ghc-lib-parser-8.10.2.20200808/compiler/0000755000000000000000000000000013713635773015322 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/GHC/0000755000000000000000000000000013713635665015723 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/0000755000000000000000000000000013713635665016275 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/GHC/HsToCore/0000755000000000000000000000000013713635665017411 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/GHC/HsToCore/PmCheck/0000755000000000000000000000000013713635665020723 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/backpack/0000755000000000000000000000000013713635665017061 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/0000755000000000000000000000000013713635665017430 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/cbits/0000755000000000000000000000000013713635665016426 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/cmm/0000755000000000000000000000000013713635665016076 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/coreSyn/0000755000000000000000000000000013713635665016744 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/ghci/0000755000000000000000000000000013713635665016234 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/iface/0000755000000000000000000000000013713635665016371 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/main/0000755000000000000000000000000013713635665016246 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/main/SysTools/0000755000000000000000000000000013713635665020045 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/parser/0000755000000000000000000000000013713636246016612 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/prelude/0000755000000000000000000000000013713635665016762 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/profiling/0000755000000000000000000000000013713635665017313 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/simplCore/0000755000000000000000000000000013713635665017257 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/simplStg/0000755000000000000000000000000013713635665017124 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/specialise/0000755000000000000000000000000013713635665017443 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/typecheck/0000755000000000000000000000000013713635665017301 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/types/0000755000000000000000000000000013713635665016466 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/utils/0000755000000000000000000000000013713635665016462 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/ghc-lib/0000755000000000000000000000000013713636006015003 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/0000755000000000000000000000000013713636042016166 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/0000755000000000000000000000000013713636236020005 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/0000755000000000000000000000000013713636243021102 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/lib/0000755000000000000000000000000013713636042016734 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/libraries/0000755000000000000000000000000013713636006020142 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/libraries/ghc-boot/0000755000000000000000000000000013713636145021650 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/libraries/ghc-boot/build/0000755000000000000000000000000013713636156022751 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/libraries/ghc-boot/build/GHC/0000755000000000000000000000000013713636155023351 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/includes/0000755000000000000000000000000013713635665015316 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/includes/stg/0000755000000000000000000000000013713635665016113 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/0000755000000000000000000000000013713635773015464 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot/0000755000000000000000000000000013713635773017166 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot-th/0000755000000000000000000000000013713635773017577 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot-th/GHC/0000755000000000000000000000000013713635665020200 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot-th/GHC/ForeignSrcLang/0000755000000000000000000000000013713635662023040 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot-th/GHC/LanguageExtensions/0000755000000000000000000000000013713635665024003 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot/GHC/0000755000000000000000000000000013713635665017567 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/ghc-heap/0000755000000000000000000000000013713635773017140 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/ghc-heap/GHC/0000755000000000000000000000000013713635662017536 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/ghc-heap/GHC/Exts/0000755000000000000000000000000013713635665020464 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/ghc-heap/GHC/Exts/Heap/0000755000000000000000000000000013713635665021341 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/0000755000000000000000000000000013713635665023204 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/ghc-heap/cbits/0000755000000000000000000000000013713635662020241 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/ghci/0000755000000000000000000000000013713635773016376 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/ghci/GHCi/0000755000000000000000000000000013713635665017150 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/ghci/GHCi/TH/0000755000000000000000000000000013713635665017463 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/template-haskell/0000755000000000000000000000000013713635773020720 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/template-haskell/Language/0000755000000000000000000000000013713635662022440 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/template-haskell/Language/Haskell/0000755000000000000000000000000013713635665024026 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/template-haskell/Language/Haskell/TH/0000755000000000000000000000000013713635665024341 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/libraries/template-haskell/Language/Haskell/TH/Lib/0000755000000000000000000000000013713635665025047 5ustar0000000000000000ghc-lib-parser-8.10.2.20200808/compiler/main/Annotations.hs0000644000000000000000000001126713713635745021105 0ustar0000000000000000-- | -- Support for source code annotation feature of GHC. That is the ANN pragma. -- -- (c) The University of Glasgow 2006 -- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -- {-# LANGUAGE DeriveFunctor #-} module Annotations ( -- * Main Annotation data types Annotation(..), AnnPayload, AnnTarget(..), CoreAnnTarget, getAnnTargetName_maybe, -- * AnnEnv for collecting and querying Annotations AnnEnv, mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns, findAnnsByTypeRep, deserializeAnns ) where import GhcPrelude import Binary import Module ( Module ) import Name import Outputable import GHC.Serialized import UniqFM import Unique import Control.Monad import Data.Maybe import Data.Typeable import Data.Word ( Word8 ) -- | Represents an annotation after it has been sufficiently desugared from -- it's initial form of 'HsDecls.AnnDecl' data Annotation = Annotation { ann_target :: CoreAnnTarget, -- ^ The target of the annotation ann_value :: AnnPayload } type AnnPayload = Serialized -- ^ The "payload" of an annotation -- allows recovery of its value at a given type, -- and can be persisted to an interface file -- | An annotation target data AnnTarget name = NamedTarget name -- ^ We are annotating something with a name: -- a type or identifier | ModuleTarget Module -- ^ We are annotating a particular module deriving (Functor) -- | The kind of annotation target found in the middle end of the compiler type CoreAnnTarget = AnnTarget Name -- | Get the 'name' of an annotation target if it exists. getAnnTargetName_maybe :: AnnTarget name -> Maybe name getAnnTargetName_maybe (NamedTarget nm) = Just nm getAnnTargetName_maybe _ = Nothing instance Uniquable name => Uniquable (AnnTarget name) where getUnique (NamedTarget nm) = getUnique nm getUnique (ModuleTarget mod) = deriveUnique (getUnique mod) 0 -- deriveUnique prevents OccName uniques clashing with NamedTarget instance Outputable name => Outputable (AnnTarget name) where ppr (NamedTarget nm) = text "Named target" <+> ppr nm ppr (ModuleTarget mod) = text "Module target" <+> ppr mod instance Binary name => Binary (AnnTarget name) where put_ bh (NamedTarget a) = do putByte bh 0 put_ bh a put_ bh (ModuleTarget a) = do putByte bh 1 put_ bh a get bh = do h <- getByte bh case h of 0 -> liftM NamedTarget $ get bh _ -> liftM ModuleTarget $ get bh instance Outputable Annotation where ppr ann = ppr (ann_target ann) -- | A collection of annotations -- Can't use a type synonym or we hit bug #2412 due to source import newtype AnnEnv = MkAnnEnv (UniqFM [AnnPayload]) -- | An empty annotation environment. emptyAnnEnv :: AnnEnv emptyAnnEnv = MkAnnEnv emptyUFM -- | Construct a new annotation environment that contains the list of -- annotations provided. mkAnnEnv :: [Annotation] -> AnnEnv mkAnnEnv = extendAnnEnvList emptyAnnEnv -- | Add the given annotation to the environment. extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv extendAnnEnvList (MkAnnEnv env) anns = MkAnnEnv $ addListToUFM_C (++) env $ map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns -- | Union two annotation environments. plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2 -- | Find the annotations attached to the given target as 'Typeable' -- values of your choice. If no deserializer is specified, -- only transient annotations will be returned. findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a] findAnns deserialize (MkAnnEnv ann_env) = (mapMaybe (fromSerialized deserialize)) . (lookupWithDefaultUFM ann_env []) -- | Find the annotations attached to the given target as 'Typeable' -- values of your choice. If no deserializer is specified, -- only transient annotations will be returned. findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]] findAnnsByTypeRep (MkAnnEnv ann_env) target tyrep = [ ws | Serialized tyrep' ws <- lookupWithDefaultUFM ann_env [] target , tyrep' == tyrep ] -- | Deserialize all annotations of a given type. This happens lazily, that is -- no deserialization will take place until the [a] is actually demanded and -- the [a] can also be empty (the UniqFM is not filtered). deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a] deserializeAnns deserialize (MkAnnEnv ann_env) = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env ghc-lib-parser-8.10.2.20200808/compiler/parser/ApiAnnotation.hs0000644000000000000000000003007713713635745021724 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module ApiAnnotation ( getAnnotation, getAndRemoveAnnotation, getAnnotationComments,getAndRemoveAnnotationComments, ApiAnns, ApiAnnKey, AnnKeywordId(..), AnnotationComment(..), IsUnicodeSyntax(..), unicodeAnn, HasE(..), LRdrName -- Exists for haddocks only ) where import GhcPrelude import RdrName import Outputable import SrcLoc import qualified Data.Map as Map import Data.Data {- Note [Api annotations] ~~~~~~~~~~~~~~~~~~~~~~ Given a parse tree of a Haskell module, how can we reconstruct the original Haskell source code, retaining all whitespace and source code comments? We need to track the locations of all elements from the original source: this includes keywords such as 'let' / 'in' / 'do' etc as well as punctuation such as commas and braces, and also comments. We collectively refer to this metadata as the "API annotations". Rather than annotate the resulting parse tree with these locations directly (this would be a major change to some fairly core data structures in GHC), we instead capture locations for these elements in a structure separate from the parse tree, and returned in the pm_annotations field of the ParsedModule type. The full ApiAnns type is > type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan] -- non-comments > , Map.Map SrcSpan [Located AnnotationComment]) -- comments NON-COMMENT ELEMENTS Intuitively, every AST element directly contains a bag of keywords (keywords can show up more than once in a node: a semicolon i.e. newline can show up multiple times before the next AST element), each of which needs to be associated with its location in the original source code. Consequently, the structure that records non-comment elements is logically a two level map, from the SrcSpan of the AST element containing it, to a map from keywords ('AnnKeyWord') to all locations of the keyword directly in the AST element: > type ApiAnnKey = (SrcSpan,AnnKeywordId) > > Map.Map ApiAnnKey [SrcSpan] So > let x = 1 in 2 *x would result in the AST element L span (HsLet (binds for x = 1) (2 * x)) and the annotations (span,AnnLet) having the location of the 'let' keyword (span,AnnEqual) having the location of the '=' sign (span,AnnIn) having the location of the 'in' keyword For any given element in the AST, there is only a set number of keywords that are applicable for it (e.g., you'll never see an 'import' keyword associated with a let-binding.) The set of allowed keywords is documented in a comment associated with the constructor of a given AST element, although the ground truth is in Parser and RdrHsSyn (which actually add the annotations; see #13012). COMMENT ELEMENTS Every comment is associated with a *located* AnnotationComment. We associate comments with the lowest (most specific) AST element enclosing them: > Map.Map SrcSpan [Located AnnotationComment] PARSER STATE There are three fields in PState (the parser state) which play a role with annotations. > annotations :: [(ApiAnnKey,[SrcSpan])], > comment_q :: [Located AnnotationComment], > annotations_comments :: [(SrcSpan,[Located AnnotationComment])] The 'annotations' and 'annotations_comments' fields are simple: they simply accumulate annotations that will end up in 'ApiAnns' at the end (after they are passed to Map.fromList). The 'comment_q' field captures comments as they are seen in the token stream, so that when they are ready to be allocated via the parser they are available (at the time we lex a comment, we don't know what the enclosing AST node of it is, so we can't associate it with a SrcSpan in annotations_comments). PARSER EMISSION OF ANNOTATIONS The parser interacts with the lexer using the function > addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () which takes the AST element SrcSpan, the annotation keyword and the target SrcSpan. This adds the annotation to the `annotations` field of `PState` and transfers any comments in `comment_q` WHICH ARE ENCLOSED by the SrcSpan of this element to the `annotations_comments` field. (Comments which are outside of this annotation are deferred until later. 'allocateComments' in 'Lexer' is responsible for making sure we only attach comments that actually fit in the 'SrcSpan'.) The wiki page describing this feature is https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations -} -- --------------------------------------------------------------------- -- If you update this, update the Note [Api annotations] above type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan] , Map.Map SrcSpan [Located AnnotationComment]) -- If you update this, update the Note [Api annotations] above type ApiAnnKey = (SrcSpan,AnnKeywordId) -- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' -- of the annotated AST element, and the known type of the annotation. getAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId -> [SrcSpan] getAnnotation (anns,_) span ann = case Map.lookup (span,ann) anns of Nothing -> [] Just ss -> ss -- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' -- of the annotated AST element, and the known type of the annotation. -- The list is removed from the annotations. getAndRemoveAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId -> ([SrcSpan],ApiAnns) getAndRemoveAnnotation (anns,cs) span ann = case Map.lookup (span,ann) anns of Nothing -> ([],(anns,cs)) Just ss -> (ss,(Map.delete (span,ann) anns,cs)) -- |Retrieve the comments allocated to the current 'SrcSpan' -- -- Note: A given 'SrcSpan' may appear in multiple AST elements, -- beware of duplicates getAnnotationComments :: ApiAnns -> SrcSpan -> [Located AnnotationComment] getAnnotationComments (_,anns) span = case Map.lookup span anns of Just cs -> cs Nothing -> [] -- |Retrieve the comments allocated to the current 'SrcSpan', and -- remove them from the annotations getAndRemoveAnnotationComments :: ApiAnns -> SrcSpan -> ([Located AnnotationComment],ApiAnns) getAndRemoveAnnotationComments (anns,canns) span = case Map.lookup span canns of Just cs -> (cs,(anns,Map.delete span canns)) Nothing -> ([],(anns,canns)) -- -------------------------------------------------------------------- -- | API Annotations exist so that tools can perform source to source -- conversions of Haskell code. They are used to keep track of the -- various syntactic keywords that are not captured in the existing -- AST. -- -- The annotations, together with original source comments are made -- available in the @'pm_annotations'@ field of @'GHC.ParsedModule'@. -- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set in -- @'DynFlags.DynFlags'@ before parsing. -- -- The wiki page describing this feature is -- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations -- -- Note: in general the names of these are taken from the -- corresponding token, unless otherwise noted -- See note [Api annotations] above for details of the usage data AnnKeywordId = AnnAnyclass | AnnAs | AnnAt | AnnBang -- ^ '!' | AnnBackquote -- ^ '`' | AnnBy | AnnCase -- ^ case or lambda case | AnnClass | AnnClose -- ^ '\#)' or '\#-}' etc | AnnCloseB -- ^ '|)' | AnnCloseBU -- ^ '|)', unicode variant | AnnCloseC -- ^ '}' | AnnCloseQ -- ^ '|]' | AnnCloseQU -- ^ '|]', unicode variant | AnnCloseP -- ^ ')' | AnnCloseS -- ^ ']' | AnnColon | AnnComma -- ^ as a list separator | AnnCommaTuple -- ^ in a RdrName for a tuple | AnnDarrow -- ^ '=>' | AnnDarrowU -- ^ '=>', unicode variant | AnnData | AnnDcolon -- ^ '::' | AnnDcolonU -- ^ '::', unicode variant | AnnDefault | AnnDeriving | AnnDo | AnnDot -- ^ '.' | AnnDotdot -- ^ '..' | AnnElse | AnnEqual | AnnExport | AnnFamily | AnnForall | AnnForallU -- ^ Unicode variant | AnnForeign | AnnFunId -- ^ for function name in matches where there are -- multiple equations for the function. | AnnGroup | AnnHeader -- ^ for CType | AnnHiding | AnnIf | AnnImport | AnnIn | AnnInfix -- ^ 'infix' or 'infixl' or 'infixr' | AnnInstance | AnnLam | AnnLarrow -- ^ '<-' | AnnLarrowU -- ^ '<-', unicode variant | AnnLet | AnnMdo | AnnMinus -- ^ '-' | AnnModule | AnnNewtype | AnnName -- ^ where a name loses its location in the AST, this carries it | AnnOf | AnnOpen -- ^ '(\#' or '{-\# LANGUAGE' etc | AnnOpenB -- ^ '(|' | AnnOpenBU -- ^ '(|', unicode variant | AnnOpenC -- ^ '{' | AnnOpenE -- ^ '[e|' or '[e||' | AnnOpenEQ -- ^ '[|' | AnnOpenEQU -- ^ '[|', unicode variant | AnnOpenP -- ^ '(' | AnnOpenPE -- ^ '$(' | AnnOpenPTE -- ^ '$$(' | AnnOpenS -- ^ '[' | AnnPackageName | AnnPattern | AnnProc | AnnQualified | AnnRarrow -- ^ '->' | AnnRarrowU -- ^ '->', unicode variant | AnnRec | AnnRole | AnnSafe | AnnSemi -- ^ ';' | AnnSimpleQuote -- ^ ''' | AnnSignature | AnnStatic -- ^ 'static' | AnnStock | AnnThen | AnnThIdSplice -- ^ '$' | AnnThIdTySplice -- ^ '$$' | AnnThTyQuote -- ^ double ''' | AnnTilde -- ^ '~' | AnnType | AnnUnit -- ^ '()' for types | AnnUsing | AnnVal -- ^ e.g. INTEGER | AnnValStr -- ^ String value, will need quotes when output | AnnVbar -- ^ '|' | AnnVia -- ^ 'via' | AnnWhere | Annlarrowtail -- ^ '-<' | AnnlarrowtailU -- ^ '-<', unicode variant | Annrarrowtail -- ^ '->' | AnnrarrowtailU -- ^ '->', unicode variant | AnnLarrowtail -- ^ '-<<' | AnnLarrowtailU -- ^ '-<<', unicode variant | AnnRarrowtail -- ^ '>>-' | AnnRarrowtailU -- ^ '>>-', unicode variant | AnnEofPos deriving (Eq, Ord, Data, Show) instance Outputable AnnKeywordId where ppr x = text (show x) -- --------------------------------------------------------------------- data AnnotationComment = -- Documentation annotations AnnDocCommentNext String -- ^ something beginning '-- |' | AnnDocCommentPrev String -- ^ something beginning '-- ^' | AnnDocCommentNamed String -- ^ something beginning '-- $' | AnnDocSection Int String -- ^ a section heading | AnnDocOptions String -- ^ doc options (prune, ignore-exports, etc) | AnnLineComment String -- ^ comment starting by "--" | AnnBlockComment String -- ^ comment in {- -} deriving (Eq, Ord, Data, Show) -- Note: these are based on the Token versions, but the Token type is -- defined in Lexer.x and bringing it in here would create a loop instance Outputable AnnotationComment where ppr x = text (show x) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma', -- 'ApiAnnotation.AnnRarrow' -- 'ApiAnnotation.AnnTilde' -- - May have 'ApiAnnotation.AnnComma' when in a list type LRdrName = Located RdrName -- | Certain tokens can have alternate representations when unicode syntax is -- enabled. This flag is attached to those tokens in the lexer so that the -- original source representation can be reproduced in the corresponding -- 'ApiAnnotation' data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax deriving (Eq, Ord, Data, Show) -- | Convert a normal annotation into its unicode equivalent one unicodeAnn :: AnnKeywordId -> AnnKeywordId unicodeAnn AnnForall = AnnForallU unicodeAnn AnnDcolon = AnnDcolonU unicodeAnn AnnLarrow = AnnLarrowU unicodeAnn AnnRarrow = AnnRarrowU unicodeAnn AnnDarrow = AnnDarrowU unicodeAnn Annlarrowtail = AnnlarrowtailU unicodeAnn Annrarrowtail = AnnrarrowtailU unicodeAnn AnnLarrowtail = AnnLarrowtailU unicodeAnn AnnRarrowtail = AnnRarrowtailU unicodeAnn AnnOpenB = AnnOpenBU unicodeAnn AnnCloseB = AnnCloseBU unicodeAnn AnnOpenEQ = AnnOpenEQU unicodeAnn AnnCloseQ = AnnCloseQU unicodeAnn ann = ann -- | Some template haskell tokens have two variants, one with an `e` the other -- not: -- -- > [| or [e| -- > [|| or [e|| -- -- This type indicates whether the 'e' is present or not. data HasE = HasE | NoE deriving (Eq, Ord, Data, Show) ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/Avail.hs0000644000000000000000000002324213713635744021021 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -- -- (c) The University of Glasgow -- #include "GhclibHsVersions.h" module Avail ( Avails, AvailInfo(..), avail, availsToNameSet, availsToNameSetWithSelectors, availsToNameEnv, availName, availNames, availNonFldNames, availNamesWithSelectors, availFlds, availsNamesWithOccs, availNamesWithOccs, stableAvailCmp, plusAvail, trimAvail, filterAvail, filterAvails, nubAvails ) where import GhcPrelude import Name import NameEnv import NameSet import FieldLabel import Binary import ListSetOps import Outputable import Util import Data.Data ( Data ) import Data.List ( find ) import Data.Function -- ----------------------------------------------------------------------------- -- The AvailInfo type -- | Records what things are \"available\", i.e. in scope data AvailInfo -- | An ordinary identifier in scope = Avail Name -- | A type or class in scope -- -- The __AvailTC Invariant__: If the type or class is itself to be in scope, -- it must be /first/ in this list. Thus, typically: -- -- > AvailTC Eq [Eq, ==, \/=] [] | AvailTC Name -- ^ The name of the type or class [Name] -- ^ The available pieces of type or class, -- excluding field selectors. [FieldLabel] -- ^ The record fields of the type -- (see Note [Representing fields in AvailInfo]). deriving ( Eq -- ^ Used when deciding if the interface has changed , Data ) -- | A collection of 'AvailInfo' - several things that are \"available\" type Avails = [AvailInfo] {- Note [Representing fields in AvailInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When -XDuplicateRecordFields is disabled (the normal case), a datatype like data T = MkT { foo :: Int } gives rise to the AvailInfo AvailTC T [T, MkT] [FieldLabel "foo" False foo] whereas if -XDuplicateRecordFields is enabled it gives AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT] since the label does not match the selector name. The labels in a field list are not necessarily unique: data families allow the same parent (the family tycon) to have multiple distinct fields with the same label. For example, data family F a data instance F Int = MkFInt { foo :: Int } data instance F Bool = MkFBool { foo :: Bool} gives rise to AvailTC F [ F, MkFInt, MkFBool ] [ FieldLabel "foo" True $sel:foo:MkFInt , FieldLabel "foo" True $sel:foo:MkFBool ] Moreover, note that the flIsOverloaded flag need not be the same for all the elements of the list. In the example above, this occurs if the two data instances are defined in different modules, one with `-XDuplicateRecordFields` enabled and one with it disabled. Thus it is possible to have AvailTC F [ F, MkFInt, MkFBool ] [ FieldLabel "foo" True $sel:foo:MkFInt , FieldLabel "foo" False foo ] If the two data instances are defined in different modules, both without `-XDuplicateRecordFields`, it will be impossible to export them from the same module (even with `-XDuplicateRecordfields` enabled), because they would be represented identically. The workaround here is to enable `-XDuplicateRecordFields` on the defining modules. -} -- | Compare lexicographically stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2 stableAvailCmp (Avail {}) (AvailTC {}) = LT stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) = (n `stableNameCmp` m) `thenCmp` (cmpList stableNameCmp ns ms) `thenCmp` (cmpList (stableNameCmp `on` flSelector) nfs mfs) stableAvailCmp (AvailTC {}) (Avail {}) = GT avail :: Name -> AvailInfo avail n = Avail n -- ----------------------------------------------------------------------------- -- Operations on AvailInfo availsToNameSet :: [AvailInfo] -> NameSet availsToNameSet avails = foldr add emptyNameSet avails where add avail set = extendNameSetList set (availNames avail) availsToNameSetWithSelectors :: [AvailInfo] -> NameSet availsToNameSetWithSelectors avails = foldr add emptyNameSet avails where add avail set = extendNameSetList set (availNamesWithSelectors avail) availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo availsToNameEnv avails = foldr add emptyNameEnv avails where add avail env = extendNameEnvList env (zip (availNames avail) (repeat avail)) -- | Just the main name made available, i.e. not the available pieces -- of type or class brought into scope by the 'GenAvailInfo' availName :: AvailInfo -> Name availName (Avail n) = n availName (AvailTC n _ _) = n -- | All names made available by the availability information (excluding overloaded selectors) availNames :: AvailInfo -> [Name] availNames (Avail n) = [n] availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ] -- | All names made available by the availability information (including overloaded selectors) availNamesWithSelectors :: AvailInfo -> [Name] availNamesWithSelectors (Avail n) = [n] availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs -- | Names for non-fields made available by the availability information availNonFldNames :: AvailInfo -> [Name] availNonFldNames (Avail n) = [n] availNonFldNames (AvailTC _ ns _) = ns -- | Fields made available by the availability information availFlds :: AvailInfo -> [FieldLabel] availFlds (AvailTC _ _ fs) = fs availFlds _ = [] availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)] availsNamesWithOccs = concatMap availNamesWithOccs -- | 'Name's made available by the availability information, paired with -- the 'OccName' used to refer to each one. -- -- When @DuplicateRecordFields@ is in use, the 'Name' may be the -- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the -- 'OccName' will be the label of the field (e.g. @foo@). -- -- See Note [Representing fields in AvailInfo]. availNamesWithOccs :: AvailInfo -> [(Name, OccName)] availNamesWithOccs (Avail n) = [(n, nameOccName n)] availNamesWithOccs (AvailTC _ ns fs) = [ (n, nameOccName n) | n <- ns ] ++ [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ] -- ----------------------------------------------------------------------------- -- Utility plusAvail :: AvailInfo -> AvailInfo -> AvailInfo plusAvail a1 a2 | debugIsOn && availName a1 /= availName a2 = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2]) plusAvail a1@(Avail {}) (Avail {}) = a1 plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2 plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1 plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2) = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) (fs1 `unionLists` fs2) (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) (fs1 `unionLists` fs2) (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) (fs1 `unionLists` fs2) (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) (fs1 `unionLists` fs2) plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2) = AvailTC n1 ss1 (fs1 `unionLists` fs2) plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2) = AvailTC n1 ss2 (fs1 `unionLists` fs2) plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) -- | trims an 'AvailInfo' to keep only a single name trimAvail :: AvailInfo -> Name -> AvailInfo trimAvail (Avail n) _ = Avail n trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of Just x -> AvailTC n [] [x] Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] [] -- | filters 'AvailInfo's by the given predicate filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo] filterAvails keep avails = foldr (filterAvail keep) [] avails -- | filters an 'AvailInfo' by the given predicate filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] filterAvail keep ie rest = case ie of Avail n | keep n -> ie : rest | otherwise -> rest AvailTC tc ns fs -> let ns' = filter keep ns fs' = filter (keep . flSelector) fs in if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest -- | Combines 'AvailInfo's from the same family -- 'avails' may have several items with the same availName -- E.g import Ix( Ix(..), index ) -- will give Ix(Ix,index,range) and Ix(index) -- We want to combine these; addAvail does that nubAvails :: [AvailInfo] -> [AvailInfo] nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails) where add env avail = extendNameEnv_C plusAvail env (availName avail) avail -- ----------------------------------------------------------------------------- -- Printing instance Outputable AvailInfo where ppr = pprAvail pprAvail :: AvailInfo -> SDoc pprAvail (Avail n) = ppr n pprAvail (AvailTC n ns fs) = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi , fsep (punctuate comma (map (ppr . flLabel) fs))]) instance Binary AvailInfo where put_ bh (Avail aa) = do putByte bh 0 put_ bh aa put_ bh (AvailTC ab ac ad) = do putByte bh 1 put_ bh ab put_ bh ac put_ bh ad get bh = do h <- getByte bh case h of 0 -> do aa <- get bh return (Avail aa) _ -> do ab <- get bh ac <- get bh ad <- get bh return (AvailTC ab ac ad) ghc-lib-parser-8.10.2.20200808/compiler/utils/Bag.hs0000644000000000000000000003034013713635745017506 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 Bag: an unordered collection with duplicates -} {-# LANGUAGE ScopedTypeVariables, CPP, DeriveFunctor #-} module Bag ( Bag, -- abstract type emptyBag, unitBag, unionBags, unionManyBags, mapBag, elemBag, lengthBag, filterBag, partitionBag, partitionBagWith, concatBag, catBagMaybes, foldBag, isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag, listToBag, bagToList, mapAccumBagL, concatMapBag, concatMapBagPair, mapMaybeBag, mapBagM, mapBagM_, flatMapBagM, flatMapBagPairM, mapAndUnzipBagM, mapAccumBagLM, anyBagM, filterBagM ) where import GhcPrelude import Outputable import Util import MonadUtils import Control.Monad import Data.Data import Data.Maybe( mapMaybe ) import Data.List ( partition, mapAccumL ) import qualified Data.Foldable as Foldable infixr 3 `consBag` infixl 3 `snocBag` data Bag a = EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty | ListBag [a] -- INVARIANT: the list is non-empty deriving (Functor) emptyBag :: Bag a emptyBag = EmptyBag unitBag :: a -> Bag a unitBag = UnitBag lengthBag :: Bag a -> Int lengthBag EmptyBag = 0 lengthBag (UnitBag {}) = 1 lengthBag (TwoBags b1 b2) = lengthBag b1 + lengthBag b2 lengthBag (ListBag xs) = length xs elemBag :: Eq a => a -> Bag a -> Bool elemBag _ EmptyBag = False elemBag x (UnitBag y) = x == y elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2 elemBag x (ListBag ys) = any (x ==) ys unionManyBags :: [Bag a] -> Bag a unionManyBags xs = foldr unionBags EmptyBag xs -- This one is a bit stricter! The bag will get completely evaluated. unionBags :: Bag a -> Bag a -> Bag a unionBags EmptyBag b = b unionBags b EmptyBag = b unionBags b1 b2 = TwoBags b1 b2 consBag :: a -> Bag a -> Bag a snocBag :: Bag a -> a -> Bag a consBag elt bag = (unitBag elt) `unionBags` bag snocBag bag elt = bag `unionBags` (unitBag elt) isEmptyBag :: Bag a -> Bool isEmptyBag EmptyBag = True isEmptyBag _ = False -- NB invariants isSingletonBag :: Bag a -> Bool isSingletonBag EmptyBag = False isSingletonBag (UnitBag _) = True isSingletonBag (TwoBags _ _) = False -- Neither is empty isSingletonBag (ListBag xs) = isSingleton xs filterBag :: (a -> Bool) -> Bag a -> Bag a filterBag _ EmptyBag = EmptyBag filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2 where sat1 = filterBag pred b1 sat2 = filterBag pred b2 filterBag pred (ListBag vs) = listToBag (filter pred vs) filterBagM :: Monad m => (a -> m Bool) -> Bag a -> m (Bag a) filterBagM _ EmptyBag = return EmptyBag filterBagM pred b@(UnitBag val) = do flag <- pred val if flag then return b else return EmptyBag filterBagM pred (TwoBags b1 b2) = do sat1 <- filterBagM pred b1 sat2 <- filterBagM pred b2 return (sat1 `unionBags` sat2) filterBagM pred (ListBag vs) = do sat <- filterM pred vs return (listToBag sat) allBag :: (a -> Bool) -> Bag a -> Bool allBag _ EmptyBag = True allBag p (UnitBag v) = p v allBag p (TwoBags b1 b2) = allBag p b1 && allBag p b2 allBag p (ListBag xs) = all p xs anyBag :: (a -> Bool) -> Bag a -> Bool anyBag _ EmptyBag = False anyBag p (UnitBag v) = p v anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2 anyBag p (ListBag xs) = any p xs anyBagM :: Monad m => (a -> m Bool) -> Bag a -> m Bool anyBagM _ EmptyBag = return False anyBagM p (UnitBag v) = p v anyBagM p (TwoBags b1 b2) = do flag <- anyBagM p b1 if flag then return True else anyBagM p b2 anyBagM p (ListBag xs) = anyM p xs concatBag :: Bag (Bag a) -> Bag a concatBag bss = foldr add emptyBag bss where add bs rs = bs `unionBags` rs catBagMaybes :: Bag (Maybe a) -> Bag a catBagMaybes bs = foldr add emptyBag bs where add Nothing rs = rs add (Just x) rs = x `consBag` rs partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, Bag a {- Don't -}) partitionBag _ EmptyBag = (EmptyBag, EmptyBag) partitionBag pred b@(UnitBag val) = if pred val then (b, EmptyBag) else (EmptyBag, b) partitionBag pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) where (sat1, fail1) = partitionBag pred b1 (sat2, fail2) = partitionBag pred b2 partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails) where (sats, fails) = partition pred vs partitionBagWith :: (a -> Either b c) -> Bag a -> (Bag b {- Left -}, Bag c {- Right -}) partitionBagWith _ EmptyBag = (EmptyBag, EmptyBag) partitionBagWith pred (UnitBag val) = case pred val of Left a -> (UnitBag a, EmptyBag) Right b -> (EmptyBag, UnitBag b) partitionBagWith pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) where (sat1, fail1) = partitionBagWith pred b1 (sat2, fail2) = partitionBagWith pred b2 partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails) where (sats, fails) = partitionWith pred vs foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative -> (a -> r) -- Replace UnitBag with this -> r -- Replace EmptyBag with this -> Bag a -> r {- Standard definition foldBag t u e EmptyBag = e foldBag t u e (UnitBag x) = u x foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2) foldBag t u e (ListBag xs) = foldr (t.u) e xs -} -- More tail-recursive definition, exploiting associativity of "t" foldBag _ _ e EmptyBag = e foldBag t u e (UnitBag x) = u x `t` e foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1 foldBag t u e (ListBag xs) = foldr (t.u) e xs mapBag :: (a -> b) -> Bag a -> Bag b mapBag = fmap concatMapBag :: (a -> Bag b) -> Bag a -> Bag b concatMapBag _ EmptyBag = EmptyBag concatMapBag f (UnitBag x) = f x concatMapBag f (TwoBags b1 b2) = unionBags (concatMapBag f b1) (concatMapBag f b2) concatMapBag f (ListBag xs) = foldr (unionBags . f) emptyBag xs concatMapBagPair :: (a -> (Bag b, Bag c)) -> Bag a -> (Bag b, Bag c) concatMapBagPair _ EmptyBag = (EmptyBag, EmptyBag) concatMapBagPair f (UnitBag x) = f x concatMapBagPair f (TwoBags b1 b2) = (unionBags r1 r2, unionBags s1 s2) where (r1, s1) = concatMapBagPair f b1 (r2, s2) = concatMapBagPair f b2 concatMapBagPair f (ListBag xs) = foldr go (emptyBag, emptyBag) xs where go a (s1, s2) = (unionBags r1 s1, unionBags r2 s2) where (r1, r2) = f a mapMaybeBag :: (a -> Maybe b) -> Bag a -> Bag b mapMaybeBag _ EmptyBag = EmptyBag mapMaybeBag f (UnitBag x) = case f x of Nothing -> EmptyBag Just y -> UnitBag y mapMaybeBag f (TwoBags b1 b2) = unionBags (mapMaybeBag f b1) (mapMaybeBag f b2) mapMaybeBag f (ListBag xs) = ListBag (mapMaybe f xs) mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) mapBagM _ EmptyBag = return EmptyBag mapBagM f (UnitBag x) = do r <- f x return (UnitBag r) mapBagM f (TwoBags b1 b2) = do r1 <- mapBagM f b1 r2 <- mapBagM f b2 return (TwoBags r1 r2) mapBagM f (ListBag xs) = do rs <- mapM f xs return (ListBag rs) mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m () mapBagM_ _ EmptyBag = return () mapBagM_ f (UnitBag x) = f x >> return () mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2 mapBagM_ f (ListBag xs) = mapM_ f xs flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b) flatMapBagM _ EmptyBag = return EmptyBag flatMapBagM f (UnitBag x) = f x flatMapBagM f (TwoBags b1 b2) = do r1 <- flatMapBagM f b1 r2 <- flatMapBagM f b2 return (r1 `unionBags` r2) flatMapBagM f (ListBag xs) = foldrM k EmptyBag xs where k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) } flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c) flatMapBagPairM _ EmptyBag = return (EmptyBag, EmptyBag) flatMapBagPairM f (UnitBag x) = f x flatMapBagPairM f (TwoBags b1 b2) = do (r1,s1) <- flatMapBagPairM f b1 (r2,s2) <- flatMapBagPairM f b2 return (r1 `unionBags` r2, s1 `unionBags` s2) flatMapBagPairM f (ListBag xs) = foldrM k (EmptyBag, EmptyBag) xs where k x (r2,s2) = do { (r1,s1) <- f x ; return (r1 `unionBags` r2, s1 `unionBags` s2) } mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c) mapAndUnzipBagM _ EmptyBag = return (EmptyBag, EmptyBag) mapAndUnzipBagM f (UnitBag x) = do (r,s) <- f x return (UnitBag r, UnitBag s) mapAndUnzipBagM f (TwoBags b1 b2) = do (r1,s1) <- mapAndUnzipBagM f b1 (r2,s2) <- mapAndUnzipBagM f b2 return (TwoBags r1 r2, TwoBags s1 s2) mapAndUnzipBagM f (ListBag xs) = do ts <- mapM f xs let (rs,ss) = unzip ts return (ListBag rs, ListBag ss) mapAccumBagL ::(acc -> x -> (acc, y)) -- ^ combining function -> acc -- ^ initial state -> Bag x -- ^ inputs -> (acc, Bag y) -- ^ final state, outputs mapAccumBagL _ s EmptyBag = (s, EmptyBag) mapAccumBagL f s (UnitBag x) = let (s1, x1) = f s x in (s1, UnitBag x1) mapAccumBagL f s (TwoBags b1 b2) = let (s1, b1') = mapAccumBagL f s b1 (s2, b2') = mapAccumBagL f s1 b2 in (s2, TwoBags b1' b2') mapAccumBagL f s (ListBag xs) = let (s', xs') = mapAccumL f s xs in (s', ListBag xs') mapAccumBagLM :: Monad m => (acc -> x -> m (acc, y)) -- ^ combining function -> acc -- ^ initial state -> Bag x -- ^ inputs -> m (acc, Bag y) -- ^ final state, outputs mapAccumBagLM _ s EmptyBag = return (s, EmptyBag) mapAccumBagLM f s (UnitBag x) = do { (s1, x1) <- f s x; return (s1, UnitBag x1) } mapAccumBagLM f s (TwoBags b1 b2) = do { (s1, b1') <- mapAccumBagLM f s b1 ; (s2, b2') <- mapAccumBagLM f s1 b2 ; return (s2, TwoBags b1' b2') } mapAccumBagLM f s (ListBag xs) = do { (s', xs') <- mapAccumLM f s xs ; return (s', ListBag xs') } listToBag :: [a] -> Bag a listToBag [] = EmptyBag listToBag [x] = UnitBag x listToBag vs = ListBag vs bagToList :: Bag a -> [a] bagToList b = foldr (:) [] b instance (Outputable a) => Outputable (Bag a) where ppr bag = braces (pprWithCommas ppr (bagToList bag)) instance Data a => Data (Bag a) where gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly toConstr _ = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Bag" dataCast1 x = gcast1 x instance Foldable.Foldable Bag where foldr _ z EmptyBag = z foldr k z (UnitBag x) = k x z foldr k z (TwoBags b1 b2) = foldr k (foldr k z b2) b1 foldr k z (ListBag xs) = foldr k z xs foldl _ z EmptyBag = z foldl k z (UnitBag x) = k z x foldl k z (TwoBags b1 b2) = foldl k (foldl k z b1) b2 foldl k z (ListBag xs) = foldl k z xs foldl' _ z EmptyBag = z foldl' k z (UnitBag x) = k z x foldl' k z (TwoBags b1 b2) = let r1 = foldl' k z b1 in seq r1 $ foldl' k r1 b2 foldl' k z (ListBag xs) = foldl' k z xs instance Traversable Bag where traverse _ EmptyBag = pure EmptyBag traverse f (UnitBag x) = UnitBag <$> f x traverse f (TwoBags b1 b2) = TwoBags <$> traverse f b1 <*> traverse f b2 traverse f (ListBag xs) = ListBag <$> traverse f xs ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/BasicTypes.hs0000644000000000000000000016210313713635744022033 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 \section[BasicTypes]{Miscellanous types} This module defines a miscellaneously collection of very simple types that \begin{itemize} \item have no other obvious home \item don't depend on any other complicated types \item are used in more than one "part" of the compiler \end{itemize} -} {-# LANGUAGE DeriveDataTypeable #-} module BasicTypes( Version, bumpVersion, initialVersion, LeftOrRight(..), pickLR, ConTag, ConTagZ, fIRST_TAG, Arity, RepArity, JoinArity, Alignment, mkAlignment, alignmentOf, alignmentBytes, PromotionFlag(..), isPromoted, FunctionOrData(..), WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..), Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, minPrecedence, negateFixity, funTyFixity, compareFixity, LexicalFixity(..), RecFlag(..), isRec, isNonRec, boolToRecFlag, Origin(..), isGenerated, RuleName, pprRuleName, TopLevelFlag(..), isTopLevel, isNotTopLevel, OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, Boxity(..), isBoxed, PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, TupleSort(..), tupleSortBoxity, boxityTupleSort, tupleParens, sumParens, pprAlternative, -- ** The OneShotInfo type OneShotInfo(..), noOneShotInfo, hasNoOneShotInfo, isOneShotInfo, bestOneShot, worstOneShot, OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc, isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs, strongLoopBreaker, weakLoopBreaker, InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch, InterestingCxt, TailCallInfo(..), tailCallInfo, zapOccTailCallInfo, isAlwaysTailCalled, EP(..), DefMethSpec(..), SwapFlag(..), flipSwap, unSwap, isSwapped, CompilerPhase(..), PhaseNum, Activation(..), isActive, isActiveIn, competesWith, isNeverActive, isAlwaysActive, isEarlyActive, activeAfterInitial, activeDuringFinal, RuleMatchInfo(..), isConLike, isFunLike, InlineSpec(..), noUserInlineSpec, InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma, isDefaultInlinePragma, isInlinePragma, isInlinablePragma, isAnyInlinePragma, inlinePragmaSpec, inlinePragmaSat, inlinePragmaActivation, inlinePragmaRuleMatchInfo, setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, pprInline, pprInlineDebug, SuccessFlag(..), succeeded, failed, successIf, IntegralLit(..), FractionalLit(..), negateIntegralLit, negateFractionalLit, mkIntegralLit, mkFractionalLit, integralFractionalLit, SourceText(..), pprWithSourceText, IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit, SpliceExplicitFlag(..), TypeOrKind(..), isTypeLevel, isKindLevel ) where import GhcPrelude import FastString import Outputable import SrcLoc ( Located,unLoc ) import Data.Data hiding (Fixity, Prefix, Infix) import Data.Function (on) import Data.Bits {- ************************************************************************ * * Binary choice * * ************************************************************************ -} data LeftOrRight = CLeft | CRight deriving( Eq, Data ) pickLR :: LeftOrRight -> (a,a) -> a pickLR CLeft (l,_) = l pickLR CRight (_,r) = r instance Outputable LeftOrRight where ppr CLeft = text "Left" ppr CRight = text "Right" {- ************************************************************************ * * \subsection[Arity]{Arity} * * ************************************************************************ -} -- | The number of value arguments that can be applied to a value before it does -- "real work". So: -- fib 100 has arity 0 -- \x -> fib x has arity 1 -- See also Note [Definition of arity] in CoreArity type Arity = Int -- | Representation Arity -- -- The number of represented arguments that can be applied to a value before it does -- "real work". So: -- fib 100 has representation arity 0 -- \x -> fib x has representation arity 1 -- \(# x, y #) -> fib (x + y) has representation arity 2 type RepArity = Int -- | The number of arguments that a join point takes. Unlike the arity of a -- function, this is a purely syntactic property and is fixed when the join -- point is created (or converted from a value). Both type and value arguments -- are counted. type JoinArity = Int {- ************************************************************************ * * Constructor tags * * ************************************************************************ -} -- | Constructor Tag -- -- Type of the tags associated with each constructor possibility or superclass -- selector type ConTag = Int -- | A *zero-indexed* constructor tag type ConTagZ = Int fIRST_TAG :: ConTag -- ^ Tags are allocated from here for real constructors -- or for superclass selectors fIRST_TAG = 1 {- ************************************************************************ * * \subsection[Alignment]{Alignment} * * ************************************************************************ -} -- | A power-of-two alignment newtype Alignment = Alignment { alignmentBytes :: Int } deriving (Eq, Ord) -- Builds an alignment, throws on non power of 2 input. This is not -- ideal, but convenient for internal use and better then silently -- passing incorrect data. mkAlignment :: Int -> Alignment mkAlignment n | n == 1 = Alignment 1 | n == 2 = Alignment 2 | n == 4 = Alignment 4 | n == 8 = Alignment 8 | n == 16 = Alignment 16 | n == 32 = Alignment 32 | n == 64 = Alignment 64 | n == 128 = Alignment 128 | n == 256 = Alignment 256 | n == 512 = Alignment 512 | otherwise = panic "mkAlignment: received either a non power of 2 argument or > 512" -- Calculates an alignment of a number. x is aligned at N bytes means -- the remainder from x / N is zero. Currently, interested in N <= 8, -- but can be expanded to N <= 16 or N <= 32 if used within SSE or AVX -- context. alignmentOf :: Int -> Alignment alignmentOf x = case x .&. 7 of 0 -> Alignment 8 4 -> Alignment 4 2 -> Alignment 2 _ -> Alignment 1 instance Outputable Alignment where ppr (Alignment m) = ppr m {- ************************************************************************ * * One-shot information * * ************************************************************************ -} -- | If the 'Id' is a lambda-bound variable then it may have lambda-bound -- variable info. Sometimes we know whether the lambda binding this variable -- is a \"one-shot\" lambda; that is, whether it is applied at most once. -- -- This information may be useful in optimisation, as computations may -- safely be floated inside such a lambda without risk of duplicating -- work. data OneShotInfo = NoOneShotInfo -- ^ No information | OneShotLam -- ^ The lambda is applied at most once. deriving (Eq) -- | It is always safe to assume that an 'Id' has no lambda-bound variable information noOneShotInfo :: OneShotInfo noOneShotInfo = NoOneShotInfo isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool isOneShotInfo OneShotLam = True isOneShotInfo _ = False hasNoOneShotInfo NoOneShotInfo = True hasNoOneShotInfo _ = False worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo worstOneShot NoOneShotInfo _ = NoOneShotInfo worstOneShot OneShotLam os = os bestOneShot NoOneShotInfo os = os bestOneShot OneShotLam _ = OneShotLam pprOneShotInfo :: OneShotInfo -> SDoc pprOneShotInfo NoOneShotInfo = empty pprOneShotInfo OneShotLam = text "OneShot" instance Outputable OneShotInfo where ppr = pprOneShotInfo {- ************************************************************************ * * Swap flag * * ************************************************************************ -} data SwapFlag = NotSwapped -- Args are: actual, expected | IsSwapped -- Args are: expected, actual instance Outputable SwapFlag where ppr IsSwapped = text "Is-swapped" ppr NotSwapped = text "Not-swapped" flipSwap :: SwapFlag -> SwapFlag flipSwap IsSwapped = NotSwapped flipSwap NotSwapped = IsSwapped isSwapped :: SwapFlag -> Bool isSwapped IsSwapped = True isSwapped NotSwapped = False unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b unSwap NotSwapped f a b = f a b unSwap IsSwapped f a b = f b a {- ********************************************************************* * * Promotion flag * * ********************************************************************* -} -- | Is a TyCon a promoted data constructor or just a normal type constructor? data PromotionFlag = NotPromoted | IsPromoted deriving ( Eq, Data ) isPromoted :: PromotionFlag -> Bool isPromoted IsPromoted = True isPromoted NotPromoted = False {- ************************************************************************ * * \subsection[FunctionOrData]{FunctionOrData} * * ************************************************************************ -} data FunctionOrData = IsFunction | IsData deriving (Eq, Ord, Data) instance Outputable FunctionOrData where ppr IsFunction = text "(function)" ppr IsData = text "(data)" {- ************************************************************************ * * \subsection[Version]{Module and identifier version numbers} * * ************************************************************************ -} type Version = Int bumpVersion :: Version -> Version bumpVersion v = v+1 initialVersion :: Version initialVersion = 1 {- ************************************************************************ * * Deprecations * * ************************************************************************ -} -- | A String Literal in the source, including its original raw format for use by -- source to source manipulation tools. data StringLiteral = StringLiteral { sl_st :: SourceText, -- literal raw source. -- See not [Literal source text] sl_fs :: FastString -- literal string value } deriving Data instance Eq StringLiteral where (StringLiteral _ a) == (StringLiteral _ b) = a == b instance Outputable StringLiteral where ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl) -- | Warning Text -- -- reason/explanation from a WARNING or DEPRECATED pragma data WarningTxt = WarningTxt (Located SourceText) [Located StringLiteral] | DeprecatedTxt (Located SourceText) [Located StringLiteral] deriving (Eq, Data) instance Outputable WarningTxt where ppr (WarningTxt lsrc ws) = case unLoc lsrc of NoSourceText -> pp_ws ws SourceText src -> text src <+> pp_ws ws <+> text "#-}" ppr (DeprecatedTxt lsrc ds) = case unLoc lsrc of NoSourceText -> pp_ws ds SourceText src -> text src <+> pp_ws ds <+> text "#-}" pp_ws :: [Located StringLiteral] -> SDoc pp_ws [l] = ppr $ unLoc l pp_ws ws = text "[" <+> vcat (punctuate comma (map (ppr . unLoc) ws)) <+> text "]" pprWarningTxtForMsg :: WarningTxt -> SDoc pprWarningTxtForMsg (WarningTxt _ ws) = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws)) pprWarningTxtForMsg (DeprecatedTxt _ ds) = text "Deprecated:" <+> doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds)) {- ************************************************************************ * * Rules * * ************************************************************************ -} type RuleName = FastString pprRuleName :: RuleName -> SDoc pprRuleName rn = doubleQuotes (ftext rn) {- ************************************************************************ * * \subsection[Fixity]{Fixity info} * * ************************************************************************ -} ------------------------ data Fixity = Fixity SourceText Int FixityDirection -- Note [Pragma source text] deriving Data instance Outputable Fixity where ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec] instance Eq Fixity where -- Used to determine if two fixities conflict (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2 ------------------------ data FixityDirection = InfixL | InfixR | InfixN deriving (Eq, Data) instance Outputable FixityDirection where ppr InfixL = text "infixl" ppr InfixR = text "infixr" ppr InfixN = text "infix" ------------------------ maxPrecedence, minPrecedence :: Int maxPrecedence = 9 minPrecedence = 0 defaultFixity :: Fixity defaultFixity = Fixity NoSourceText maxPrecedence InfixL negateFixity, funTyFixity :: Fixity -- Wired-in fixities negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate funTyFixity = Fixity NoSourceText (-1) InfixR -- Fixity of '->', see #15235 {- Consider \begin{verbatim} a `op1` b `op2` c \end{verbatim} @(compareFixity op1 op2)@ tells which way to arrange application, or whether there's an error. -} compareFixity :: Fixity -> Fixity -> (Bool, -- Error please Bool) -- Associate to the right: a op1 (b op2 c) compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2) = case prec1 `compare` prec2 of GT -> left LT -> right EQ -> case (dir1, dir2) of (InfixR, InfixR) -> right (InfixL, InfixL) -> left _ -> error_please where right = (False, True) left = (False, False) error_please = (True, False) -- |Captures the fixity of declarations as they are parsed. This is not -- necessarily the same as the fixity declaration, as the normal fixity may be -- overridden using parens or backticks. data LexicalFixity = Prefix | Infix deriving (Data,Eq) instance Outputable LexicalFixity where ppr Prefix = text "Prefix" ppr Infix = text "Infix" {- ************************************************************************ * * \subsection[Top-level/local]{Top-level/not-top level flag} * * ************************************************************************ -} data TopLevelFlag = TopLevel | NotTopLevel isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool isNotTopLevel NotTopLevel = True isNotTopLevel TopLevel = False isTopLevel TopLevel = True isTopLevel NotTopLevel = False instance Outputable TopLevelFlag where ppr TopLevel = text "" ppr NotTopLevel = text "" {- ************************************************************************ * * Boxity flag * * ************************************************************************ -} data Boxity = Boxed | Unboxed deriving( Eq, Data ) isBoxed :: Boxity -> Bool isBoxed Boxed = True isBoxed Unboxed = False instance Outputable Boxity where ppr Boxed = text "Boxed" ppr Unboxed = text "Unboxed" {- ************************************************************************ * * Recursive/Non-Recursive flag * * ************************************************************************ -} -- | Recursivity Flag data RecFlag = Recursive | NonRecursive deriving( Eq, Data ) isRec :: RecFlag -> Bool isRec Recursive = True isRec NonRecursive = False isNonRec :: RecFlag -> Bool isNonRec Recursive = False isNonRec NonRecursive = True boolToRecFlag :: Bool -> RecFlag boolToRecFlag True = Recursive boolToRecFlag False = NonRecursive instance Outputable RecFlag where ppr Recursive = text "Recursive" ppr NonRecursive = text "NonRecursive" {- ************************************************************************ * * Code origin * * ************************************************************************ -} data Origin = FromSource | Generated deriving( Eq, Data ) isGenerated :: Origin -> Bool isGenerated Generated = True isGenerated FromSource = False instance Outputable Origin where ppr FromSource = text "FromSource" ppr Generated = text "Generated" {- ************************************************************************ * * Instance overlap flag * * ************************************************************************ -} -- | The semantics allowed for overlapping instances for a particular -- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a -- explanation of the `isSafeOverlap` field. -- -- - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or -- @'\{-\# OVERLAPPING'@ or -- @'\{-\# OVERLAPS'@ or -- @'\{-\# INCOHERENT'@, -- 'ApiAnnotation.AnnClose' @`\#-\}`@, -- For details on above see note [Api annotations] in ApiAnnotation data OverlapFlag = OverlapFlag { overlapMode :: OverlapMode , isSafeOverlap :: Bool } deriving (Eq, Data) setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag setOverlapModeMaybe f Nothing = f setOverlapModeMaybe f (Just m) = f { overlapMode = m } hasIncoherentFlag :: OverlapMode -> Bool hasIncoherentFlag mode = case mode of Incoherent _ -> True _ -> False hasOverlappableFlag :: OverlapMode -> Bool hasOverlappableFlag mode = case mode of Overlappable _ -> True Overlaps _ -> True Incoherent _ -> True _ -> False hasOverlappingFlag :: OverlapMode -> Bool hasOverlappingFlag mode = case mode of Overlapping _ -> True Overlaps _ -> True Incoherent _ -> True _ -> False data OverlapMode -- See Note [Rules for instance lookup] in InstEnv = NoOverlap SourceText -- See Note [Pragma source text] -- ^ This instance must not overlap another `NoOverlap` instance. -- However, it may be overlapped by `Overlapping` instances, -- and it may overlap `Overlappable` instances. | Overlappable SourceText -- See Note [Pragma source text] -- ^ Silently ignore this instance if you find a -- more specific one that matches the constraint -- you are trying to resolve -- -- Example: constraint (Foo [Int]) -- instance Foo [Int] -- instance {-# OVERLAPPABLE #-} Foo [a] -- -- Since the second instance has the Overlappable flag, -- the first instance will be chosen (otherwise -- its ambiguous which to choose) | Overlapping SourceText -- See Note [Pragma source text] -- ^ Silently ignore any more general instances that may be -- used to solve the constraint. -- -- Example: constraint (Foo [Int]) -- instance {-# OVERLAPPING #-} Foo [Int] -- instance Foo [a] -- -- Since the first instance has the Overlapping flag, -- the second---more general---instance will be ignored (otherwise -- it is ambiguous which to choose) | Overlaps SourceText -- See Note [Pragma source text] -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. | Incoherent SourceText -- See Note [Pragma source text] -- ^ Behave like Overlappable and Overlapping, and in addition pick -- an an arbitrary one if there are multiple matching candidates, and -- don't worry about later instantiation -- -- Example: constraint (Foo [b]) -- instance {-# INCOHERENT -} Foo [Int] -- instance Foo [a] -- Without the Incoherent flag, we'd complain that -- instantiating 'b' would change which instance -- was chosen. See also note [Incoherent instances] in InstEnv deriving (Eq, Data) instance Outputable OverlapFlag where ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) instance Outputable OverlapMode where ppr (NoOverlap _) = empty ppr (Overlappable _) = text "[overlappable]" ppr (Overlapping _) = text "[overlapping]" ppr (Overlaps _) = text "[overlap ok]" ppr (Incoherent _) = text "[incoherent]" pprSafeOverlap :: Bool -> SDoc pprSafeOverlap True = text "[safe]" pprSafeOverlap False = empty {- ************************************************************************ * * Precedence * * ************************************************************************ -} -- | A general-purpose pretty-printing precedence type. newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show) -- See Note [Precedence in types] topPrec, sigPrec, funPrec, opPrec, appPrec :: PprPrec topPrec = PprPrec 0 -- No parens sigPrec = PprPrec 1 -- Explicit type signatures funPrec = PprPrec 2 -- Function args; no parens for constructor apps -- See [Type operator precedence] for why both -- funPrec and opPrec exist. opPrec = PprPrec 2 -- Infix operator appPrec = PprPrec 3 -- Constructor args; no parens for atomic maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc maybeParen ctxt_prec inner_prec pretty | ctxt_prec < inner_prec = pretty | otherwise = parens pretty {- Note [Precedence in types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Many pretty-printing functions have type ppr_ty :: PprPrec -> Type -> SDoc The PprPrec gives the binding strength of the context. For example, in T ty1 ty2 we will pretty-print 'ty1' and 'ty2' with the call (ppr_ty appPrec ty) to indicate that the context is that of an argument of a TyConApp. We use this consistently for Type and HsType. Note [Type operator precedence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We don't keep the fixity of type operators in the operator. So the pretty printer follows the following precedence order: TyConPrec Type constructor application TyOpPrec/FunPrec Operator application and function arrow We have funPrec and opPrec to represent the precedence of function arrow and type operators respectively, but currently we implement funPrec == opPrec, so that we don't distinguish the two. Reason: it's hard to parse a type like a ~ b => c * d -> e - f By treating opPrec = funPrec we end up with more parens (a ~ b) => (c * d) -> (e - f) But the two are different constructors of PprPrec so we could make (->) bind more or less tightly if we wanted. -} {- ************************************************************************ * * Tuples * * ************************************************************************ -} data TupleSort = BoxedTuple | UnboxedTuple | ConstraintTuple deriving( Eq, Data ) instance Outputable TupleSort where ppr ts = text $ case ts of BoxedTuple -> "BoxedTuple" UnboxedTuple -> "UnboxedTuple" ConstraintTuple -> "ConstraintTuple" tupleSortBoxity :: TupleSort -> Boxity tupleSortBoxity BoxedTuple = Boxed tupleSortBoxity UnboxedTuple = Unboxed tupleSortBoxity ConstraintTuple = Boxed boxityTupleSort :: Boxity -> TupleSort boxityTupleSort Boxed = BoxedTuple boxityTupleSort Unboxed = UnboxedTuple tupleParens :: TupleSort -> SDoc -> SDoc tupleParens BoxedTuple p = parens p tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)") tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)")) (parens p) {- ************************************************************************ * * Sums * * ************************************************************************ -} sumParens :: SDoc -> SDoc sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") -- | Pretty print an alternative in an unboxed sum e.g. "| a | |". pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use -> a -- ^ The things to be pretty printed -> ConTag -- ^ Alternative (one-based) -> Arity -- ^ Arity -> SDoc -- ^ 'SDoc' where the alternative havs been pretty -- printed and finally packed into a paragraph. pprAlternative pp x alt arity = fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar) {- ************************************************************************ * * \subsection[Generic]{Generic flag} * * ************************************************************************ This is the "Embedding-Projection pair" datatype, it contains two pieces of code (normally either RenamedExpr's or Id's) If we have a such a pair (EP from to), the idea is that 'from' and 'to' represents functions of type from :: T -> Tring to :: Tring -> T And we should have to (from x) = x T and Tring are arbitrary, but typically T is the 'main' type while Tring is the 'representation' type. (This just helps us remember whether to use 'from' or 'to'. -} -- | Embedding Projection pair data EP a = EP { fromEP :: a, -- :: T -> Tring toEP :: a } -- :: Tring -> T {- Embedding-projection pairs are used in several places: First of all, each type constructor has an EP associated with it, the code in EP converts (datatype T) from T to Tring and back again. Secondly, when we are filling in Generic methods (in the typechecker, tcMethodBinds), we are constructing bimaps by induction on the structure of the type of the method signature. ************************************************************************ * * \subsection{Occurrence information} * * ************************************************************************ This data type is used exclusively by the simplifier, but it appears in a SubstResult, which is currently defined in VarEnv, which is pretty near the base of the module hierarchy. So it seemed simpler to put the defn of OccInfo here, safely at the bottom -} -- | identifier Occurrence Information data OccInfo = ManyOccs { occ_tail :: !TailCallInfo } -- ^ There are many occurrences, or unknown occurrences | IAmDead -- ^ Marks unused variables. Sometimes useful for -- lambda and case-bound variables. | OneOcc { occ_in_lam :: !InsideLam , occ_one_br :: !OneBranch , occ_int_cxt :: !InterestingCxt , occ_tail :: !TailCallInfo } -- ^ Occurs exactly once (per branch), not inside a rule -- | This identifier breaks a loop of mutually recursive functions. The field -- marks whether it is only a loop breaker due to a reference in a rule | IAmALoopBreaker { occ_rules_only :: !RulesOnly , occ_tail :: !TailCallInfo } -- Note [LoopBreaker OccInfo] deriving (Eq) type RulesOnly = Bool {- Note [LoopBreaker OccInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~ IAmALoopBreaker True <=> A "weak" or rules-only loop breaker Do not preInlineUnconditionally IAmALoopBreaker False <=> A "strong" loop breaker Do not inline at all See OccurAnal Note [Weak loop breakers] -} noOccInfo :: OccInfo noOccInfo = ManyOccs { occ_tail = NoTailCallInfo } isManyOccs :: OccInfo -> Bool isManyOccs ManyOccs{} = True isManyOccs _ = False seqOccInfo :: OccInfo -> () seqOccInfo occ = occ `seq` () ----------------- -- | Interesting Context type InterestingCxt = Bool -- True <=> Function: is applied -- Data value: scrutinised by a case with -- at least one non-DEFAULT branch ----------------- -- | Inside Lambda type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda -- Substituting a redex for this occurrence is -- dangerous because it might duplicate work. insideLam, notInsideLam :: InsideLam insideLam = True notInsideLam = False ----------------- type OneBranch = Bool -- True <=> Occurs in only one case branch -- so no code-duplication issue to worry about oneBranch, notOneBranch :: OneBranch oneBranch = True notOneBranch = False ----------------- data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo] | NoTailCallInfo deriving (Eq) tailCallInfo :: OccInfo -> TailCallInfo tailCallInfo IAmDead = NoTailCallInfo tailCallInfo other = occ_tail other zapOccTailCallInfo :: OccInfo -> OccInfo zapOccTailCallInfo IAmDead = IAmDead zapOccTailCallInfo occ = occ { occ_tail = NoTailCallInfo } isAlwaysTailCalled :: OccInfo -> Bool isAlwaysTailCalled occ = case tailCallInfo occ of AlwaysTailCalled{} -> True NoTailCallInfo -> False instance Outputable TailCallInfo where ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ] ppr _ = empty ----------------- strongLoopBreaker, weakLoopBreaker :: OccInfo strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo weakLoopBreaker = IAmALoopBreaker True NoTailCallInfo isWeakLoopBreaker :: OccInfo -> Bool isWeakLoopBreaker (IAmALoopBreaker{}) = True isWeakLoopBreaker _ = False isStrongLoopBreaker :: OccInfo -> Bool isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True -- Loop-breaker that breaks a non-rule cycle isStrongLoopBreaker _ = False isDeadOcc :: OccInfo -> Bool isDeadOcc IAmDead = True isDeadOcc _ = False isOneOcc :: OccInfo -> Bool isOneOcc (OneOcc {}) = True isOneOcc _ = False zapFragileOcc :: OccInfo -> OccInfo -- Keep only the most robust data: deadness, loop-breaker-hood zapFragileOcc (OneOcc {}) = noOccInfo zapFragileOcc occ = zapOccTailCallInfo occ instance Outputable OccInfo where -- only used for debugging; never parsed. KSW 1999-07 ppr (ManyOccs tails) = pprShortTailCallInfo tails ppr IAmDead = text "Dead" ppr (IAmALoopBreaker rule_only tails) = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails where pp_ro | rule_only = char '!' | otherwise = empty ppr (OneOcc inside_lam one_branch int_cxt tail_info) = text "Once" <> pp_lam <> pp_br <> pp_args <> pp_tail where pp_lam | inside_lam = char 'L' | otherwise = empty pp_br | one_branch = empty | otherwise = char '*' pp_args | int_cxt = char '!' | otherwise = empty pp_tail = pprShortTailCallInfo tail_info pprShortTailCallInfo :: TailCallInfo -> SDoc pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar) pprShortTailCallInfo NoTailCallInfo = empty {- Note [TailCallInfo] ~~~~~~~~~~~~~~~~~~~ The occurrence analyser determines what can be made into a join point, but it doesn't change the binder into a JoinId because then it would be inconsistent with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to change the IdDetails. The AlwaysTailCalled marker actually means slightly more than simply that the function is always tail-called. See Note [Invariants on join points]. This info is quite fragile and should not be relied upon unless the occurrence analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of the join-point-hood of a binder; a join id itself will not be marked AlwaysTailCalled. Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that being tail-called would mean that the variable could only appear once per branch (thus getting a `OneOcc { occ_one_br = True }` occurrence info), but a join point can also be invoked from other join points, not just from case branches: let j1 x = ... j2 y = ... j1 z {- tail call -} ... in case w of A -> j1 v B -> j2 u C -> j2 q Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get ManyOccs and j2 will get `OneOcc { occ_one_br = True }`. ************************************************************************ * * Default method specification * * ************************************************************************ The DefMethSpec enumeration just indicates what sort of default method is used for a class. It is generated from source code, and present in interface files; it is converted to Class.DefMethInfo before begin put in a Class object. -} -- | Default Method Specification data DefMethSpec ty = VanillaDM -- Default method given with polymorphic code | GenericDM ty -- Default method given with code of this type instance Outputable (DefMethSpec ty) where ppr VanillaDM = text "{- Has default method -}" ppr (GenericDM {}) = text "{- Has generic default method -}" {- ************************************************************************ * * \subsection{Success flag} * * ************************************************************************ -} data SuccessFlag = Succeeded | Failed instance Outputable SuccessFlag where ppr Succeeded = text "Succeeded" ppr Failed = text "Failed" successIf :: Bool -> SuccessFlag successIf True = Succeeded successIf False = Failed succeeded, failed :: SuccessFlag -> Bool succeeded Succeeded = True succeeded Failed = False failed Succeeded = False failed Failed = True {- ************************************************************************ * * \subsection{Source Text} * * ************************************************************************ Keeping Source Text for source to source conversions Note [Pragma source text] ~~~~~~~~~~~~~~~~~~~~~~~~~ The lexer does a case-insensitive match for pragmas, as well as accepting both UK and US spelling variants. So {-# SPECIALISE #-} {-# SPECIALIZE #-} {-# Specialize #-} will all generate ITspec_prag token for the start of the pragma. In order to be able to do source to source conversions, the original source text for the token needs to be preserved, hence the `SourceText` field. So the lexer will then generate ITspec_prag "{ -# SPECIALISE" ITspec_prag "{ -# SPECIALIZE" ITspec_prag "{ -# Specialize" for the cases above. [without the space between '{' and '-', otherwise this comment won't parse] Note [Literal source text] ~~~~~~~~~~~~~~~~~~~~~~~~~~ The lexer/parser converts literals from their original source text versions to an appropriate internal representation. This is a problem for tools doing source to source conversions, so the original source text is stored in literals where this can occur. Motivating examples for HsLit HsChar '\n' == '\x20` HsCharPrim '\x41`# == `A` HsString "\x20\x41" == " A" HsStringPrim "\x20"# == " "# HsInt 001 == 1 HsIntPrim 002# == 2# HsWordPrim 003## == 3## HsInt64Prim 004## == 4## HsWord64Prim 005## == 5## HsInteger 006 == 6 For OverLitVal HsIntegral 003 == 0x003 HsIsString "\x41nd" == "And" -} -- Note [Literal source text],[Pragma source text] data SourceText = SourceText String | NoSourceText -- ^ For when code is generated, e.g. TH, -- deriving. The pretty printer will then make -- its own representation of the item. deriving (Data, Show, Eq ) instance Outputable SourceText where ppr (SourceText s) = text "SourceText" <+> text s ppr NoSourceText = text "NoSourceText" -- | Special combinator for showing string literals. pprWithSourceText :: SourceText -> SDoc -> SDoc pprWithSourceText NoSourceText d = d pprWithSourceText (SourceText src) _ = text src {- ************************************************************************ * * \subsection{Activation} * * ************************************************************************ When a rule or inlining is active -} -- | Phase Number type PhaseNum = Int -- Compilation phase -- Phases decrease towards zero -- Zero is the last phase data CompilerPhase = Phase PhaseNum | InitialPhase -- The first phase -- number = infinity! instance Outputable CompilerPhase where ppr (Phase n) = int n ppr InitialPhase = text "InitialPhase" activeAfterInitial :: Activation -- Active in the first phase after the initial phase -- Currently we have just phases [2,1,0] activeAfterInitial = ActiveAfter NoSourceText 2 activeDuringFinal :: Activation -- Active in the final simplification phase (which is repeated) activeDuringFinal = ActiveAfter NoSourceText 0 -- See note [Pragma source text] data Activation = NeverActive | AlwaysActive | ActiveBefore SourceText PhaseNum -- Active only *strictly before* this phase | ActiveAfter SourceText PhaseNum -- Active in this phase and later deriving( Eq, Data ) -- Eq used in comparing rules in GHC.Hs.Decls -- | Rule Match Information data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] | FunLike deriving( Eq, Data, Show ) -- Show needed for Lexer.x data InlinePragma -- Note [InlinePragma] = InlinePragma { inl_src :: SourceText -- Note [Pragma source text] , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act] , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n -- explicit (non-type, non-dictionary) args -- That is, inl_sat describes the number of *source-code* -- arguments the thing must be applied to. We add on the -- number of implicit, dictionary arguments when making -- the Unfolding, and don't look at inl_sat further , inl_act :: Activation -- Says during which phases inlining is allowed -- See Note [inl_inline and inl_act] , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? } deriving( Eq, Data ) -- | Inline Specification data InlineSpec -- What the user's INLINE pragma looked like = Inline -- User wrote INLINE | Inlinable -- User wrote INLINABLE | NoInline -- User wrote NOINLINE | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE -- e.g. in `defaultInlinePragma` or when created by CSE deriving( Eq, Data, Show ) -- Show needed for Lexer.x {- Note [InlinePragma] ~~~~~~~~~~~~~~~~~~~~~~ This data type mirrors what you can write in an INLINE or NOINLINE pragma in the source program. If you write nothing at all, you get defaultInlinePragma: inl_inline = NoUserInline inl_act = AlwaysActive inl_rule = FunLike It's not possible to get that combination by *writing* something, so if an Id has defaultInlinePragma it means the user didn't specify anything. If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding. If you want to know where InlinePragmas take effect: Look in DsBinds.makeCorePair Note [inl_inline and inl_act] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * inl_inline says what the user wrote: did she say INLINE, NOINLINE, INLINABLE, or nothing at all * inl_act says in what phases the unfolding is active or inactive E.g If you write INLINE[1] then inl_act will be set to ActiveAfter 1 If you write NOINLINE[1] then inl_act will be set to ActiveBefore 1 If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1 So note that inl_act does not say what pragma you wrote: it just expresses its consequences * inl_act just says when the unfolding is active; it doesn't say what to inline. If you say INLINE f, then f's inl_act will be AlwaysActive, but in addition f will get a "stable unfolding" with UnfoldingGuidance that tells the inliner to be pretty eager about it. Note [CONLIKE pragma] ~~~~~~~~~~~~~~~~~~~~~ The ConLike constructor of a RuleMatchInfo is aimed at the following. Consider first {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-} g b bs = let x = b:bs in ..x...x...(r x)... Now, the rule applies to the (r x) term, because GHC "looks through" the definition of 'x' to see that it is (b:bs). Now consider {-# RULE "r/f" forall v. r (f v) = f (v+1) #-} g v = let x = f v in ..x...x...(r x)... Normally the (r x) would *not* match the rule, because GHC would be scared about duplicating the redex (f v), so it does not "look through" the bindings. However the CONLIKE modifier says to treat 'f' like a constructor in this situation, and "look through" the unfolding for x. So (r x) fires, yielding (f (v+1)). This is all controlled with a user-visible pragma: {-# NOINLINE CONLIKE [1] f #-} The main effects of CONLIKE are: - The occurrence analyser (OccAnal) and simplifier (Simplify) treat CONLIKE thing like constructors, by ANF-ing them - New function CoreUtils.exprIsExpandable is like exprIsCheap, but additionally spots applications of CONLIKE functions - A CoreUnfolding has a field that caches exprIsExpandable - The rule matcher consults this field. See Note [Expanding variables] in Rules.hs. -} isConLike :: RuleMatchInfo -> Bool isConLike ConLike = True isConLike _ = False isFunLike :: RuleMatchInfo -> Bool isFunLike FunLike = True isFunLike _ = False noUserInlineSpec :: InlineSpec -> Bool noUserInlineSpec NoUserInline = True noUserInlineSpec _ = False defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma :: InlinePragma defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE" , inl_act = AlwaysActive , inl_rule = FunLike , inl_inline = NoUserInline , inl_sat = Nothing } alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline } neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } inlinePragmaSpec :: InlinePragma -> InlineSpec inlinePragmaSpec = inl_inline -- A DFun has an always-active inline activation so that -- exprIsConApp_maybe can "see" its unfolding -- (However, its actual Unfolding is a DFunUnfolding, which is -- never inlined other than via exprIsConApp_maybe.) dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive , inl_rule = ConLike } isDefaultInlinePragma :: InlinePragma -> Bool isDefaultInlinePragma (InlinePragma { inl_act = activation , inl_rule = match_info , inl_inline = inline }) = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info isInlinePragma :: InlinePragma -> Bool isInlinePragma prag = case inl_inline prag of Inline -> True _ -> False isInlinablePragma :: InlinePragma -> Bool isInlinablePragma prag = case inl_inline prag of Inlinable -> True _ -> False isAnyInlinePragma :: InlinePragma -> Bool -- INLINE or INLINABLE isAnyInlinePragma prag = case inl_inline prag of Inline -> True Inlinable -> True _ -> False inlinePragmaSat :: InlinePragma -> Maybe Arity inlinePragmaSat = inl_sat inlinePragmaActivation :: InlinePragma -> Activation inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma setInlinePragmaActivation prag activation = prag { inl_act = activation } setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } instance Outputable Activation where ppr AlwaysActive = empty ppr NeverActive = brackets (text "~") ppr (ActiveBefore _ n) = brackets (char '~' <> int n) ppr (ActiveAfter _ n) = brackets (int n) instance Outputable RuleMatchInfo where ppr ConLike = text "CONLIKE" ppr FunLike = text "FUNLIKE" instance Outputable InlineSpec where ppr Inline = text "INLINE" ppr NoInline = text "NOINLINE" ppr Inlinable = text "INLINABLE" ppr NoUserInline = text "NOUSERINLINE" -- what is better? instance Outputable InlinePragma where ppr = pprInline pprInline :: InlinePragma -> SDoc pprInline = pprInline' True pprInlineDebug :: InlinePragma -> SDoc pprInlineDebug = pprInline' False pprInline' :: Bool -- True <=> do not display the inl_inline field -> InlinePragma -> SDoc pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation , inl_rule = info, inl_sat = mb_arity }) = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info where pp_inl x = if emptyInline then empty else ppr x pp_act Inline AlwaysActive = empty pp_act NoInline NeverActive = empty pp_act _ act = ppr act pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar) | otherwise = empty pp_info | isFunLike info = empty | otherwise = ppr info isActive :: CompilerPhase -> Activation -> Bool isActive InitialPhase AlwaysActive = True isActive InitialPhase (ActiveBefore {}) = True isActive InitialPhase _ = False isActive (Phase p) act = isActiveIn p act isActiveIn :: PhaseNum -> Activation -> Bool isActiveIn _ NeverActive = False isActiveIn _ AlwaysActive = True isActiveIn p (ActiveAfter _ n) = p <= n isActiveIn p (ActiveBefore _ n) = p > n competesWith :: Activation -> Activation -> Bool -- See Note [Activation competition] competesWith NeverActive _ = False competesWith _ NeverActive = False competesWith AlwaysActive _ = True competesWith (ActiveBefore {}) AlwaysActive = True competesWith (ActiveBefore {}) (ActiveBefore {}) = True competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b competesWith (ActiveAfter {}) AlwaysActive = False competesWith (ActiveAfter {}) (ActiveBefore {}) = False competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b {- Note [Competing activations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Sometimes a RULE and an inlining may compete, or two RULES. See Note [Rules and inlining/other rules] in Desugar. We say that act1 "competes with" act2 iff act1 is active in the phase when act2 *becomes* active NB: remember that phases count *down*: 2, 1, 0! It's too conservative to ensure that the two are never simultaneously active. For example, a rule might be always active, and an inlining might switch on in phase 2. We could switch off the rule, but it does no harm. -} isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool isNeverActive NeverActive = True isNeverActive _ = False isAlwaysActive AlwaysActive = True isAlwaysActive _ = False isEarlyActive AlwaysActive = True isEarlyActive (ActiveBefore {}) = True isEarlyActive _ = False -- | Integral Literal -- -- Used (instead of Integer) to represent negative zegative zero which is -- required for NegativeLiterals extension to correctly parse `-0::Double` -- as negative zero. See also #13211. data IntegralLit = IL { il_text :: SourceText , il_neg :: Bool -- See Note [Negative zero] , il_value :: Integer } deriving (Data, Show) mkIntegralLit :: Integral a => a -> IntegralLit mkIntegralLit i = IL { il_text = SourceText (show i_integer) , il_neg = i < 0 , il_value = i_integer } where i_integer :: Integer i_integer = toInteger i negateIntegralLit :: IntegralLit -> IntegralLit negateIntegralLit (IL text neg value) = case text of SourceText ('-':src) -> IL (SourceText src) False (negate value) SourceText src -> IL (SourceText ('-':src)) True (negate value) NoSourceText -> IL NoSourceText (not neg) (negate value) -- | Fractional Literal -- -- Used (instead of Rational) to represent exactly the floating point literal that we -- encountered in the user's source program. This allows us to pretty-print exactly what -- the user wrote, which is important e.g. for floating point numbers that can't represented -- as Doubles (we used to via Double for pretty-printing). See also #2245. data FractionalLit = FL { fl_text :: SourceText -- How the value was written in the source , fl_neg :: Bool -- See Note [Negative zero] , fl_value :: Rational -- Numeric value of the literal } deriving (Data, Show) -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on mkFractionalLit :: Real a => a -> FractionalLit mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double)) -- Converting to a Double here may technically lose -- precision (see #15502). We could alternatively -- convert to a Rational for the most accuracy, but -- it would cause Floats and Doubles to be displayed -- strangely, so we opt not to do this. (In contrast -- to mkIntegralLit, where we always convert to an -- Integer for the highest accuracy.) , fl_neg = r < 0 , fl_value = toRational r } negateFractionalLit :: FractionalLit -> FractionalLit negateFractionalLit (FL text neg value) = case text of SourceText ('-':src) -> FL (SourceText src) False value SourceText src -> FL (SourceText ('-':src)) True value NoSourceText -> FL NoSourceText (not neg) (negate value) integralFractionalLit :: Bool -> Integer -> FractionalLit integralFractionalLit neg i = FL { fl_text = SourceText (show i), fl_neg = neg, fl_value = fromInteger i } -- Comparison operations are needed when grouping literals -- for compiling pattern-matching (module MatchLit) instance Eq IntegralLit where (==) = (==) `on` il_value instance Ord IntegralLit where compare = compare `on` il_value instance Outputable IntegralLit where ppr (IL (SourceText src) _ _) = text src ppr (IL NoSourceText _ value) = text (show value) instance Eq FractionalLit where (==) = (==) `on` fl_value instance Ord FractionalLit where compare = compare `on` fl_value instance Outputable FractionalLit where ppr f = pprWithSourceText (fl_text f) (rational (fl_value f)) {- ************************************************************************ * * IntWithInf * * ************************************************************************ Represents an integer or positive infinity -} -- | An integer or infinity data IntWithInf = Int {-# UNPACK #-} !Int | Infinity deriving Eq -- | A representation of infinity infinity :: IntWithInf infinity = Infinity instance Ord IntWithInf where compare Infinity Infinity = EQ compare (Int _) Infinity = LT compare Infinity (Int _) = GT compare (Int a) (Int b) = a `compare` b instance Outputable IntWithInf where ppr Infinity = char '∞' ppr (Int n) = int n instance Num IntWithInf where (+) = plusWithInf (*) = mulWithInf abs Infinity = Infinity abs (Int n) = Int (abs n) signum Infinity = Int 1 signum (Int n) = Int (signum n) fromInteger = Int . fromInteger (-) = panic "subtracting IntWithInfs" intGtLimit :: Int -> IntWithInf -> Bool intGtLimit _ Infinity = False intGtLimit n (Int m) = n > m -- | Add two 'IntWithInf's plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf plusWithInf Infinity _ = Infinity plusWithInf _ Infinity = Infinity plusWithInf (Int a) (Int b) = Int (a + b) -- | Multiply two 'IntWithInf's mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf mulWithInf Infinity _ = Infinity mulWithInf _ Infinity = Infinity mulWithInf (Int a) (Int b) = Int (a * b) -- | Turn a positive number into an 'IntWithInf', where 0 represents infinity treatZeroAsInf :: Int -> IntWithInf treatZeroAsInf 0 = Infinity treatZeroAsInf n = Int n -- | Inject any integer into an 'IntWithInf' mkIntWithInf :: Int -> IntWithInf mkIntWithInf = Int data SpliceExplicitFlag = ExplicitSplice | -- ^ <=> $(f x y) ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression deriving Data {- ********************************************************************* * * Types vs Kinds * * ********************************************************************* -} -- | Flag to see whether we're type-checking terms or kind-checking types data TypeOrKind = TypeLevel | KindLevel deriving Eq instance Outputable TypeOrKind where ppr TypeLevel = text "TypeLevel" ppr KindLevel = text "KindLevel" isTypeLevel :: TypeOrKind -> Bool isTypeLevel TypeLevel = True isTypeLevel KindLevel = False isKindLevel :: TypeOrKind -> Bool isKindLevel TypeLevel = False isKindLevel KindLevel = True ghc-lib-parser-8.10.2.20200808/compiler/iface/BinFingerprint.hs0000644000000000000000000000262513713635745021651 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Computing fingerprints of values serializeable with GHC's "Binary" module. module BinFingerprint ( -- * Computing fingerprints fingerprintBinMem , computeFingerprint , putNameLiterally ) where #include "GhclibHsVersions.h" import GhcPrelude import Fingerprint import Binary import Name import PlainPanic import Util fingerprintBinMem :: BinHandle -> IO Fingerprint fingerprintBinMem bh = withBinBuffer bh f where f bs = -- we need to take care that we force the result here -- lest a reference to the ByteString may leak out of -- withBinBuffer. let fp = fingerprintByteString bs in fp `seq` return fp computeFingerprint :: (Binary a) => (BinHandle -> Name -> IO ()) -> a -> IO Fingerprint computeFingerprint put_nonbinding_name a = do bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block put_ bh a fp <- fingerprintBinMem bh return fp where set_user_data bh = setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS -- | Used when we want to fingerprint a structure without depending on the -- fingerprints of external Names that it refers to. putNameLiterally :: BinHandle -> Name -> IO () putNameLiterally bh name = ASSERT( isExternalName name ) do put_ bh $! nameModule name put_ bh $! nameOccName name ghc-lib-parser-8.10.2.20200808/compiler/utils/Binary.hs0000644000000000000000000013352313713635745020250 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected -- -- (c) The University of Glasgow 2002-2006 -- -- Binary I/O library, with special tweaks for GHC -- -- Based on the nhc98 Binary library, which is copyright -- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. -- Under the terms of the license for that software, we must tell you -- where you can obtain the original version of the Binary library, namely -- http://www.cs.york.ac.uk/fp/nhc98/ module Binary ( {-type-} Bin, {-class-} Binary(..), {-type-} BinHandle, SymbolTable, Dictionary, openBinMem, -- closeBin, seekBin, seekBy, tellBin, castBin, isEOFBin, withBinBuffer, writeBinMem, readBinMem, putAt, getAt, -- * For writing instances putByte, getByte, -- * Variable length encodings putULEB128, getULEB128, putSLEB128, getSLEB128, -- * Lazy Binary I/O lazyGet, lazyPut, -- * User data UserData(..), getUserData, setUserData, newReadState, newWriteState, putDictionary, getDictionary, putFS, ) where #include "GhclibHsVersions.h" import GhcPrelude import {-# SOURCE #-} Name (Name) import FastString import PlainPanic import UniqFM import FastMutInt import Fingerprint import BasicTypes import SrcLoc import Foreign import Data.Array import Data.ByteString (ByteString) import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Unsafe as BS import Data.IORef import Data.Char ( ord, chr ) import Data.Time import Data.List (unfoldr) import Type.Reflection import Type.Reflection.Unsafe import Data.Kind (Type) import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..)) import Control.Monad ( when, (<$!>), unless ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) import GHC.Real ( Ratio(..) ) import GHC.Serialized type BinArray = ForeignPtr Word8 --------------------------------------------------------------- -- BinHandle --------------------------------------------------------------- data BinHandle = BinMem { -- binary data stored in an unboxed array bh_usr :: UserData, -- sigh, need parameterized modules :-) _off_r :: !FastMutInt, -- the current offset _sz_r :: !FastMutInt, -- size of the array (cached) _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) } -- XXX: should really store a "high water mark" for dumping out -- the binary data to a file. getUserData :: BinHandle -> UserData getUserData bh = bh_usr bh setUserData :: BinHandle -> UserData -> BinHandle setUserData bh us = bh { bh_usr = us } -- | Get access to the underlying buffer. -- -- It is quite important that no references to the 'ByteString' leak out of the -- continuation lest terrible things happen. withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a withBinBuffer (BinMem _ ix_r _ arr_r) action = do arr <- readIORef arr_r ix <- readFastMutInt ix_r withForeignPtr arr $ \ptr -> BS.unsafePackCStringLen (castPtr ptr, ix) >>= action --------------------------------------------------------------- -- Bin --------------------------------------------------------------- newtype Bin a = BinPtr Int deriving (Eq, Ord, Show, Bounded) castBin :: Bin a -> Bin b castBin (BinPtr i) = BinPtr i --------------------------------------------------------------- -- class Binary --------------------------------------------------------------- -- | Do not rely on instance sizes for general types, -- we use variable length encoding for many of them. class Binary a where put_ :: BinHandle -> a -> IO () put :: BinHandle -> a -> IO (Bin a) get :: BinHandle -> IO a -- define one of put_, put. Use of put_ is recommended because it -- is more likely that tail-calls can kick in, and we rarely need the -- position return value. put_ bh a = do _ <- put bh a; return () put bh a = do p <- tellBin bh; put_ bh a; return p putAt :: Binary a => BinHandle -> Bin a -> a -> IO () putAt bh p x = do seekBin bh p; put_ bh x; return () getAt :: Binary a => BinHandle -> Bin a -> IO a getAt bh p = do seekBin bh p; get bh openBinMem :: Int -> IO BinHandle openBinMem size | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" | otherwise = do arr <- mallocForeignPtrBytes size arr_r <- newIORef arr ix_r <- newFastMutInt writeFastMutInt ix_r 0 sz_r <- newFastMutInt writeFastMutInt sz_r size return (BinMem noUserData ix_r sz_r arr_r) tellBin :: BinHandle -> IO (Bin a) tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) seekBin :: BinHandle -> Bin a -> IO () seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do sz <- readFastMutInt sz_r if (p >= sz) then do expandBin h p; writeFastMutInt ix_r p else writeFastMutInt ix_r p seekBy :: BinHandle -> Int -> IO () seekBy h@(BinMem _ ix_r sz_r _) !off = do sz <- readFastMutInt sz_r ix <- readFastMutInt ix_r let ix' = ix + off if (ix' >= sz) then do expandBin h ix'; writeFastMutInt ix_r ix' else writeFastMutInt ix_r ix' isEOFBin :: BinHandle -> IO Bool isEOFBin (BinMem _ ix_r sz_r _) = do ix <- readFastMutInt ix_r sz <- readFastMutInt sz_r return (ix >= sz) writeBinMem :: BinHandle -> FilePath -> IO () writeBinMem (BinMem _ ix_r _ arr_r) fn = do h <- openBinaryFile fn WriteMode arr <- readIORef arr_r ix <- readFastMutInt ix_r withForeignPtr arr $ \p -> hPutBuf h p ix hClose h readBinMem :: FilePath -> IO BinHandle -- Return a BinHandle with a totally undefined State readBinMem filename = do h <- openBinaryFile filename ReadMode filesize' <- hFileSize h let filesize = fromIntegral filesize' arr <- mallocForeignPtrBytes filesize count <- withForeignPtr arr $ \p -> hGetBuf h p filesize when (count /= filesize) $ error ("Binary.readBinMem: only read " ++ show count ++ " bytes") hClose h arr_r <- newIORef arr ix_r <- newFastMutInt writeFastMutInt ix_r 0 sz_r <- newFastMutInt writeFastMutInt sz_r filesize return (BinMem noUserData ix_r sz_r arr_r) -- expand the size of the array to include a specified offset expandBin :: BinHandle -> Int -> IO () expandBin (BinMem _ _ sz_r arr_r) !off = do !sz <- readFastMutInt sz_r let !sz' = getSize sz arr <- readIORef arr_r arr' <- mallocForeignPtrBytes sz' withForeignPtr arr $ \old -> withForeignPtr arr' $ \new -> copyBytes new old sz writeFastMutInt sz_r sz' writeIORef arr_r arr' where getSize :: Int -> Int getSize !sz | sz > off = sz | otherwise = getSize (sz * 2) -- ----------------------------------------------------------------------------- -- Low-level reading/writing of bytes -- | Takes a size and action writing up to @size@ bytes. -- After the action has run advance the index to the buffer -- by size bytes. putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO () putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do ix <- readFastMutInt ix_r sz <- readFastMutInt sz_r when (ix + size > sz) $ expandBin h (ix + size) arr <- readIORef arr_r withForeignPtr arr $ \op -> f (op `plusPtr` ix) writeFastMutInt ix_r (ix + size) -- -- | Similar to putPrim but advances the index by the actual number of -- -- bytes written. -- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO () -- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do -- ix <- readFastMutInt ix_r -- sz <- readFastMutInt sz_r -- when (ix + size > sz) $ -- expandBin h (ix + size) -- arr <- readIORef arr_r -- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) -- writeFastMutInt ix_r (ix + written) getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a getPrim (BinMem _ ix_r sz_r arr_r) size f = do ix <- readFastMutInt ix_r sz <- readFastMutInt sz_r when (ix + size > sz) $ ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing) arr <- readIORef arr_r w <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) writeFastMutInt ix_r (ix + size) return w putWord8 :: BinHandle -> Word8 -> IO () putWord8 h !w = putPrim h 1 (\op -> poke op w) getWord8 :: BinHandle -> IO Word8 getWord8 h = getPrim h 1 peek -- putWord16 :: BinHandle -> Word16 -> IO () -- putWord16 h w = putPrim h 2 (\op -> do -- pokeElemOff op 0 (fromIntegral (w `shiftR` 8)) -- pokeElemOff op 1 (fromIntegral (w .&. 0xFF)) -- ) -- getWord16 :: BinHandle -> IO Word16 -- getWord16 h = getPrim h 2 (\op -> do -- w0 <- fromIntegral <$> peekElemOff op 0 -- w1 <- fromIntegral <$> peekElemOff op 1 -- return $! w0 `shiftL` 8 .|. w1 -- ) putWord32 :: BinHandle -> Word32 -> IO () putWord32 h w = putPrim h 4 (\op -> do pokeElemOff op 0 (fromIntegral (w `shiftR` 24)) pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) pokeElemOff op 3 (fromIntegral (w .&. 0xFF)) ) getWord32 :: BinHandle -> IO Word32 getWord32 h = getPrim h 4 (\op -> do w0 <- fromIntegral <$> peekElemOff op 0 w1 <- fromIntegral <$> peekElemOff op 1 w2 <- fromIntegral <$> peekElemOff op 2 w3 <- fromIntegral <$> peekElemOff op 3 return $! (w0 `shiftL` 24) .|. (w1 `shiftL` 16) .|. (w2 `shiftL` 8) .|. w3 ) -- putWord64 :: BinHandle -> Word64 -> IO () -- putWord64 h w = putPrim h 8 (\op -> do -- pokeElemOff op 0 (fromIntegral (w `shiftR` 56)) -- pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF)) -- pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF)) -- pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF)) -- pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF)) -- pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) -- pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) -- pokeElemOff op 7 (fromIntegral (w .&. 0xFF)) -- ) -- getWord64 :: BinHandle -> IO Word64 -- getWord64 h = getPrim h 8 (\op -> do -- w0 <- fromIntegral <$> peekElemOff op 0 -- w1 <- fromIntegral <$> peekElemOff op 1 -- w2 <- fromIntegral <$> peekElemOff op 2 -- w3 <- fromIntegral <$> peekElemOff op 3 -- w4 <- fromIntegral <$> peekElemOff op 4 -- w5 <- fromIntegral <$> peekElemOff op 5 -- w6 <- fromIntegral <$> peekElemOff op 6 -- w7 <- fromIntegral <$> peekElemOff op 7 -- return $! (w0 `shiftL` 56) .|. -- (w1 `shiftL` 48) .|. -- (w2 `shiftL` 40) .|. -- (w3 `shiftL` 32) .|. -- (w4 `shiftL` 24) .|. -- (w5 `shiftL` 16) .|. -- (w6 `shiftL` 8) .|. -- w7 -- ) putByte :: BinHandle -> Word8 -> IO () putByte bh !w = putWord8 bh w getByte :: BinHandle -> IO Word8 getByte h = getWord8 h -- ----------------------------------------------------------------------------- -- Encode numbers in LEB128 encoding. -- Requires one byte of space per 7 bits of data. -- -- There are signed and unsigned variants. -- Do NOT use the unsigned one for signed values, at worst it will -- result in wrong results, at best it will lead to bad performance -- when coercing negative values to an unsigned type. -- -- We mark them as SPECIALIZE as it's extremely critical that they get specialized -- to their specific types. -- -- TODO: Each use of putByte performs a bounds check, -- we should use putPrimMax here. However it's quite hard to return -- the number of bytes written into putPrimMax without allocating an -- Int for it, while the code below does not allocate at all. -- So we eat the cost of the bounds check instead of increasing allocations -- for now. -- Unsigned numbers {-# SPECIALISE putULEB128 :: BinHandle -> Word -> IO () #-} {-# SPECIALISE putULEB128 :: BinHandle -> Word64 -> IO () #-} {-# SPECIALISE putULEB128 :: BinHandle -> Word32 -> IO () #-} {-# SPECIALISE putULEB128 :: BinHandle -> Word16 -> IO () #-} {-# SPECIALISE putULEB128 :: BinHandle -> Int -> IO () #-} {-# SPECIALISE putULEB128 :: BinHandle -> Int64 -> IO () #-} {-# SPECIALISE putULEB128 :: BinHandle -> Int32 -> IO () #-} {-# SPECIALISE putULEB128 :: BinHandle -> Int16 -> IO () #-} putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO () putULEB128 bh w = #if defined(DEBUG) (if w < 0 then panic "putULEB128: Signed number" else id) $ #endif go w where go :: a -> IO () go w | w <= (127 :: a) = putByte bh (fromIntegral w :: Word8) | otherwise = do -- bit 7 (8th bit) indicates more to come. let !byte = setBit (fromIntegral w) 7 :: Word8 putByte bh byte go (w `unsafeShiftR` 7) {-# SPECIALISE getULEB128 :: BinHandle -> IO Word #-} {-# SPECIALISE getULEB128 :: BinHandle -> IO Word64 #-} {-# SPECIALISE getULEB128 :: BinHandle -> IO Word32 #-} {-# SPECIALISE getULEB128 :: BinHandle -> IO Word16 #-} {-# SPECIALISE getULEB128 :: BinHandle -> IO Int #-} {-# SPECIALISE getULEB128 :: BinHandle -> IO Int64 #-} {-# SPECIALISE getULEB128 :: BinHandle -> IO Int32 #-} {-# SPECIALISE getULEB128 :: BinHandle -> IO Int16 #-} getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a getULEB128 bh = go 0 0 where go :: Int -> a -> IO a go shift w = do b <- getByte bh let !hasMore = testBit b 7 let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a if hasMore then do go (shift+7) val else return $! val -- Signed numbers {-# SPECIALISE putSLEB128 :: BinHandle -> Word -> IO () #-} {-# SPECIALISE putSLEB128 :: BinHandle -> Word64 -> IO () #-} {-# SPECIALISE putSLEB128 :: BinHandle -> Word32 -> IO () #-} {-# SPECIALISE putSLEB128 :: BinHandle -> Word16 -> IO () #-} {-# SPECIALISE putSLEB128 :: BinHandle -> Int -> IO () #-} {-# SPECIALISE putSLEB128 :: BinHandle -> Int64 -> IO () #-} {-# SPECIALISE putSLEB128 :: BinHandle -> Int32 -> IO () #-} {-# SPECIALISE putSLEB128 :: BinHandle -> Int16 -> IO () #-} putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO () putSLEB128 bh initial = go initial where go :: a -> IO () go val = do let !byte = fromIntegral (clearBit val 7) :: Word8 let !val' = val `unsafeShiftR` 7 let !signBit = testBit byte 6 let !done = -- Unsigned value, val' == 0 and and last value can -- be discriminated from a negative number. ((val' == 0 && not signBit) || -- Signed value, (val' == -1 && signBit)) let !byte' = if done then byte else setBit byte 7 putByte bh byte' unless done $ go val' {-# SPECIALISE getSLEB128 :: BinHandle -> IO Word #-} {-# SPECIALISE getSLEB128 :: BinHandle -> IO Word64 #-} {-# SPECIALISE getSLEB128 :: BinHandle -> IO Word32 #-} {-# SPECIALISE getSLEB128 :: BinHandle -> IO Word16 #-} {-# SPECIALISE getSLEB128 :: BinHandle -> IO Int #-} {-# SPECIALISE getSLEB128 :: BinHandle -> IO Int64 #-} {-# SPECIALISE getSLEB128 :: BinHandle -> IO Int32 #-} {-# SPECIALISE getSLEB128 :: BinHandle -> IO Int16 #-} getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a getSLEB128 bh = do (val,shift,signed) <- go 0 0 if signed && (shift < finiteBitSize val ) then return $! ((complement 0 `unsafeShiftL` shift) .|. val) else return val where go :: Int -> a -> IO (a,Int,Bool) go shift val = do byte <- getByte bh let !byteVal = fromIntegral (clearBit byte 7) :: a let !val' = val .|. (byteVal `unsafeShiftL` shift) let !more = testBit byte 7 let !shift' = shift+7 if more then go (shift') val' else do let !signed = testBit byte 6 return (val',shift',signed) -- ----------------------------------------------------------------------------- -- Primitive Word writes instance Binary Word8 where put_ bh !w = putWord8 bh w get = getWord8 instance Binary Word16 where put_ = putULEB128 get = getULEB128 instance Binary Word32 where put_ = putULEB128 get = getULEB128 instance Binary Word64 where put_ = putULEB128 get = getULEB128 -- ----------------------------------------------------------------------------- -- Primitive Int writes instance Binary Int8 where put_ h w = put_ h (fromIntegral w :: Word8) get h = do w <- get h; return $! (fromIntegral (w::Word8)) instance Binary Int16 where put_ = putSLEB128 get = getSLEB128 instance Binary Int32 where put_ = putSLEB128 get = getSLEB128 instance Binary Int64 where put_ h w = putSLEB128 h w get h = getSLEB128 h -- ----------------------------------------------------------------------------- -- Instances for standard types instance Binary () where put_ _ () = return () get _ = return () instance Binary Bool where put_ bh b = putByte bh (fromIntegral (fromEnum b)) get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) instance Binary Char where put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) instance Binary Int where put_ bh i = put_ bh (fromIntegral i :: Int64) get bh = do x <- get bh return $! (fromIntegral (x :: Int64)) instance Binary a => Binary [a] where put_ bh l = do let len = length l put_ bh len mapM_ (put_ bh) l get bh = do len <- get bh :: IO Int -- Int is variable length encoded so only -- one byte for small lists. let loop 0 = return [] loop n = do a <- get bh; as <- loop (n-1); return (a:as) loop len instance (Ix a, Binary a, Binary b) => Binary (Array a b) where put_ bh arr = do put_ bh $ bounds arr put_ bh $ elems arr get bh = do bounds <- get bh xs <- get bh return $ listArray bounds xs instance (Binary a, Binary b) => Binary (a,b) where put_ bh (a,b) = do put_ bh a; put_ bh b get bh = do a <- get bh b <- get bh return (a,b) instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c get bh = do a <- get bh b <- get bh c <- get bh return (a,b,c) instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d get bh = do a <- get bh b <- get bh c <- get bh d <- get bh return (a,b,c,d) instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; get bh = do a <- get bh b <- get bh c <- get bh d <- get bh e <- get bh return (a,b,c,d,e) instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; get bh = do a <- get bh b <- get bh c <- get bh d <- get bh e <- get bh f <- get bh return (a,b,c,d,e,f) instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g get bh = do a <- get bh b <- get bh c <- get bh d <- get bh e <- get bh f <- get bh g <- get bh return (a,b,c,d,e,f,g) instance Binary a => Binary (Maybe a) where put_ bh Nothing = putByte bh 0 put_ bh (Just a) = do putByte bh 1; put_ bh a get bh = do h <- getWord8 bh case h of 0 -> return Nothing _ -> do x <- get bh; return (Just x) instance (Binary a, Binary b) => Binary (Either a b) where put_ bh (Left a) = do putByte bh 0; put_ bh a put_ bh (Right b) = do putByte bh 1; put_ bh b get bh = do h <- getWord8 bh case h of 0 -> do a <- get bh ; return (Left a) _ -> do b <- get bh ; return (Right b) instance Binary UTCTime where put_ bh u = do put_ bh (utctDay u) put_ bh (utctDayTime u) get bh = do day <- get bh dayTime <- get bh return $ UTCTime { utctDay = day, utctDayTime = dayTime } instance Binary Day where put_ bh d = put_ bh (toModifiedJulianDay d) get bh = do i <- get bh return $ ModifiedJulianDay { toModifiedJulianDay = i } instance Binary DiffTime where put_ bh dt = put_ bh (toRational dt) get bh = do r <- get bh return $ fromRational r {- Finally - a reasonable portable Integer instance. We used to encode values in the Int32 range as such, falling back to a string of all things. In either case we stored a tag byte to discriminate between the two cases. This made some sense as it's highly portable but also not very efficient. However GHC stores a surprisingly large number off large Integer values. In the examples looked at between 25% and 50% of Integers serialized were outside of the Int32 range. Consider a valie like `2724268014499746065`, some sort of hash actually generated by GHC. In the old scheme this was encoded as a list of 19 chars. This gave a size of 77 Bytes, one for the length of the list and 76 since we encod chars as Word32 as well. We can easily do better. The new plan is: * Start with a tag byte * 0 => Int64 (LEB128 encoded) * 1 => Negative large interger * 2 => Positive large integer * Followed by the value: * Int64 is encoded as usual * Large integers are encoded as a list of bytes (Word8). We use Data.Bits which defines a bit order independent of the representation. Values are stored LSB first. This means our example value `2724268014499746065` is now only 10 bytes large. * One byte tag * One byte for the length of the [Word8] list. * 8 bytes for the actual date. The new scheme also does not depend in any way on architecture specific details. We still use this scheme even with LEB128 available, as it has less overhead for truely large numbers. (> maxBound :: Int64) The instance is used for in Binary Integer and Binary Rational in basicTypes/Literal.hs -} instance Binary Integer where put_ bh i | i >= lo64 && i <= hi64 = do putWord8 bh 0 put_ bh (fromIntegral i :: Int64) | otherwise = do if i < 0 then putWord8 bh 1 else putWord8 bh 2 put_ bh (unroll $ abs i) where lo64 = fromIntegral (minBound :: Int64) hi64 = fromIntegral (maxBound :: Int64) get bh = do int_kind <- getWord8 bh case int_kind of 0 -> fromIntegral <$!> (get bh :: IO Int64) -- Large integer 1 -> negate <$!> getInt 2 -> getInt _ -> panic "Binary Integer - Invalid byte" where getInt :: IO Integer getInt = roll <$!> (get bh :: IO [Word8]) unroll :: Integer -> [Word8] unroll = unfoldr step where step 0 = Nothing step i = Just (fromIntegral i, i `shiftR` 8) roll :: [Word8] -> Integer roll = foldl' unstep 0 . reverse where unstep a b = a `shiftL` 8 .|. fromIntegral b {- -- This code is currently commented out. -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for -- discussion. put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) put_ bh (J# s# a#) = do putByte bh 1 put_ bh (I# s#) let sz# = sizeofByteArray# a# -- in *bytes* put_ bh (I# sz#) -- in *bytes* putByteArray bh a# sz# get bh = do b <- getByte bh case b of 0 -> do (I# i#) <- get bh return (S# i#) _ -> do (I# s#) <- get bh sz <- get bh (BA a#) <- getByteArray bh sz return (J# s# a#) putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () putByteArray bh a s# = loop 0# where loop n# | n# ==# s# = return () | otherwise = do putByte bh (indexByteArray a n#) loop (n# +# 1#) getByteArray :: BinHandle -> Int -> IO ByteArray getByteArray bh (I# sz) = do (MBA arr) <- newByteArray sz let loop n | n ==# sz = return () | otherwise = do w <- getByte bh writeByteArray arr n w loop (n +# 1#) loop 0# freezeByteArray arr -} {- data ByteArray = BA ByteArray# data MBA = MBA (MutableByteArray# RealWorld) newByteArray :: Int# -> IO MBA newByteArray sz = IO $ \s -> case newByteArray# sz s of { (# s, arr #) -> (# s, MBA arr #) } freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray freezeByteArray arr = IO $ \s -> case unsafeFreezeByteArray# arr s of { (# s, arr #) -> (# s, BA arr #) } writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () writeByteArray arr i (W8# w) = IO $ \s -> case writeWord8Array# arr i w s of { s -> (# s, () #) } indexByteArray :: ByteArray# -> Int# -> Word8 indexByteArray a# n# = W8# (indexWord8Array# a# n#) -} instance (Binary a) => Binary (Ratio a) where put_ bh (a :% b) = do put_ bh a; put_ bh b get bh = do a <- get bh; b <- get bh; return (a :% b) -- Instance uses fixed-width encoding to allow inserting -- Bin placeholders in the stream. instance Binary (Bin a) where put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32) get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32))) -- ----------------------------------------------------------------------------- -- Instances for Data.Typeable stuff instance Binary TyCon where put_ bh tc = do put_ bh (tyConPackage tc) put_ bh (tyConModule tc) put_ bh (tyConName tc) put_ bh (tyConKindArgs tc) put_ bh (tyConKindRep tc) get bh = mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh instance Binary VecCount where put_ bh = putByte bh . fromIntegral . fromEnum get bh = toEnum . fromIntegral <$> getByte bh instance Binary VecElem where put_ bh = putByte bh . fromIntegral . fromEnum get bh = toEnum . fromIntegral <$> getByte bh instance Binary RuntimeRep where put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps put_ bh LiftedRep = putByte bh 3 put_ bh UnliftedRep = putByte bh 4 put_ bh IntRep = putByte bh 5 put_ bh WordRep = putByte bh 6 put_ bh Int64Rep = putByte bh 7 put_ bh Word64Rep = putByte bh 8 put_ bh AddrRep = putByte bh 9 put_ bh FloatRep = putByte bh 10 put_ bh DoubleRep = putByte bh 11 #if __GLASGOW_HASKELL__ >= 807 put_ bh Int8Rep = putByte bh 12 put_ bh Word8Rep = putByte bh 13 put_ bh Int16Rep = putByte bh 14 put_ bh Word16Rep = putByte bh 15 #endif #if __GLASGOW_HASKELL__ >= 809 put_ bh Int32Rep = putByte bh 16 put_ bh Word32Rep = putByte bh 17 #endif get bh = do tag <- getByte bh case tag of 0 -> VecRep <$> get bh <*> get bh 1 -> TupleRep <$> get bh 2 -> SumRep <$> get bh 3 -> pure LiftedRep 4 -> pure UnliftedRep 5 -> pure IntRep 6 -> pure WordRep 7 -> pure Int64Rep 8 -> pure Word64Rep 9 -> pure AddrRep 10 -> pure FloatRep 11 -> pure DoubleRep #if __GLASGOW_HASKELL__ >= 807 12 -> pure Int8Rep 13 -> pure Word8Rep 14 -> pure Int16Rep 15 -> pure Word16Rep #endif #if __GLASGOW_HASKELL__ >= 809 16 -> pure Int32Rep 17 -> pure Word32Rep #endif _ -> fail "Binary.putRuntimeRep: invalid tag" instance Binary KindRep where put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r get bh = do tag <- getByte bh case tag of 0 -> KindRepTyConApp <$> get bh <*> get bh 1 -> KindRepVar <$> get bh 2 -> KindRepApp <$> get bh <*> get bh 3 -> KindRepFun <$> get bh <*> get bh 4 -> KindRepTYPE <$> get bh 5 -> KindRepTypeLit <$> get bh <*> get bh _ -> fail "Binary.putKindRep: invalid tag" instance Binary TypeLitSort where put_ bh TypeLitSymbol = putByte bh 0 put_ bh TypeLitNat = putByte bh 1 get bh = do tag <- getByte bh case tag of 0 -> pure TypeLitSymbol 1 -> pure TypeLitNat _ -> fail "Binary.putTypeLitSort: invalid tag" putTypeRep :: BinHandle -> TypeRep a -> IO () -- Special handling for TYPE, (->), and RuntimeRep due to recursive kind -- relations. -- See Note [Mutually recursive representations of primitive types] putTypeRep bh rep | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) = put_ bh (0 :: Word8) putTypeRep bh (Con' con ks) = do put_ bh (1 :: Word8) put_ bh con put_ bh ks putTypeRep bh (App f x) = do put_ bh (2 :: Word8) putTypeRep bh f putTypeRep bh x putTypeRep bh (Fun arg res) = do put_ bh (3 :: Word8) putTypeRep bh arg putTypeRep bh res getSomeTypeRep :: BinHandle -> IO SomeTypeRep getSomeTypeRep bh = do tag <- get bh :: IO Word8 case tag of 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type) 1 -> do con <- get bh :: IO TyCon ks <- get bh :: IO [SomeTypeRep] return $ SomeTypeRep $ mkTrCon con ks 2 -> do SomeTypeRep f <- getSomeTypeRep bh SomeTypeRep x <- getSomeTypeRep bh case typeRepKind f of Fun arg res -> case arg `eqTypeRep` typeRepKind x of Just HRefl -> case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of Just HRefl -> return $ SomeTypeRep $ mkTrApp f x _ -> failure "Kind mismatch in type application" [] _ -> failure "Kind mismatch in type application" [ " Found argument of kind: " ++ show (typeRepKind x) , " Where the constructor: " ++ show f , " Expects kind: " ++ show arg ] _ -> failure "Applied non-arrow" [ " Applied type: " ++ show f , " To argument: " ++ show x ] 3 -> do SomeTypeRep arg <- getSomeTypeRep bh SomeTypeRep res <- getSomeTypeRep bh if | App argkcon _ <- typeRepKind arg , App reskcon _ <- typeRepKind res , Just HRefl <- argkcon `eqTypeRep` tYPErep , Just HRefl <- reskcon `eqTypeRep` tYPErep -> return $ SomeTypeRep $ Fun arg res | otherwise -> failure "Kind mismatch" [] _ -> failure "Invalid SomeTypeRep" [] where tYPErep :: TypeRep TYPE tYPErep = typeRep failure description info = fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ] ++ map (" "++) info instance Typeable a => Binary (TypeRep (a :: k)) where put_ = putTypeRep get bh = do SomeTypeRep rep <- getSomeTypeRep bh case rep `eqTypeRep` expected of Just HRefl -> pure rep Nothing -> fail $ unlines [ "Binary: Type mismatch" , " Deserialized type: " ++ show rep , " Expected type: " ++ show expected ] where expected = typeRep :: TypeRep a instance Binary SomeTypeRep where put_ bh (SomeTypeRep rep) = putTypeRep bh rep get = getSomeTypeRep -- ----------------------------------------------------------------------------- -- Lazy reading/writing lazyPut :: Binary a => BinHandle -> a -> IO () lazyPut bh a = do -- output the obj with a ptr to skip over it: pre_a <- tellBin bh put_ bh pre_a -- save a slot for the ptr put_ bh a -- dump the object q <- tellBin bh -- q = ptr to after object putAt bh pre_a q -- fill in slot before a with ptr to q seekBin bh q -- finally carry on writing at q lazyGet :: Binary a => BinHandle -> IO a lazyGet bh = do p <- get bh -- a BinPtr p_a <- tellBin bh a <- unsafeInterleaveIO $ do -- NB: Use a fresh off_r variable in the child thread, for thread -- safety. off_r <- newFastMutInt getAt bh { _off_r = off_r } p_a seekBin bh p -- skip over the object for now return a -- ----------------------------------------------------------------------------- -- UserData -- ----------------------------------------------------------------------------- -- | Information we keep around during interface file -- serialization/deserialization. Namely we keep the functions for serializing -- and deserializing 'Name's and 'FastString's. We do this because we actually -- use serialization in two distinct settings, -- -- * When serializing interface files themselves -- -- * When computing the fingerprint of an IfaceDecl (which we computing by -- hashing its Binary serialization) -- -- These two settings have different needs while serializing Names: -- -- * Names in interface files are serialized via a symbol table (see Note -- [Symbol table representation of names] in BinIface). -- -- * During fingerprinting a binding Name is serialized as the OccName and a -- non-binding Name is serialized as the fingerprint of the thing they -- represent. See Note [Fingerprinting IfaceDecls] for further discussion. -- data UserData = UserData { -- for *deserialising* only: ud_get_name :: BinHandle -> IO Name, ud_get_fs :: BinHandle -> IO FastString, -- for *serialising* only: ud_put_nonbinding_name :: BinHandle -> Name -> IO (), -- ^ serialize a non-binding 'Name' (e.g. a reference to another -- binding). ud_put_binding_name :: BinHandle -> Name -> IO (), -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl) ud_put_fs :: BinHandle -> FastString -> IO () } newReadState :: (BinHandle -> IO Name) -- ^ how to deserialize 'Name's -> (BinHandle -> IO FastString) -> UserData newReadState get_name get_fs = UserData { ud_get_name = get_name, ud_get_fs = get_fs, ud_put_nonbinding_name = undef "put_nonbinding_name", ud_put_binding_name = undef "put_binding_name", ud_put_fs = undef "put_fs" } newWriteState :: (BinHandle -> Name -> IO ()) -- ^ how to serialize non-binding 'Name's -> (BinHandle -> Name -> IO ()) -- ^ how to serialize binding 'Name's -> (BinHandle -> FastString -> IO ()) -> UserData newWriteState put_nonbinding_name put_binding_name put_fs = UserData { ud_get_name = undef "get_name", ud_get_fs = undef "get_fs", ud_put_nonbinding_name = put_nonbinding_name, ud_put_binding_name = put_binding_name, ud_put_fs = put_fs } noUserData :: a noUserData = undef "UserData" undef :: String -> a undef s = panic ("Binary.UserData: no " ++ s) --------------------------------------------------------- -- The Dictionary --------------------------------------------------------- type Dictionary = Array Int FastString -- The dictionary -- Should be 0-indexed putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO () putDictionary bh sz dict = do put_ bh sz mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict))) -- It's OK to use nonDetEltsUFM here because the elements have indices -- that array uses to create order getDictionary :: BinHandle -> IO Dictionary getDictionary bh = do sz <- get bh elems <- sequence (take sz (repeat (getFS bh))) return (listArray (0,sz-1) elems) --------------------------------------------------------- -- The Symbol Table --------------------------------------------------------- -- On disk, the symbol table is an array of IfExtName, when -- reading it in we turn it into a SymbolTable. type SymbolTable = Array Int Name --------------------------------------------------------- -- Reading and writing FastStrings --------------------------------------------------------- putFS :: BinHandle -> FastString -> IO () putFS bh fs = putBS bh $ bytesFS fs getFS :: BinHandle -> IO FastString getFS bh = do l <- get bh :: IO Int getPrim bh l (\src -> pure $! mkFastStringBytes src l ) putBS :: BinHandle -> ByteString -> IO () putBS bh bs = BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do put_ bh l putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l) getBS :: BinHandle -> IO ByteString getBS bh = do l <- get bh :: IO Int BS.create l $ \dest -> do getPrim bh l (\src -> BS.memcpy dest src l) instance Binary ByteString where put_ bh f = putBS bh f get bh = getBS bh instance Binary FastString where put_ bh f = case getUserData bh of UserData { ud_put_fs = put_fs } -> put_fs bh f get bh = case getUserData bh of UserData { ud_get_fs = get_fs } -> get_fs bh -- Here to avoid loop instance Binary LeftOrRight where put_ bh CLeft = putByte bh 0 put_ bh CRight = putByte bh 1 get bh = do { h <- getByte bh ; case h of 0 -> return CLeft _ -> return CRight } instance Binary PromotionFlag where put_ bh NotPromoted = putByte bh 0 put_ bh IsPromoted = putByte bh 1 get bh = do n <- getByte bh case n of 0 -> return NotPromoted 1 -> return IsPromoted _ -> fail "Binary(IsPromoted): fail)" instance Binary Fingerprint where put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) instance Binary FunctionOrData where put_ bh IsFunction = putByte bh 0 put_ bh IsData = putByte bh 1 get bh = do h <- getByte bh case h of 0 -> return IsFunction 1 -> return IsData _ -> panic "Binary FunctionOrData" instance Binary TupleSort where put_ bh BoxedTuple = putByte bh 0 put_ bh UnboxedTuple = putByte bh 1 put_ bh ConstraintTuple = putByte bh 2 get bh = do h <- getByte bh case h of 0 -> do return BoxedTuple 1 -> do return UnboxedTuple _ -> do return ConstraintTuple instance Binary Activation where put_ bh NeverActive = do putByte bh 0 put_ bh AlwaysActive = do putByte bh 1 put_ bh (ActiveBefore src aa) = do putByte bh 2 put_ bh src put_ bh aa put_ bh (ActiveAfter src ab) = do putByte bh 3 put_ bh src put_ bh ab get bh = do h <- getByte bh case h of 0 -> do return NeverActive 1 -> do return AlwaysActive 2 -> do src <- get bh aa <- get bh return (ActiveBefore src aa) _ -> do src <- get bh ab <- get bh return (ActiveAfter src ab) instance Binary InlinePragma where put_ bh (InlinePragma s a b c d) = do put_ bh s put_ bh a put_ bh b put_ bh c put_ bh d get bh = do s <- get bh a <- get bh b <- get bh c <- get bh d <- get bh return (InlinePragma s a b c d) instance Binary RuleMatchInfo where put_ bh FunLike = putByte bh 0 put_ bh ConLike = putByte bh 1 get bh = do h <- getByte bh if h == 1 then return ConLike else return FunLike instance Binary InlineSpec where put_ bh NoUserInline = putByte bh 0 put_ bh Inline = putByte bh 1 put_ bh Inlinable = putByte bh 2 put_ bh NoInline = putByte bh 3 get bh = do h <- getByte bh case h of 0 -> return NoUserInline 1 -> return Inline 2 -> return Inlinable _ -> return NoInline instance Binary RecFlag where put_ bh Recursive = do putByte bh 0 put_ bh NonRecursive = do putByte bh 1 get bh = do h <- getByte bh case h of 0 -> do return Recursive _ -> do return NonRecursive instance Binary OverlapMode where put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s get bh = do h <- getByte bh case h of 0 -> (get bh) >>= \s -> return $ NoOverlap s 1 -> (get bh) >>= \s -> return $ Overlaps s 2 -> (get bh) >>= \s -> return $ Incoherent s 3 -> (get bh) >>= \s -> return $ Overlapping s 4 -> (get bh) >>= \s -> return $ Overlappable s _ -> panic ("get OverlapMode" ++ show h) instance Binary OverlapFlag where put_ bh flag = do put_ bh (overlapMode flag) put_ bh (isSafeOverlap flag) get bh = do h <- get bh b <- get bh return OverlapFlag { overlapMode = h, isSafeOverlap = b } instance Binary FixityDirection where put_ bh InfixL = do putByte bh 0 put_ bh InfixR = do putByte bh 1 put_ bh InfixN = do putByte bh 2 get bh = do h <- getByte bh case h of 0 -> do return InfixL 1 -> do return InfixR _ -> do return InfixN instance Binary Fixity where put_ bh (Fixity src aa ab) = do put_ bh src put_ bh aa put_ bh ab get bh = do src <- get bh aa <- get bh ab <- get bh return (Fixity src aa ab) instance Binary WarningTxt where put_ bh (WarningTxt s w) = do putByte bh 0 put_ bh s put_ bh w put_ bh (DeprecatedTxt s d) = do putByte bh 1 put_ bh s put_ bh d get bh = do h <- getByte bh case h of 0 -> do s <- get bh w <- get bh return (WarningTxt s w) _ -> do s <- get bh d <- get bh return (DeprecatedTxt s d) instance Binary StringLiteral where put_ bh (StringLiteral st fs) = do put_ bh st put_ bh fs get bh = do st <- get bh fs <- get bh return (StringLiteral st fs) instance Binary a => Binary (Located a) where put_ bh (L l x) = do put_ bh l put_ bh x get bh = do l <- get bh x <- get bh return (L l x) instance Binary RealSrcSpan where put_ bh ss = do put_ bh (srcSpanFile ss) put_ bh (srcSpanStartLine ss) put_ bh (srcSpanStartCol ss) put_ bh (srcSpanEndLine ss) put_ bh (srcSpanEndCol ss) get bh = do f <- get bh sl <- get bh sc <- get bh el <- get bh ec <- get bh return (mkRealSrcSpan (mkRealSrcLoc f sl sc) (mkRealSrcLoc f el ec)) instance Binary SrcSpan where put_ bh (RealSrcSpan ss) = do putByte bh 0 put_ bh ss put_ bh (UnhelpfulSpan s) = do putByte bh 1 put_ bh s get bh = do h <- getByte bh case h of 0 -> do ss <- get bh return (RealSrcSpan ss) _ -> do s <- get bh return (UnhelpfulSpan s) instance Binary Serialized where put_ bh (Serialized the_type bytes) = do put_ bh the_type put_ bh bytes get bh = do the_type <- get bh bytes <- get bh return (Serialized the_type bytes) instance Binary SourceText where put_ bh NoSourceText = putByte bh 0 put_ bh (SourceText s) = do putByte bh 1 put_ bh s get bh = do h <- getByte bh case h of 0 -> return NoSourceText 1 -> do s <- get bh return (SourceText s) _ -> panic $ "Binary SourceText:" ++ show h ghc-lib-parser-8.10.2.20200808/compiler/backpack/BkpSyn.hs0000644000000000000000000000510613713635744020623 0ustar0000000000000000-- | This is the syntax for bkp files which are parsed in 'ghc --backpack' -- mode. This syntax is used purely for testing purposes. module BkpSyn ( -- * Backpack abstract syntax HsUnitId(..), LHsUnitId, HsModuleSubst, LHsModuleSubst, HsModuleId(..), LHsModuleId, HsComponentId(..), LHsUnit, HsUnit(..), LHsUnitDecl, HsUnitDecl(..), IncludeDecl(..), LRenaming, Renaming(..), ) where import GhcPrelude import DriverPhases import GHC.Hs import SrcLoc import Outputable import Module import PackageConfig {- ************************************************************************ * * User syntax * * ************************************************************************ -} data HsComponentId = HsComponentId { hsPackageName :: PackageName, hsComponentId :: ComponentId } instance Outputable HsComponentId where ppr (HsComponentId _pn cid) = ppr cid -- todo debug with pn data HsUnitId n = HsUnitId (Located n) [LHsModuleSubst n] type LHsUnitId n = Located (HsUnitId n) type HsModuleSubst n = (Located ModuleName, LHsModuleId n) type LHsModuleSubst n = Located (HsModuleSubst n) data HsModuleId n = HsModuleVar (Located ModuleName) | HsModuleId (LHsUnitId n) (Located ModuleName) type LHsModuleId n = Located (HsModuleId n) -- | Top level @unit@ declaration in a Backpack file. data HsUnit n = HsUnit { hsunitName :: Located n, hsunitBody :: [LHsUnitDecl n] } type LHsUnit n = Located (HsUnit n) -- | A declaration in a package, e.g. a module or signature definition, -- or an include. data HsUnitDecl n = DeclD HscSource (Located ModuleName) (Maybe (Located (HsModule GhcPs))) | IncludeD (IncludeDecl n) type LHsUnitDecl n = Located (HsUnitDecl n) -- | An include of another unit data IncludeDecl n = IncludeDecl { idUnitId :: LHsUnitId n, idModRenaming :: Maybe [ LRenaming ], -- | Is this a @dependency signature@ include? If so, -- we don't compile this include when we instantiate this -- unit (as there should not be any modules brought into -- scope.) idSignatureInclude :: Bool } -- | Rename a module from one name to another. The identity renaming -- means that the module should be brought into scope. data Renaming = Renaming { renameFrom :: Located ModuleName , renameTo :: Maybe (Located ModuleName) } type LRenaming = Located Renaming ghc-lib-parser-8.10.2.20200808/compiler/utils/BooleanFormula.hs0000644000000000000000000002313613713635745021727 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -------------------------------------------------------------------------------- -- | Boolean formulas without quantifiers and without negation. -- Such a formula consists of variables, conjunctions (and), and disjunctions (or). -- -- This module is used to represent minimal complete definitions for classes. -- module BooleanFormula ( BooleanFormula(..), LBooleanFormula, mkFalse, mkTrue, mkAnd, mkOr, mkVar, isFalse, isTrue, eval, simplify, isUnsatisfied, implies, impliesAtom, pprBooleanFormula, pprBooleanFormulaNice ) where import GhcPrelude import Data.List ( nub, intersperse ) import Data.Data import MonadUtils import Outputable import Binary import SrcLoc import Unique import UniqSet ---------------------------------------------------------------------- -- Boolean formula type and smart constructors ---------------------------------------------------------------------- type LBooleanFormula a = Located (BooleanFormula a) data BooleanFormula a = Var a | And [LBooleanFormula a] | Or [LBooleanFormula a] | Parens (LBooleanFormula a) deriving (Eq, Data, Functor, Foldable, Traversable) mkVar :: a -> BooleanFormula a mkVar = Var mkFalse, mkTrue :: BooleanFormula a mkFalse = Or [] mkTrue = And [] -- Convert a Bool to a BooleanFormula mkBool :: Bool -> BooleanFormula a mkBool False = mkFalse mkBool True = mkTrue -- Make a conjunction, and try to simplify mkAnd :: Eq a => [LBooleanFormula a] -> BooleanFormula a mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd where -- See Note [Simplification of BooleanFormulas] fromAnd :: LBooleanFormula a -> Maybe [LBooleanFormula a] fromAnd (L _ (And xs)) = Just xs -- assume that xs are already simplified -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs fromAnd (L _ (Or [])) = Nothing -- in case of False we bail out, And [..,mkFalse,..] == mkFalse fromAnd x = Just [x] mkAnd' [x] = unLoc x mkAnd' xs = And xs mkOr :: Eq a => [LBooleanFormula a] -> BooleanFormula a mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr where -- See Note [Simplification of BooleanFormulas] fromOr (L _ (Or xs)) = Just xs fromOr (L _ (And [])) = Nothing fromOr x = Just [x] mkOr' [x] = unLoc x mkOr' xs = Or xs {- Note [Simplification of BooleanFormulas] ~~~~~~~~~~~~~~~~~~~~~~ The smart constructors (`mkAnd` and `mkOr`) do some attempt to simplify expressions. In particular, 1. Collapsing nested ands and ors, so `(mkAnd [x, And [y,z]]` is represented as `And [x,y,z]` Implemented by `fromAnd`/`fromOr` 2. Collapsing trivial ands and ors, so `mkAnd [x]` becomes just `x`. Implemented by mkAnd' / mkOr' 3. Conjunction with false, disjunction with true is simplified, i.e. `mkAnd [mkFalse,x]` becomes `mkFalse`. 4. Common subexpression elimination: `mkAnd [x,x,y]` is reduced to just `mkAnd [x,y]`. This simplification is not exhaustive, in the sense that it will not produce the smallest possible equivalent expression. For example, `Or [And [x,y], And [x]]` could be simplified to `And [x]`, but it currently is not. A general simplifier would need to use something like BDDs. The reason behind the (crude) simplifier is to make for more user friendly error messages. E.g. for the code > class Foo a where > {-# MINIMAL bar, (foo, baq | foo, quux) #-} > instance Foo Int where > bar = ... > baz = ... > quux = ... We don't show a ridiculous error message like Implement () and (either (`foo' and ()) or (`foo' and ())) -} ---------------------------------------------------------------------- -- Evaluation and simplification ---------------------------------------------------------------------- isFalse :: BooleanFormula a -> Bool isFalse (Or []) = True isFalse _ = False isTrue :: BooleanFormula a -> Bool isTrue (And []) = True isTrue _ = False eval :: (a -> Bool) -> BooleanFormula a -> Bool eval f (Var x) = f x eval f (And xs) = all (eval f . unLoc) xs eval f (Or xs) = any (eval f . unLoc) xs eval f (Parens x) = eval f (unLoc x) -- Simplify a boolean formula. -- The argument function should give the truth of the atoms, or Nothing if undecided. simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a simplify f (Var a) = case f a of Nothing -> Var a Just b -> mkBool b simplify f (And xs) = mkAnd (map (\(L l x) -> L l (simplify f x)) xs) simplify f (Or xs) = mkOr (map (\(L l x) -> L l (simplify f x)) xs) simplify f (Parens x) = simplify f (unLoc x) -- Test if a boolean formula is satisfied when the given values are assigned to the atoms -- if it is, returns Nothing -- if it is not, return (Just remainder) isUnsatisfied :: Eq a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a) isUnsatisfied f bf | isTrue bf' = Nothing | otherwise = Just bf' where f' x = if f x then Just True else Nothing bf' = simplify f' bf -- prop_simplify: -- eval f x == True <==> isTrue (simplify (Just . f) x) -- eval f x == False <==> isFalse (simplify (Just . f) x) -- If the boolean formula holds, does that mean that the given atom is always true? impliesAtom :: Eq a => BooleanFormula a -> a -> Bool Var x `impliesAtom` y = x == y And xs `impliesAtom` y = any (\x -> (unLoc x) `impliesAtom` y) xs -- we have all of xs, so one of them implying y is enough Or xs `impliesAtom` y = all (\x -> (unLoc x) `impliesAtom` y) xs Parens x `impliesAtom` y = (unLoc x) `impliesAtom` y implies :: Uniquable a => BooleanFormula a -> BooleanFormula a -> Bool implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2]) where go :: Uniquable a => Clause a -> Clause a -> Bool go l@Clause{ clauseExprs = hyp:hyps } r = case hyp of Var x | memberClauseAtoms x r -> True | otherwise -> go (extendClauseAtoms l x) { clauseExprs = hyps } r Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps } r And hyps' -> go l { clauseExprs = map unLoc hyps' ++ hyps } r Or hyps' -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps' go l r@Clause{ clauseExprs = con:cons } = case con of Var x | memberClauseAtoms x l -> True | otherwise -> go l (extendClauseAtoms r x) { clauseExprs = cons } Parens con' -> go l r { clauseExprs = unLoc con':cons } And cons' -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons' Or cons' -> go l r { clauseExprs = map unLoc cons' ++ cons } go _ _ = False -- A small sequent calculus proof engine. data Clause a = Clause { clauseAtoms :: UniqSet a, clauseExprs :: [BooleanFormula a] } extendClauseAtoms :: Uniquable a => Clause a -> a -> Clause a extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x } memberClauseAtoms :: Uniquable a => a -> Clause a -> Bool memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c ---------------------------------------------------------------------- -- Pretty printing ---------------------------------------------------------------------- -- Pretty print a BooleanFormula, -- using the arguments as pretty printers for Var, And and Or respectively pprBooleanFormula' :: (Rational -> a -> SDoc) -> (Rational -> [SDoc] -> SDoc) -> (Rational -> [SDoc] -> SDoc) -> Rational -> BooleanFormula a -> SDoc pprBooleanFormula' pprVar pprAnd pprOr = go where go p (Var x) = pprVar p x go p (And []) = cparen (p > 0) $ empty go p (And xs) = pprAnd p (map (go 3 . unLoc) xs) go _ (Or []) = keyword $ text "FALSE" go p (Or xs) = pprOr p (map (go 2 . unLoc) xs) go p (Parens x) = go p (unLoc x) -- Pretty print in source syntax, "a | b | c,d,e" pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> SDoc pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr where pprAnd p = cparen (p > 3) . fsep . punctuate comma pprOr p = cparen (p > 2) . fsep . intersperse vbar -- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"? pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0 where pprVar _ = quotes . ppr pprAnd p = cparen (p > 1) . pprAnd' pprAnd' [] = empty pprAnd' [x,y] = x <+> text "and" <+> y pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs) instance (OutputableBndr a) => Outputable (BooleanFormula a) where ppr = pprBooleanFormulaNormal pprBooleanFormulaNormal :: (OutputableBndr a) => BooleanFormula a -> SDoc pprBooleanFormulaNormal = go where go (Var x) = pprPrefixOcc x go (And xs) = fsep $ punctuate comma (map (go . unLoc) xs) go (Or []) = keyword $ text "FALSE" go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs) go (Parens x) = parens (go $ unLoc x) ---------------------------------------------------------------------- -- Binary ---------------------------------------------------------------------- instance Binary a => Binary (BooleanFormula a) where put_ bh (Var x) = putByte bh 0 >> put_ bh x put_ bh (And xs) = putByte bh 1 >> put_ bh xs put_ bh (Or xs) = putByte bh 2 >> put_ bh xs put_ bh (Parens x) = putByte bh 3 >> put_ bh x get bh = do h <- getByte bh case h of 0 -> Var <$> get bh 1 -> And <$> get bh 2 -> Or <$> get bh _ -> Parens <$> get bh ghc-lib-parser-8.10.2.20200808/compiler/utils/BufWrite.hs0000644000000000000000000001034413713635745020546 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- -- Fast write-buffered Handles -- -- (c) The University of Glasgow 2005-2006 -- -- This is a simple abstraction over Handles that offers very fast write -- buffering, but without the thread safety that Handles provide. It's used -- to save time in Pretty.printDoc. -- ----------------------------------------------------------------------------- module BufWrite ( BufHandle(..), newBufHandle, bPutChar, bPutStr, bPutFS, bPutFZS, bPutPtrString, bPutReplicate, bFlush, ) where import GhcPrelude import FastString import FastMutInt import Control.Monad ( when ) import Data.ByteString (ByteString) import qualified Data.ByteString.Unsafe as BS import Data.Char ( ord ) import Foreign import Foreign.C.String import System.IO -- ----------------------------------------------------------------------------- data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8) {-#UNPACK#-}!FastMutInt Handle newBufHandle :: Handle -> IO BufHandle newBufHandle hdl = do ptr <- mallocBytes buf_size r <- newFastMutInt writeFastMutInt r 0 return (BufHandle ptr r hdl) buf_size :: Int buf_size = 8192 bPutChar :: BufHandle -> Char -> IO () bPutChar b@(BufHandle buf r hdl) !c = do i <- readFastMutInt r if (i >= buf_size) then do hPutBuf hdl buf buf_size writeFastMutInt r 0 bPutChar b c else do pokeElemOff buf i (fromIntegral (ord c) :: Word8) writeFastMutInt r (i+1) bPutStr :: BufHandle -> String -> IO () bPutStr (BufHandle buf r hdl) !str = do i <- readFastMutInt r loop str i where loop "" !i = do writeFastMutInt r i; return () loop (c:cs) !i | i >= buf_size = do hPutBuf hdl buf buf_size loop (c:cs) 0 | otherwise = do pokeElemOff buf i (fromIntegral (ord c)) loop cs (i+1) bPutFS :: BufHandle -> FastString -> IO () bPutFS b fs = bPutBS b $ bytesFS fs bPutFZS :: BufHandle -> FastZString -> IO () bPutFZS b fs = bPutBS b $ fastZStringToByteString fs bPutBS :: BufHandle -> ByteString -> IO () bPutBS b bs = BS.unsafeUseAsCStringLen bs $ bPutCStringLen b bPutCStringLen :: BufHandle -> CStringLen -> IO () bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do i <- readFastMutInt r if (i + len) >= buf_size then do hPutBuf hdl buf i writeFastMutInt r 0 if (len >= buf_size) then hPutBuf hdl ptr len else bPutCStringLen b cstr else do copyBytes (buf `plusPtr` i) ptr len writeFastMutInt r (i + len) bPutPtrString :: BufHandle -> PtrString -> IO () bPutPtrString b@(BufHandle buf r hdl) l@(PtrString a len) = l `seq` do i <- readFastMutInt r if (i+len) >= buf_size then do hPutBuf hdl buf i writeFastMutInt r 0 if (len >= buf_size) then hPutBuf hdl a len else bPutPtrString b l else do copyBytes (buf `plusPtr` i) a len writeFastMutInt r (i+len) -- | Replicate an 8-bit character bPutReplicate :: BufHandle -> Int -> Char -> IO () bPutReplicate (BufHandle buf r hdl) len c = do i <- readFastMutInt r let oc = fromIntegral (ord c) if (i+len) < buf_size then do fillBytes (buf `plusPtr` i) oc len writeFastMutInt r (i+len) else do -- flush the current buffer when (i /= 0) $ hPutBuf hdl buf i if (len < buf_size) then do fillBytes buf oc len writeFastMutInt r len else do -- fill a full buffer fillBytes buf oc buf_size -- flush it as many times as necessary let go n | n >= buf_size = do hPutBuf hdl buf buf_size go (n-buf_size) | otherwise = writeFastMutInt r n go len bFlush :: BufHandle -> IO () bFlush (BufHandle buf r hdl) = do i <- readFastMutInt r when (i > 0) $ hPutBuf hdl buf i free buf return () ghc-lib-parser-8.10.2.20200808/compiler/ghci/ByteCodeTypes.hs0000644000000000000000000001305613713635745021317 0ustar0000000000000000{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-} -- -- (c) The University of Glasgow 2002-2006 -- -- | Bytecode assembler types module ByteCodeTypes ( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..) , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..) , ItblEnv, ItblPtr(..) , CgBreakInfo(..) , ModBreaks (..), BreakIndex, emptyModBreaks , CCostCentre ) where import GhcPrelude import FastString import Id import Name import NameEnv import Outputable import PrimOp import SizedSeq import Type import SrcLoc import GHCi.BreakArray import GHCi.RemoteTypes import GHCi.FFI import Control.DeepSeq import Foreign import Data.Array import Data.Array.Base ( UArray(..) ) import Data.ByteString (ByteString) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Maybe (catMaybes) import GHC.Exts.Heap import GHC.Stack.CCS -- ----------------------------------------------------------------------------- -- Compiled Byte Code data CompiledByteCode = CompiledByteCode { bc_bcos :: [UnlinkedBCO] -- Bunch of interpretable bindings , bc_itbls :: ItblEnv -- A mapping from DataCons to their itbls , bc_ffis :: [FFIInfo] -- ffi blocks we allocated , bc_strs :: [RemotePtr ()] -- malloc'd strings , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not -- creating breakpoints, for some reason) } -- ToDo: we're not tracking strings that we malloc'd newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif) deriving (Show, NFData) instance Outputable CompiledByteCode where ppr CompiledByteCode{..} = ppr bc_bcos -- Not a real NFData instance, because ModBreaks contains some things -- we can't rnf seqCompiledByteCode :: CompiledByteCode -> () seqCompiledByteCode CompiledByteCode{..} = rnf bc_bcos `seq` rnf (nameEnvElts bc_itbls) `seq` rnf bc_ffis `seq` rnf bc_strs `seq` rnf (fmap seqModBreaks bc_breaks) type ItblEnv = NameEnv (Name, ItblPtr) -- We need the Name in the range so we know which -- elements to filter out when unloading a module newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable) deriving (Show, NFData) data UnlinkedBCO = UnlinkedBCO { unlinkedBCOName :: !Name, unlinkedBCOArity :: {-# UNPACK #-} !Int, unlinkedBCOInstrs :: !(UArray Int Word16), -- insns unlinkedBCOBitmap :: !(UArray Int Word64), -- bitmap unlinkedBCOLits :: !(SizedSeq BCONPtr), -- non-ptrs unlinkedBCOPtrs :: !(SizedSeq BCOPtr) -- ptrs } instance NFData UnlinkedBCO where rnf UnlinkedBCO{..} = rnf unlinkedBCOLits `seq` rnf unlinkedBCOPtrs data BCOPtr = BCOPtrName !Name | BCOPtrPrimOp !PrimOp | BCOPtrBCO !UnlinkedBCO | BCOPtrBreakArray -- a pointer to this module's BreakArray instance NFData BCOPtr where rnf (BCOPtrBCO bco) = rnf bco rnf x = x `seq` () data BCONPtr = BCONPtrWord {-# UNPACK #-} !Word | BCONPtrLbl !FastString | BCONPtrItbl !Name | BCONPtrStr !ByteString instance NFData BCONPtr where rnf x = x `seq` () -- | Information about a breakpoint that we know at code-generation time data CgBreakInfo = CgBreakInfo { cgb_vars :: [Maybe (Id,Word16)] , cgb_resty :: Type } -- See Note [Syncing breakpoint info] in compiler/main/InteractiveEval.hs -- Not a real NFData instance because we can't rnf Id or Type seqCgBreakInfo :: CgBreakInfo -> () seqCgBreakInfo CgBreakInfo{..} = rnf (map snd (catMaybes (cgb_vars))) `seq` seqType cgb_resty instance Outputable UnlinkedBCO where ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) = sep [text "BCO", ppr nm, text "with", ppr (sizeSS lits), text "lits", ppr (sizeSS ptrs), text "ptrs" ] instance Outputable CgBreakInfo where ppr info = text "CgBreakInfo" <+> parens (ppr (cgb_vars info) <+> ppr (cgb_resty info)) -- ----------------------------------------------------------------------------- -- Breakpoints -- | Breakpoint index type BreakIndex = Int -- | C CostCentre type data CCostCentre -- | All the information about the breakpoints for a module data ModBreaks = ModBreaks { modBreaks_flags :: ForeignRef BreakArray -- ^ The array of flags, one per breakpoint, -- indicating which breakpoints are enabled. , modBreaks_locs :: !(Array BreakIndex SrcSpan) -- ^ An array giving the source span of each breakpoint. , modBreaks_vars :: !(Array BreakIndex [OccName]) -- ^ An array giving the names of the free variables at each breakpoint. , modBreaks_decls :: !(Array BreakIndex [String]) -- ^ An array giving the names of the declarations enclosing each breakpoint. , modBreaks_ccs :: !(Array BreakIndex (RemotePtr CostCentre)) -- ^ Array pointing to cost centre for each breakpoint , modBreaks_breakInfo :: IntMap CgBreakInfo -- ^ info about each breakpoint from the bytecode generator } seqModBreaks :: ModBreaks -> () seqModBreaks ModBreaks{..} = rnf modBreaks_flags `seq` rnf modBreaks_locs `seq` rnf modBreaks_vars `seq` rnf modBreaks_decls `seq` rnf modBreaks_ccs `seq` rnf (fmap seqCgBreakInfo modBreaks_breakInfo) -- | Construct an empty ModBreaks emptyModBreaks :: ModBreaks emptyModBreaks = ModBreaks { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" -- ToDo: can we avoid this? , modBreaks_locs = array (0,-1) [] , modBreaks_vars = array (0,-1) [] , modBreaks_decls = array (0,-1) [] , modBreaks_ccs = array (0,-1) [] , modBreaks_breakInfo = IntMap.empty } ghc-lib-parser-8.10.2.20200808/compiler/types/Class.hs0000644000000000000000000003100313713635745020063 0ustar0000000000000000-- (c) The University of Glasgow 2006 -- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -- -- The @Class@ datatype {-# LANGUAGE CPP #-} module Class ( Class, ClassOpItem, ClassATItem(..), ClassMinimalDef, DefMethInfo, pprDefMethInfo, FunDep, pprFundeps, pprFunDep, mkClass, mkAbstractClass, classTyVars, classArity, classKey, className, classATs, classATItems, classTyCon, classMethods, classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, classHasFds, isAbstractClass, ) where #include "GhclibHsVersions.h" import GhcPrelude import {-# SOURCE #-} TyCon ( TyCon ) import {-# SOURCE #-} TyCoRep ( Type, PredType ) import {-# SOURCE #-} TyCoPpr ( pprType ) import Var import Name import BasicTypes import Unique import Util import SrcLoc import Outputable import BooleanFormula (BooleanFormula, mkTrue) import qualified Data.Data as Data {- ************************************************************************ * * \subsection[Class-basic]{@Class@: basic definition} * * ************************************************************************ A @Class@ corresponds to a Greek kappa in the static semantics: -} data Class = Class { classTyCon :: TyCon, -- The data type constructor for -- dictionaries of this class -- See Note [ATyCon for classes] in TyCoRep className :: Name, -- Just the cached name of the TyCon classKey :: Unique, -- Cached unique of TyCon classTyVars :: [TyVar], -- The class kind and type variables; -- identical to those of the TyCon -- If you want visibility info, look at the classTyCon -- This field is redundant because it's duplicated in the -- classTyCon, but classTyVars is used quite often, so maybe -- it's a bit faster to cache it here classFunDeps :: [FunDep TyVar], -- The functional dependencies classBody :: ClassBody -- Superclasses, ATs, methods } -- | e.g. -- -- > class C a b c | a b -> c, a c -> b where... -- -- Here fun-deps are [([a,b],[c]), ([a,c],[b])] -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'', -- For details on above see note [Api annotations] in ApiAnnotation type FunDep a = ([a],[a]) type ClassOpItem = (Id, DefMethInfo) -- Selector function; contains unfolding -- Default-method info type DefMethInfo = Maybe (Name, DefMethSpec Type) -- Nothing No default method -- Just ($dm, VanillaDM) A polymorphic default method, name $dm -- Just ($gm, GenericDM ty) A generic default method, name $gm, type ty -- The generic dm type is *not* quantified -- over the class variables; ie has the -- class variables free data ClassATItem = ATI TyCon -- See Note [Associated type tyvar names] (Maybe (Type, SrcSpan)) -- Default associated type (if any) from this template -- Note [Associated type defaults] type ClassMinimalDef = BooleanFormula Name -- Required methods data ClassBody = AbstractClass | ConcreteClass { -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b) -- We need value-level selectors for both the dictionary -- superclasses and the equality superclasses cls_sc_theta :: [PredType], -- Immediate superclasses, cls_sc_sel_ids :: [Id], -- Selector functions to extract the -- superclasses from a -- dictionary of this class -- Associated types cls_ats :: [ClassATItem], -- Associated type families -- Class operations (methods, not superclasses) cls_ops :: [ClassOpItem], -- Ordered by tag -- Minimal complete definition cls_min_def :: ClassMinimalDef } -- TODO: maybe super classes should be allowed in abstract class definitions classMinimalDef :: Class -> ClassMinimalDef classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction {- Note [Associated type defaults] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The following is an example of associated type defaults: class C a where data D a r type F x a b :: * type F p q r = (p,q)->r -- Default Note that * The TyCons for the associated types *share type variables* with the class, so that we can tell which argument positions should be instantiated in an instance decl. (The first for 'D', the second for 'F'.) * We can have default definitions only for *type* families, not data families * In the default decl, the "patterns" should all be type variables, but (in the source language) they don't need to be the same as in the 'type' decl signature or the class. It's more like a free-standing 'type instance' declaration. * HOWEVER, in the internal ClassATItem we rename the RHS to match the tyConTyVars of the family TyCon. So in the example above we'd get a ClassATItem of ATI F ((x,a) -> b) So the tyConTyVars of the family TyCon bind the free vars of the default Type rhs The @mkClass@ function fills in the indirect superclasses. The SrcSpan is for the entire original declaration. -} mkClass :: Name -> [TyVar] -> [FunDep TyVar] -> [PredType] -> [Id] -> [ClassATItem] -> [ClassOpItem] -> ClassMinimalDef -> TyCon -> Class mkClass cls_name tyvars fds super_classes superdict_sels at_stuff op_stuff mindef tycon = Class { classKey = nameUnique cls_name, className = cls_name, -- NB: tyConName tycon = cls_name, -- But it takes a module loop to assert it here classTyVars = tyvars, classFunDeps = fds, classBody = ConcreteClass { cls_sc_theta = super_classes, cls_sc_sel_ids = superdict_sels, cls_ats = at_stuff, cls_ops = op_stuff, cls_min_def = mindef }, classTyCon = tycon } mkAbstractClass :: Name -> [TyVar] -> [FunDep TyVar] -> TyCon -> Class mkAbstractClass cls_name tyvars fds tycon = Class { classKey = nameUnique cls_name, className = cls_name, -- NB: tyConName tycon = cls_name, -- But it takes a module loop to assert it here classTyVars = tyvars, classFunDeps = fds, classBody = AbstractClass, classTyCon = tycon } {- Note [Associated type tyvar names] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The TyCon of an associated type should use the same variable names as its parent class. Thus class C a b where type F b x a :: * We make F use the same Name for 'a' as C does, and similary 'b'. The reason for this is when checking instances it's easier to match them up, to ensure they match. Eg instance C Int [d] where type F [d] x Int = .... we should make sure that the first and third args match the instance header. Having the same variables for class and tycon is also used in checkValidRoles (in TcTyClsDecls) when checking a class's roles. ************************************************************************ * * \subsection[Class-selectors]{@Class@: simple selectors} * * ************************************************************************ The rest of these functions are just simple selectors. -} classArity :: Class -> Arity classArity clas = length (classTyVars clas) -- Could memoise this classAllSelIds :: Class -> [Id] -- Both superclass-dictionary and method selectors classAllSelIds c@(Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) = sc_sels ++ classMethods c classAllSelIds c = ASSERT( null (classMethods c) ) [] classSCSelIds :: Class -> [Id] -- Both superclass-dictionary and method selectors classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) = sc_sels classSCSelIds c = ASSERT( null (classMethods c) ) [] classSCSelId :: Class -> Int -> Id -- Get the n'th superclass selector Id -- where n is 0-indexed, and counts -- *all* superclasses including equalities classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n = ASSERT( n >= 0 && lengthExceeds sc_sels n ) sc_sels !! n classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n) classMethods :: Class -> [Id] classMethods (Class { classBody = ConcreteClass { cls_ops = op_stuff } }) = [op_sel | (op_sel, _) <- op_stuff] classMethods _ = [] classOpItems :: Class -> [ClassOpItem] classOpItems (Class { classBody = ConcreteClass { cls_ops = op_stuff }}) = op_stuff classOpItems _ = [] classATs :: Class -> [TyCon] classATs (Class { classBody = ConcreteClass { cls_ats = at_stuff } }) = [tc | ATI tc _ <- at_stuff] classATs _ = [] classATItems :: Class -> [ClassATItem] classATItems (Class { classBody = ConcreteClass { cls_ats = at_stuff }}) = at_stuff classATItems _ = [] classSCTheta :: Class -> [PredType] classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }}) = theta_stuff classSCTheta _ = [] classTvsFds :: Class -> ([TyVar], [FunDep TyVar]) classTvsFds c = (classTyVars c, classFunDeps c) classHasFds :: Class -> Bool classHasFds (Class { classFunDeps = fds }) = not (null fds) classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem]) classBigSig (Class {classTyVars = tyvars, classBody = AbstractClass}) = (tyvars, [], [], []) classBigSig (Class {classTyVars = tyvars, classBody = ConcreteClass { cls_sc_theta = sc_theta, cls_sc_sel_ids = sc_sels, cls_ops = op_stuff }}) = (tyvars, sc_theta, sc_sels, op_stuff) classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem]) classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, classBody = AbstractClass}) = (tyvars, fundeps, [], [], [], []) classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, classBody = ConcreteClass { cls_sc_theta = sc_theta, cls_sc_sel_ids = sc_sels, cls_ats = ats, cls_ops = op_stuff }}) = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff) isAbstractClass :: Class -> Bool isAbstractClass Class{ classBody = AbstractClass } = True isAbstractClass _ = False {- ************************************************************************ * * \subsection[Class-instances]{Instance declarations for @Class@} * * ************************************************************************ We compare @Classes@ by their keys (which include @Uniques@). -} instance Eq Class where c1 == c2 = classKey c1 == classKey c2 c1 /= c2 = classKey c1 /= classKey c2 instance Uniquable Class where getUnique c = classKey c instance NamedThing Class where getName clas = className clas instance Outputable Class where ppr c = ppr (getName c) pprDefMethInfo :: DefMethInfo -> SDoc pprDefMethInfo Nothing = empty -- No default method pprDefMethInfo (Just (n, VanillaDM)) = text "Default method" <+> ppr n pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method" <+> ppr n <+> dcolon <+> pprType ty pprFundeps :: Outputable a => [FunDep a] -> SDoc pprFundeps [] = empty pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds)) pprFunDep :: Outputable a => FunDep a -> SDoc pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs] instance Data.Data Class where -- don't traverse? toConstr _ = abstractConstr "Class" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Class" ghc-lib-parser-8.10.2.20200808/compiler/main/CliOption.hs0000644000000000000000000000174713713635745020512 0ustar0000000000000000module CliOption ( Option (..) , showOpt ) where import GhcPrelude -- ----------------------------------------------------------------------------- -- Command-line options -- | When invoking external tools as part of the compilation pipeline, we -- pass these a sequence of options on the command-line. Rather than -- just using a list of Strings, we use a type that allows us to distinguish -- between filepaths and 'other stuff'. The reason for this is that -- this type gives us a handle on transforming filenames, and filenames only, -- to whatever format they're expected to be on a particular platform. data Option = FileOption -- an entry that _contains_ filename(s) / filepaths. String -- a non-filepath prefix that shouldn't be -- transformed (e.g., "/out=") String -- the filepath/filename portion | Option String deriving ( Eq ) showOpt :: Option -> String showOpt (FileOption pre f) = pre ++ f showOpt (Option s) = s ghc-lib-parser-8.10.2.20200808/compiler/main/CmdLineParser.hs0000644000000000000000000002725713713635745021306 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} ------------------------------------------------------------------------------- -- -- | Command-line parser -- -- This is an abstract command-line parser used by DynFlags. -- -- (c) The University of Glasgow 2005 -- ------------------------------------------------------------------------------- module CmdLineParser ( processArgs, OptKind(..), GhcFlagMode(..), CmdLineP(..), getCmdLineState, putCmdLineState, Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, errorsToGhcException, Err(..), Warn(..), WarnReason(..), EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM, deprecate ) where #include "GhclibHsVersions.h" import GhcPrelude import Util import Outputable import Panic import Bag import SrcLoc import Json import Data.Function import Data.List import Control.Monad (liftM, ap) -------------------------------------------------------- -- The Flag and OptKind types -------------------------------------------------------- data Flag m = Flag { flagName :: String, -- Flag, without the leading "-" flagOptKind :: OptKind m, -- What to do if we see it flagGhcMode :: GhcFlagMode -- Which modes this flag affects } defFlag :: String -> OptKind m -> Flag m defFlag name optKind = Flag name optKind AllModes defGhcFlag :: String -> OptKind m -> Flag m defGhcFlag name optKind = Flag name optKind OnlyGhc defGhciFlag :: String -> OptKind m -> Flag m defGhciFlag name optKind = Flag name optKind OnlyGhci defHiddenFlag :: String -> OptKind m -> Flag m defHiddenFlag name optKind = Flag name optKind HiddenFlag -- | GHC flag modes describing when a flag has an effect. data GhcFlagMode = OnlyGhc -- ^ The flag only affects the non-interactive GHC | OnlyGhci -- ^ The flag only affects the interactive GHC | AllModes -- ^ The flag affects multiple ghc modes | HiddenFlag -- ^ This flag should not be seen in cli completion data OptKind m -- Suppose the flag is -f = NoArg (EwM m ()) -- -f all by itself | HasArg (String -> EwM m ()) -- -farg or -f arg | SepArg (String -> EwM m ()) -- -f arg | Prefix (String -> EwM m ()) -- -farg | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional) | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn -------------------------------------------------------- -- The EwM monad -------------------------------------------------------- -- | Used when filtering warnings: if a reason is given -- it can be filtered out when displaying. data WarnReason = NoReason | ReasonDeprecatedFlag | ReasonUnrecognisedFlag deriving (Eq, Show) instance Outputable WarnReason where ppr = text . show instance ToJson WarnReason where json NoReason = JSNull json reason = JSString $ show reason -- | A command-line error message newtype Err = Err { errMsg :: Located String } -- | A command-line warning message and the reason it arose data Warn = Warn { warnReason :: WarnReason, warnMsg :: Located String } type Errs = Bag Err type Warns = Bag Warn -- EwM ("errors and warnings monad") is a monad -- transformer for m that adds an (err, warn) state newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg -> Errs -> Warns -> m (Errs, Warns, a) } instance Monad m => Functor (EwM m) where fmap = liftM instance Monad m => Applicative (EwM m) where pure v = EwM (\_ e w -> return (e, w, v)) (<*>) = ap instance Monad m => Monad (EwM m) where (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w unEwM (k r) l e' w') runEwM :: EwM m a -> m (Errs, Warns, a) runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag setArg :: Located String -> EwM m () -> EwM m () setArg l (EwM f) = EwM (\_ es ws -> f l es ws) addErr :: Monad m => String -> EwM m () addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ())) addWarn :: Monad m => String -> EwM m () addWarn = addFlagWarn NoReason addFlagWarn :: Monad m => WarnReason -> String -> EwM m () addFlagWarn reason msg = EwM $ (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ())) deprecate :: Monad m => String -> EwM m () deprecate s = do arg <- getArg addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s) getArg :: Monad m => EwM m String getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) getCurLoc :: Monad m => EwM m SrcSpan getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc)) liftEwM :: Monad m => m a -> EwM m a liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) -------------------------------------------------------- -- A state monad for use in the command-line parser -------------------------------------------------------- -- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m) newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) } deriving (Functor) instance Applicative (CmdLineP s) where pure a = CmdLineP $ \s -> (a, s) (<*>) = ap instance Monad (CmdLineP s) where m >>= k = CmdLineP $ \s -> let (a, s') = runCmdLine m s in runCmdLine (k a) s' getCmdLineState :: CmdLineP s s getCmdLineState = CmdLineP $ \s -> (s,s) putCmdLineState :: s -> CmdLineP s () putCmdLineState s = CmdLineP $ \_ -> ((),s) -------------------------------------------------------- -- Processing arguments -------------------------------------------------------- processArgs :: Monad m => [Flag m] -- cmdline parser spec -> [Located String] -- args -> m ( [Located String], -- spare args [Err], -- errors [Warn] ) -- warnings processArgs spec args = do (errs, warns, spare) <- runEwM action return (spare, bagToList errs, bagToList warns) where action = process args [] -- process :: [Located String] -> [Located String] -> EwM m [Located String] process [] spare = return (reverse spare) process (locArg@(L _ ('-' : arg)) : args) spare = case findArg spec arg of Just (rest, opt_kind) -> case processOneArg opt_kind rest arg args of Left err -> let b = process args spare in (setArg locArg $ addErr err) >> b Right (action,rest) -> let b = process rest spare in (setArg locArg $ action) >> b Nothing -> process args (locArg : spare) process (arg : args) spare = process args (arg : spare) processOneArg :: OptKind m -> String -> String -> [Located String] -> Either String (EwM m (), [Located String]) processOneArg opt_kind rest arg args = let dash_arg = '-' : arg rest_no_eq = dropEq rest in case opt_kind of NoArg a -> ASSERT(null rest) Right (a, args) HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args) | otherwise -> case args of [] -> missingArgErr dash_arg (L _ arg1:args1) -> Right (f arg1, args1) -- See #9776 SepArg f -> case args of [] -> missingArgErr dash_arg (L _ arg1:args1) -> Right (f arg1, args1) -- See #12625 Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args) | otherwise -> missingArgErr dash_arg PassFlag f | notNull rest -> unknownFlagErr dash_arg | otherwise -> Right (f dash_arg, args) OptIntSuffix f | null rest -> Right (f Nothing, args) | Just n <- parseInt rest_no_eq -> Right (f (Just n), args) | otherwise -> Left ("malformed integer argument in " ++ dash_arg) IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args) | otherwise -> Left ("malformed integer argument in " ++ dash_arg) FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args) | otherwise -> Left ("malformed float argument in " ++ dash_arg) OptPrefix f -> Right (f rest_no_eq, args) AnySuffix f -> Right (f dash_arg, args) findArg :: [Flag m] -> String -> Maybe (String, OptKind m) findArg spec arg = case sortBy (compare `on` (length . fst)) -- prefer longest matching flag [ (removeSpaces rest, optKind) | flag <- spec, let optKind = flagOptKind flag, Just rest <- [stripPrefix (flagName flag) arg], arg_ok optKind rest arg ] of [] -> Nothing (one:_) -> Just one arg_ok :: OptKind t -> [Char] -> String -> Bool arg_ok (NoArg _) rest _ = null rest arg_ok (HasArg _) _ _ = True arg_ok (SepArg _) rest _ = null rest arg_ok (Prefix _) _ _ = True -- Missing argument checked for in processOneArg t -- to improve error message (#12625) arg_ok (OptIntSuffix _) _ _ = True arg_ok (IntSuffix _) _ _ = True arg_ok (FloatSuffix _) _ _ = True arg_ok (OptPrefix _) _ _ = True arg_ok (PassFlag _) rest _ = null rest arg_ok (AnySuffix _) _ _ = True -- | Parse an Int -- -- Looks for "433" or "=342", with no trailing gubbins -- * n or =n => Just n -- * gibberish => Nothing parseInt :: String -> Maybe Int parseInt s = case reads s of ((n,""):_) -> Just n _ -> Nothing parseFloat :: String -> Maybe Float parseFloat s = case reads s of ((n,""):_) -> Just n _ -> Nothing -- | Discards a leading equals sign dropEq :: String -> String dropEq ('=' : s) = s dropEq s = s unknownFlagErr :: String -> Either String a unknownFlagErr f = Left ("unrecognised flag: " ++ f) missingArgErr :: String -> Either String a missingArgErr f = Left ("missing argument for flag: " ++ f) -------------------------------------------------------- -- Utils -------------------------------------------------------- -- See Note [Handling errors when parsing flags] errorsToGhcException :: [(String, -- Location String)] -- Error -> GhcException errorsToGhcException errs = UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ] {- Note [Handling errors when parsing commandline flags] Parsing of static and mode flags happens before any session is started, i.e., before the first call to 'GHC.withGhc'. Therefore, to report errors for invalid usage of these two types of flags, we can not call any function that needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags is not set either). So we always print "on the commandline" as the location, which is true except for Api users, which is probably ok. When reporting errors for invalid usage of dynamic flags we /can/ make use of DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull. Before, we called unsafeGlobalDynFlags when an invalid (combination of) flag(s) was given on the commandline, resulting in panics (#9963). -} ghc-lib-parser-8.10.2.20200808/compiler/cmm/CmmType.hs0000644000000000000000000003430313713635744020011 0ustar0000000000000000module CmmType ( CmmType -- Abstract , b8, b16, b32, b64, b128, b256, b512, f32, f64, bWord, bHalfWord, gcWord , cInt , cmmBits, cmmFloat , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood , isFloatType, isGcPtrType, isBitsType , isWord32, isWord64, isFloat64, isFloat32 , Width(..) , widthInBits, widthInBytes, widthInLog, widthFromBytes , wordWidth, halfWordWidth, cIntWidth , halfWordMask , narrowU, narrowS , rEP_CostCentreStack_mem_alloc , rEP_CostCentreStack_scc_count , rEP_StgEntCounter_allocs , rEP_StgEntCounter_allocd , ForeignHint(..) , Length , vec, vec2, vec4, vec8, vec16 , vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 , cmmVec , vecLength, vecElemType , isVecType ) where import GhcPrelude import DynFlags import FastString import Outputable import Data.Word import Data.Int ----------------------------------------------------------------------------- -- CmmType ----------------------------------------------------------------------------- -- NOTE: CmmType is an abstract type, not exported from this -- module so you can easily change its representation -- -- However Width is exported in a concrete way, -- and is used extensively in pattern-matching data CmmType -- The important one! = CmmType CmmCat Width data CmmCat -- "Category" (not exported) = GcPtrCat -- GC pointer | BitsCat -- Non-pointer | FloatCat -- Float | VecCat Length CmmCat -- Vector deriving( Eq ) -- See Note [Signed vs unsigned] at the end instance Outputable CmmType where ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid) instance Outputable CmmCat where ppr FloatCat = text "F" ppr GcPtrCat = text "P" ppr BitsCat = text "I" ppr (VecCat n cat) = ppr cat <> text "x" <> ppr n <> text "V" -- Why is CmmType stratified? For native code generation, -- most of the time you just want to know what sort of register -- to put the thing in, and for this you need to know how -- many bits thing has, and whether it goes in a floating-point -- register. By contrast, the distinction between GcPtr and -- GcNonPtr is of interest to only a few parts of the code generator. -------- Equality on CmmType -------------- -- CmmType is *not* an instance of Eq; sometimes we care about the -- Gc/NonGc distinction, and sometimes we don't -- So we use an explicit function to force you to think about it cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2 cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool -- This equality is temporary; used in CmmLint -- but the RTS files are not yet well-typed wrt pointers cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2) = c1 `weak_eq` c2 && w1==w2 where weak_eq :: CmmCat -> CmmCat -> Bool FloatCat `weak_eq` FloatCat = True FloatCat `weak_eq` _other = False _other `weak_eq` FloatCat = False (VecCat l1 cat1) `weak_eq` (VecCat l2 cat2) = l1 == l2 && cat1 `weak_eq` cat2 (VecCat {}) `weak_eq` _other = False _other `weak_eq` (VecCat {}) = False _word1 `weak_eq` _word2 = True -- Ignores GcPtr --- Simple operations on CmmType ----- typeWidth :: CmmType -> Width typeWidth (CmmType _ w) = w cmmBits, cmmFloat :: Width -> CmmType cmmBits = CmmType BitsCat cmmFloat = CmmType FloatCat -------- Common CmmTypes ------------ -- Floats and words of specific widths b8, b16, b32, b64, b128, b256, b512, f32, f64 :: CmmType b8 = cmmBits W8 b16 = cmmBits W16 b32 = cmmBits W32 b64 = cmmBits W64 b128 = cmmBits W128 b256 = cmmBits W256 b512 = cmmBits W512 f32 = cmmFloat W32 f64 = cmmFloat W64 -- CmmTypes of native word widths bWord :: DynFlags -> CmmType bWord dflags = cmmBits (wordWidth dflags) bHalfWord :: DynFlags -> CmmType bHalfWord dflags = cmmBits (halfWordWidth dflags) gcWord :: DynFlags -> CmmType gcWord dflags = CmmType GcPtrCat (wordWidth dflags) cInt :: DynFlags -> CmmType cInt dflags = cmmBits (cIntWidth dflags) ------------ Predicates ---------------- isFloatType, isGcPtrType, isBitsType :: CmmType -> Bool isFloatType (CmmType FloatCat _) = True isFloatType _other = False isGcPtrType (CmmType GcPtrCat _) = True isGcPtrType _other = False isBitsType (CmmType BitsCat _) = True isBitsType _ = False isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool -- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise) -- isFloat32 and 64 are obvious isWord64 (CmmType BitsCat W64) = True isWord64 (CmmType GcPtrCat W64) = True isWord64 _other = False isWord32 (CmmType BitsCat W32) = True isWord32 (CmmType GcPtrCat W32) = True isWord32 _other = False isFloat32 (CmmType FloatCat W32) = True isFloat32 _other = False isFloat64 (CmmType FloatCat W64) = True isFloat64 _other = False ----------------------------------------------------------------------------- -- Width ----------------------------------------------------------------------------- data Width = W8 | W16 | W32 | W64 | W128 | W256 | W512 deriving (Eq, Ord, Show) instance Outputable Width where ppr rep = ptext (mrStr rep) mrStr :: Width -> PtrString mrStr W8 = sLit("W8") mrStr W16 = sLit("W16") mrStr W32 = sLit("W32") mrStr W64 = sLit("W64") mrStr W128 = sLit("W128") mrStr W256 = sLit("W256") mrStr W512 = sLit("W512") -------- Common Widths ------------ wordWidth :: DynFlags -> Width wordWidth dflags | wORD_SIZE dflags == 4 = W32 | wORD_SIZE dflags == 8 = W64 | otherwise = panic "MachOp.wordRep: Unknown word size" halfWordWidth :: DynFlags -> Width halfWordWidth dflags | wORD_SIZE dflags == 4 = W16 | wORD_SIZE dflags == 8 = W32 | otherwise = panic "MachOp.halfWordRep: Unknown word size" halfWordMask :: DynFlags -> Integer halfWordMask dflags | wORD_SIZE dflags == 4 = 0xFFFF | wORD_SIZE dflags == 8 = 0xFFFFFFFF | otherwise = panic "MachOp.halfWordMask: Unknown word size" -- cIntRep is the Width for a C-language 'int' cIntWidth :: DynFlags -> Width cIntWidth dflags = case cINT_SIZE dflags of 4 -> W32 8 -> W64 s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s) widthInBits :: Width -> Int widthInBits W8 = 8 widthInBits W16 = 16 widthInBits W32 = 32 widthInBits W64 = 64 widthInBits W128 = 128 widthInBits W256 = 256 widthInBits W512 = 512 widthInBytes :: Width -> Int widthInBytes W8 = 1 widthInBytes W16 = 2 widthInBytes W32 = 4 widthInBytes W64 = 8 widthInBytes W128 = 16 widthInBytes W256 = 32 widthInBytes W512 = 64 widthFromBytes :: Int -> Width widthFromBytes 1 = W8 widthFromBytes 2 = W16 widthFromBytes 4 = W32 widthFromBytes 8 = W64 widthFromBytes 16 = W128 widthFromBytes 32 = W256 widthFromBytes 64 = W512 widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n) -- log_2 of the width in bytes, useful for generating shifts. widthInLog :: Width -> Int widthInLog W8 = 0 widthInLog W16 = 1 widthInLog W32 = 2 widthInLog W64 = 3 widthInLog W128 = 4 widthInLog W256 = 5 widthInLog W512 = 6 -- widening / narrowing narrowU :: Width -> Integer -> Integer narrowU W8 x = fromIntegral (fromIntegral x :: Word8) narrowU W16 x = fromIntegral (fromIntegral x :: Word16) narrowU W32 x = fromIntegral (fromIntegral x :: Word32) narrowU W64 x = fromIntegral (fromIntegral x :: Word64) narrowU _ _ = panic "narrowTo" narrowS :: Width -> Integer -> Integer narrowS W8 x = fromIntegral (fromIntegral x :: Int8) narrowS W16 x = fromIntegral (fromIntegral x :: Int16) narrowS W32 x = fromIntegral (fromIntegral x :: Int32) narrowS W64 x = fromIntegral (fromIntegral x :: Int64) narrowS _ _ = panic "narrowTo" ----------------------------------------------------------------------------- -- SIMD ----------------------------------------------------------------------------- type Length = Int vec :: Length -> CmmType -> CmmType vec l (CmmType cat w) = CmmType (VecCat l cat) vecw where vecw :: Width vecw = widthFromBytes (l*widthInBytes w) vec2, vec4, vec8, vec16 :: CmmType -> CmmType vec2 = vec 2 vec4 = vec 4 vec8 = vec 8 vec16 = vec 16 vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 :: CmmType vec2f64 = vec 2 f64 vec2b64 = vec 2 b64 vec4f32 = vec 4 f32 vec4b32 = vec 4 b32 vec8b16 = vec 8 b16 vec16b8 = vec 16 b8 cmmVec :: Int -> CmmType -> CmmType cmmVec n (CmmType cat w) = CmmType (VecCat n cat) (widthFromBytes (n*widthInBytes w)) vecLength :: CmmType -> Length vecLength (CmmType (VecCat l _) _) = l vecLength _ = panic "vecLength: not a vector" vecElemType :: CmmType -> CmmType vecElemType (CmmType (VecCat l cat) w) = CmmType cat scalw where scalw :: Width scalw = widthFromBytes (widthInBytes w `div` l) vecElemType _ = panic "vecElemType: not a vector" isVecType :: CmmType -> Bool isVecType (CmmType (VecCat {}) _) = True isVecType _ = False ------------------------------------------------------------------------- -- Hints -- Hints are extra type information we attach to the arguments and -- results of a foreign call, where more type information is sometimes -- needed by the ABI to make the correct kind of call. data ForeignHint = NoHint | AddrHint | SignedHint deriving( Eq ) -- Used to give extra per-argument or per-result -- information needed by foreign calling conventions ------------------------------------------------------------------------- -- These don't really belong here, but I don't know where is best to -- put them. rEP_CostCentreStack_mem_alloc :: DynFlags -> CmmType rEP_CostCentreStack_mem_alloc dflags = cmmBits (widthFromBytes (pc_REP_CostCentreStack_mem_alloc pc)) where pc = platformConstants dflags rEP_CostCentreStack_scc_count :: DynFlags -> CmmType rEP_CostCentreStack_scc_count dflags = cmmBits (widthFromBytes (pc_REP_CostCentreStack_scc_count pc)) where pc = platformConstants dflags rEP_StgEntCounter_allocs :: DynFlags -> CmmType rEP_StgEntCounter_allocs dflags = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocs pc)) where pc = platformConstants dflags rEP_StgEntCounter_allocd :: DynFlags -> CmmType rEP_StgEntCounter_allocd dflags = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd pc)) where pc = platformConstants dflags ------------------------------------------------------------------------- {- Note [Signed vs unsigned] ~~~~~~~~~~~~~~~~~~~~~~~~~ Should a CmmType include a signed vs. unsigned distinction? This is very much like a "hint" in C-- terminology: it isn't necessary in order to generate correct code, but it might be useful in that the compiler can generate better code if it has access to higher-level hints about data. This is important at call boundaries, because the definition of a function is not visible at all of its call sites, so the compiler cannot infer the hints. Here in Cmm, we're taking a slightly different approach. We include the int vs. float hint in the CmmType, because (a) the majority of platforms have a strong distinction between float and int registers, and (b) we don't want to do any heavyweight hint-inference in the native code backend in order to get good code. We're treating the hint more like a type: our Cmm is always completely consistent with respect to hints. All coercions between float and int are explicit. What about the signed vs. unsigned hint? This information might be useful if we want to keep sub-word-sized values in word-size registers, which we must do if we only have word-sized registers. On such a system, there are two straightforward conventions for representing sub-word-sized values: (a) Leave the upper bits undefined. Comparison operations must sign- or zero-extend both operands before comparing them, depending on whether the comparison is signed or unsigned. (b) Always keep the values sign- or zero-extended as appropriate. Arithmetic operations must narrow the result to the appropriate size. A clever compiler might not use either (a) or (b) exclusively, instead it would attempt to minimize the coercions by analysis: the same kind of analysis that propagates hints around. In Cmm we don't want to have to do this, so we plump for having richer types and keeping the type information consistent. If signed/unsigned hints are missing from CmmType, then the only choice we have is (a), because we don't know whether the result of an operation should be sign- or zero-extended. Many architectures have extending load operations, which work well with (b). To make use of them with (a), you need to know whether the value is going to be sign- or zero-extended by an enclosing comparison (for example), which involves knowing above the context. This is doable but more complex. Further complicating the issue is foreign calls: a foreign calling convention can specify that signed 8-bit quantities are passed as sign-extended 32 bit quantities, for example (this is the case on the PowerPC). So we *do* need sign information on foreign call arguments. Pros for adding signed vs. unsigned to CmmType: - It would let us use convention (b) above, and get easier code generation for extending loads. - Less information required on foreign calls. - MachOp type would be simpler Cons: - More complexity - What is the CmmType for a VanillaReg? Currently it is always wordRep, but now we have to decide whether it is signed or unsigned. The same VanillaReg can thus have different CmmType in different parts of the program. - Extra coercions cluttering up expressions. Currently for GHC, the foreign call point is moot, because we do our own promotion of sub-word-sized values to word-sized values. The Int8 type is represented by an Int# which is kept sign-extended at all times (this is slightly naughty, because we're making assumptions about the C calling convention rather early on in the compiler). However, given this, the cons outweigh the pros. -} ghc-lib-parser-8.10.2.20200808/compiler/types/CoAxiom.hs0000644000000000000000000005061613713635745020370 0ustar0000000000000000-- (c) The University of Glasgow 2012 {-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, GADTs, KindSignatures, ScopedTypeVariables, StandaloneDeriving, RoleAnnotations #-} -- | Module for coercion axioms, used to represent type family instances -- and newtypes module CoAxiom ( BranchFlag, Branched, Unbranched, BranchIndex, Branches(..), manyBranches, unbranched, fromBranches, numBranches, mapAccumBranches, CoAxiom(..), CoAxBranch(..), toBranchedAxiom, toUnbranchedAxiom, coAxiomName, coAxiomArity, coAxiomBranches, coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats, coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole, coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars, coAxBranchRoles, coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, placeHolderIncomps, Role(..), fsFromRole, CoAxiomRule(..), TypeEqn, BuiltInSynFamily(..), trivialBuiltInFamily ) where import GhcPrelude import {-# SOURCE #-} TyCoRep ( Type ) import {-# SOURCE #-} TyCoPpr ( pprType ) import {-# SOURCE #-} TyCon ( TyCon ) import Outputable import FastString import Name import Unique import Var import Util import Binary import Pair import BasicTypes import Data.Typeable ( Typeable ) import SrcLoc import qualified Data.Data as Data import Data.Array import Data.List ( mapAccumL ) #include "GhclibHsVersions.h" {- Note [Coercion axiom branches] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In order to allow closed type families, an axiom needs to contain an ordered list of alternatives, called branches. The kind of the coercion built from an axiom is determined by which index is used when building the coercion from the axiom. For example, consider the axiom derived from the following declaration: type family F a where F [Int] = Bool F [a] = Double F (a b) = Char This will give rise to this axiom: axF :: { F [Int] ~ Bool ; forall (a :: *). F [a] ~ Double ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char } The axiom is used with the AxiomInstCo constructor of Coercion. If we wish to have a coercion showing that F (Maybe Int) ~ Char, it will look like axF[2] <*> :: F (Maybe Int) ~ Char -- or, written using concrete-ish syntax -- AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int] Note that the index is 0-based. For type-checking, it is also necessary to check that no previous pattern can unify with the supplied arguments. After all, it is possible that some of the type arguments are lambda-bound type variables whose instantiation may cause an earlier match among the branches. We wish to prohibit this behavior, so the type checker rules out the choice of a branch where a previous branch can unify. See also [Apartness] in FamInstEnv.hs. For example, the following is malformed, where 'a' is a lambda-bound type variable: axF[2] <*> :: F (a Bool) ~ Char Why? Because a might be instantiated with [], meaning that branch 1 should apply, not branch 2. This is a vital consistency check; without it, we could derive Int ~ Bool, and that is a Bad Thing. Note [Branched axioms] ~~~~~~~~~~~~~~~~~~~~~~ Although a CoAxiom has the capacity to store many branches, in certain cases, we want only one. These cases are in data/newtype family instances, newtype coercions, and type family instances. Furthermore, these unbranched axioms are used in a variety of places throughout GHC, and it would difficult to generalize all of that code to deal with branched axioms, especially when the code can be sure of the fact that an axiom is indeed a singleton. At the same time, it seems dangerous to assume singlehood in various places through GHC. The solution to this is to label a CoAxiom with a phantom type variable declaring whether it is known to be a singleton or not. The branches are stored using a special datatype, declared below, that ensures that the type variable is accurate. ************************************************************************ * * Branches * * ************************************************************************ -} type BranchIndex = Int -- The index of the branch in the list of branches -- Counting from zero -- promoted data type data BranchFlag = Branched | Unbranched type Branched = 'Branched type Unbranched = 'Unbranched -- By using type synonyms for the promoted constructors, we avoid needing -- DataKinds and the promotion quote in client modules. This also means that -- we don't need to export the term-level constructors, which should never be used. newtype Branches (br :: BranchFlag) = MkBranches { unMkBranches :: Array BranchIndex CoAxBranch } type role Branches nominal manyBranches :: [CoAxBranch] -> Branches Branched manyBranches brs = ASSERT( snd bnds >= fst bnds ) MkBranches (listArray bnds brs) where bnds = (0, length brs - 1) unbranched :: CoAxBranch -> Branches Unbranched unbranched br = MkBranches (listArray (0, 0) [br]) toBranched :: Branches br -> Branches Branched toBranched = MkBranches . unMkBranches toUnbranched :: Branches br -> Branches Unbranched toUnbranched (MkBranches arr) = ASSERT( bounds arr == (0,0) ) MkBranches arr fromBranches :: Branches br -> [CoAxBranch] fromBranches = elems . unMkBranches branchesNth :: Branches br -> BranchIndex -> CoAxBranch branchesNth (MkBranches arr) n = arr ! n numBranches :: Branches br -> Int numBranches (MkBranches arr) = snd (bounds arr) + 1 -- | The @[CoAxBranch]@ passed into the mapping function is a list of -- all previous branches, reversed mapAccumBranches :: ([CoAxBranch] -> CoAxBranch -> CoAxBranch) -> Branches br -> Branches br mapAccumBranches f (MkBranches arr) = MkBranches (listArray (bounds arr) (snd $ mapAccumL go [] (elems arr))) where go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) go prev_branches cur_branch = ( cur_branch : prev_branches , f prev_branches cur_branch ) {- ************************************************************************ * * Coercion axioms * * ************************************************************************ Note [Storing compatibility] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ During axiom application, we need to be aware of which branches are compatible with which others. The full explanation is in Note [Compatibility] in FamInstEnv. (The code is placed there to avoid a dependency from CoAxiom on the unification algorithm.) Although we could theoretically compute compatibility on the fly, this is silly, so we store it in a CoAxiom. Specifically, each branch refers to all other branches with which it is incompatible. This list might well be empty, and it will always be for the first branch of any axiom. CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk stored in cab_incomps. The incompatibilities are properly a property of the axiom as a whole, and they are computed only when the final axiom is built. During serialization, the list is converted into a list of the indices of the branches. -} -- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom. -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.hs data CoAxiom br = CoAxiom -- Type equality axiom. { co_ax_unique :: Unique -- Unique identifier , co_ax_name :: Name -- Name for pretty-printing , co_ax_role :: Role -- Role of the axiom's equality , co_ax_tc :: TyCon -- The head of the LHS patterns -- e.g. the newtype or family tycon , co_ax_branches :: Branches br -- The branches that form this axiom , co_ax_implicit :: Bool -- True <=> the axiom is "implicit" -- See Note [Implicit axioms] -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1. } data CoAxBranch = CoAxBranch { cab_loc :: SrcSpan -- Location of the defining equation -- See Note [CoAxiom locations] , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh , cab_eta_tvs :: [TyVar] -- Eta-reduced tyvars -- See Note [CoAxBranch type variables] -- cab_tvs and cab_lhs may be eta-reduded; see -- Note [Eta reduction for data families] , cab_cvs :: [CoVar] -- Bound coercion variables -- Always empty, for now. -- See Note [Constraints in patterns] -- in TcTyClsDecls , cab_roles :: [Role] -- See Note [CoAxBranch roles] , cab_lhs :: [Type] -- Type patterns to match against , cab_rhs :: Type -- Right-hand side of the equality , cab_incomps :: [CoAxBranch] -- The previous incompatible branches -- See Note [Storing compatibility] } deriving Data.Data toBranchedAxiom :: CoAxiom br -> CoAxiom Branched toBranchedAxiom (CoAxiom unique name role tc branches implicit) = CoAxiom unique name role tc (toBranched branches) implicit toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched toUnbranchedAxiom (CoAxiom unique name role tc branches implicit) = CoAxiom unique name role tc (toUnbranched branches) implicit coAxiomNumPats :: CoAxiom br -> Int coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0) coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index = branchesNth bs index coAxiomArity :: CoAxiom br -> BranchIndex -> Arity coAxiomArity ax index = length tvs + length cvs where CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index coAxiomName :: CoAxiom br -> Name coAxiomName = co_ax_name coAxiomRole :: CoAxiom br -> Role coAxiomRole = co_ax_role coAxiomBranches :: CoAxiom br -> Branches br coAxiomBranches = co_ax_branches coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = MkBranches arr }) | snd (bounds arr) == 0 = Just $ arr ! 0 | otherwise = Nothing coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr }) = arr ! 0 coAxiomTyCon :: CoAxiom br -> TyCon coAxiomTyCon = co_ax_tc coAxBranchTyVars :: CoAxBranch -> [TyVar] coAxBranchTyVars = cab_tvs coAxBranchCoVars :: CoAxBranch -> [CoVar] coAxBranchCoVars = cab_cvs coAxBranchLHS :: CoAxBranch -> [Type] coAxBranchLHS = cab_lhs coAxBranchRHS :: CoAxBranch -> Type coAxBranchRHS = cab_rhs coAxBranchRoles :: CoAxBranch -> [Role] coAxBranchRoles = cab_roles coAxBranchSpan :: CoAxBranch -> SrcSpan coAxBranchSpan = cab_loc isImplicitCoAxiom :: CoAxiom br -> Bool isImplicitCoAxiom = co_ax_implicit coAxBranchIncomps :: CoAxBranch -> [CoAxBranch] coAxBranchIncomps = cab_incomps -- See Note [Compatibility checking] in FamInstEnv placeHolderIncomps :: [CoAxBranch] placeHolderIncomps = panic "placeHolderIncomps" {- Note [CoAxBranch type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the case of a CoAxBranch of an associated type-family instance, we use the *same* type variables (where possible) as the enclosing class or instance. Consider instance C Int [z] where type F Int [z] = ... -- Second param must be [z] In the CoAxBranch in the instance decl (F Int [z]) we use the same 'z', so that it's easy to check that that type is the same as that in the instance header. So, unlike FamInsts, there is no expectation that the cab_tvs are fresh wrt each other, or any other CoAxBranch. Note [CoAxBranch roles] ~~~~~~~~~~~~~~~~~~~~~~~ Consider this code: newtype Age = MkAge Int newtype Wrap a = MkWrap a convert :: Wrap Age -> Int convert (MkWrap (MkAge i)) = i We want this to compile to: NTCo:Wrap :: forall a. Wrap a ~R a NTCo:Age :: Age ~R Int convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0]) But, note that NTCo:Age is at role R. Thus, we need to be able to pass coercions at role R into axioms. However, we don't *always* want to be able to do this, as it would be disastrous with type families. The solution is to annotate the arguments to the axiom with roles, much like we annotate tycon tyvars. Where do these roles get set? Newtype axioms inherit their roles from the newtype tycon; family axioms are all at role N. Note [CoAxiom locations] ~~~~~~~~~~~~~~~~~~~~~~~~ The source location of a CoAxiom is stored in two places in the datatype tree. * The first is in the location info buried in the Name of the CoAxiom. This span includes all of the branches of a branched CoAxiom. * The second is in the cab_loc fields of the CoAxBranches. In the case of a single branch, we can extract the source location of the branch from the name of the CoAxiom. In other cases, we need an explicit SrcSpan to correctly store the location of the equation giving rise to the FamInstBranch. Note [Implicit axioms] ~~~~~~~~~~~~~~~~~~~~~~ See also Note [Implicit TyThings] in HscTypes * A CoAxiom arising from data/type family instances is not "implicit". That is, it has its own IfaceAxiom declaration in an interface file * The CoAxiom arising from a newtype declaration *is* "implicit". That is, it does not have its own IfaceAxiom declaration in an interface file; instead the CoAxiom is generated by type-checking the newtype declaration Note [Eta reduction for data families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this data family T a b :: * newtype instance T Int a = MkT (IO a) deriving( Monad ) We'd like this to work. From the 'newtype instance' you might think we'd get: newtype TInt a = MkT (IO a) axiom ax1 a :: T Int a ~ TInt a -- The newtype-instance part axiom ax2 a :: TInt a ~ IO a -- The newtype part But now what can we do? We have this problem Given: d :: Monad IO Wanted: d' :: Monad (T Int) = d |> ???? What coercion can we use for the ??? Solution: eta-reduce both axioms, thus: axiom ax1 :: T Int ~ TInt axiom ax2 :: TInt ~ IO Now d' = d |> Monad (sym (ax2 ; ax1)) ----- Bottom line ------ For a CoAxBranch for a data family instance with representation TyCon rep_tc: - cab_tvs (of its CoAxiom) may be shorter than tyConTyVars of rep_tc. - cab_lhs may be shorter than tyConArity of the family tycon i.e. LHS is unsaturated - cab_rhs will be (rep_tc cab_tvs) i.e. RHS is un-saturated - This eta reduction happens for data instances as well as newtype instances. Here we want to eta-reduce the data family axiom. - This eta-reduction is done in TcInstDcls.tcDataFamInstDecl. But for a /type/ family - cab_lhs has the exact arity of the family tycon There are certain situations (e.g., pretty-printing) where it is necessary to deal with eta-expanded data family instances. For these situations, the cab_eta_tvs field records the stuff that has been eta-reduced away. So if we have axiom forall a b. F [a->b] = D b a and cab_eta_tvs is [p,q], then the original user-written definition looked like axiom forall a b p q. F [a->b] p q = D b a p q (See #9692, #14179, and #15845 for examples of what can go wrong if we don't eta-expand when showing things to the user.) (See also Note [Newtype eta] in TyCon. This is notionally separate and deals with the axiom connecting a newtype with its representation type; but it too is eta-reduced.) -} instance Eq (CoAxiom br) where a == b = getUnique a == getUnique b a /= b = getUnique a /= getUnique b instance Uniquable (CoAxiom br) where getUnique = co_ax_unique instance Outputable (CoAxiom br) where ppr = ppr . getName instance NamedThing (CoAxiom br) where getName = co_ax_name instance Typeable br => Data.Data (CoAxiom br) where -- don't traverse? toConstr _ = abstractConstr "CoAxiom" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "CoAxiom" instance Outputable CoAxBranch where ppr (CoAxBranch { cab_loc = loc , cab_lhs = lhs , cab_rhs = rhs }) = text "CoAxBranch" <+> parens (ppr loc) <> colon <+> brackets (fsep (punctuate comma (map pprType lhs))) <+> text "=>" <+> pprType rhs {- ************************************************************************ * * Roles * * ************************************************************************ Roles are defined here to avoid circular dependencies. -} -- See Note [Roles] in Coercion -- defined here to avoid cyclic dependency with Coercion -- -- Order of constructors matters: the Ord instance coincides with the *super*typing -- relation on roles. data Role = Nominal | Representational | Phantom deriving (Eq, Ord, Data.Data) -- These names are slurped into the parser code. Changing these strings -- will change the **surface syntax** that GHC accepts! If you want to -- change only the pretty-printing, do some replumbing. See -- mkRoleAnnotDecl in RdrHsSyn fsFromRole :: Role -> FastString fsFromRole Nominal = fsLit "nominal" fsFromRole Representational = fsLit "representational" fsFromRole Phantom = fsLit "phantom" instance Outputable Role where ppr = ftext . fsFromRole instance Binary Role where put_ bh Nominal = putByte bh 1 put_ bh Representational = putByte bh 2 put_ bh Phantom = putByte bh 3 get bh = do tag <- getByte bh case tag of 1 -> return Nominal 2 -> return Representational 3 -> return Phantom _ -> panic ("get Role " ++ show tag) {- ************************************************************************ * * CoAxiomRule Rules for building Evidence * * ************************************************************************ Conditional axioms. The general idea is that a `CoAxiomRule` looks like this: forall as. (r1 ~ r2, s1 ~ s2) => t1 ~ t2 My intention is to reuse these for both (~) and (~#). The short-term plan is to use this datatype to represent the type-nat axioms. In the longer run, it may be good to unify this and `CoAxiom`, as `CoAxiom` is the special case when there are no assumptions. -} -- | A more explicit representation for `t1 ~ t2`. type TypeEqn = Pair Type -- | For now, we work only with nominal equality. data CoAxiomRule = CoAxiomRule { coaxrName :: FastString , coaxrAsmpRoles :: [Role] -- roles of parameter equations , coaxrRole :: Role -- role of resulting equation , coaxrProves :: [TypeEqn] -> Maybe TypeEqn -- ^ coaxrProves returns @Nothing@ when it doesn't like -- the supplied arguments. When this happens in a coercion -- that means that the coercion is ill-formed, and Core Lint -- checks for that. } instance Data.Data CoAxiomRule where -- don't traverse? toConstr _ = abstractConstr "CoAxiomRule" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "CoAxiomRule" instance Uniquable CoAxiomRule where getUnique = getUnique . coaxrName instance Eq CoAxiomRule where x == y = coaxrName x == coaxrName y instance Ord CoAxiomRule where compare x y = compare (coaxrName x) (coaxrName y) instance Outputable CoAxiomRule where ppr = ppr . coaxrName -- Type checking of built-in families data BuiltInSynFamily = BuiltInSynFamily { sfMatchFam :: [Type] -> Maybe (CoAxiomRule, [Type], Type) , sfInteractTop :: [Type] -> Type -> [TypeEqn] , sfInteractInert :: [Type] -> Type -> [Type] -> Type -> [TypeEqn] } -- Provides default implementations that do nothing. trivialBuiltInFamily :: BuiltInSynFamily trivialBuiltInFamily = BuiltInSynFamily { sfMatchFam = \_ -> Nothing , sfInteractTop = \_ _ -> [] , sfInteractInert = \_ _ _ _ -> [] } ghc-lib-parser-8.10.2.20200808/compiler/types/Coercion.hs0000644000000000000000000033610513713635745020572 0ustar0000000000000000{- (c) The University of Glasgow 2006 -} {-# LANGUAGE RankNTypes, CPP, MultiWayIf, FlexibleContexts, BangPatterns, ScopedTypeVariables #-} -- | Module for (a) type kinds and (b) type coercions, -- as used in System FC. See 'CoreSyn.Expr' for -- more on System FC and how coercions fit into it. -- module Coercion ( -- * Main data type Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR, UnivCoProvenance, CoercionHole(..), coHoleCoVar, setCoHoleCoVar, LeftOrRight(..), Var, CoVar, TyCoVar, Role(..), ltRole, -- ** Functions over coercions coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole, coercionType, coercionKind, coercionKinds, mkCoercionType, coercionRole, coercionKindRole, -- ** Constructing coercions mkGReflCo, mkReflCo, mkRepReflCo, mkNomReflCo, mkCoVarCo, mkCoVarCos, mkAxInstCo, mkUnbranchedAxInstCo, mkAxInstRHS, mkUnbranchedAxInstRHS, mkAxInstLHS, mkUnbranchedAxInstLHS, mkPiCo, mkPiCos, mkCoCast, mkSymCo, mkTransCo, mkTransMCo, mkNthCo, nthCoRole, mkLRCo, mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, mkForAllCo, mkForAllCos, mkHomoForAllCos, mkPhantomCo, mkUnsafeCo, mkHoleCo, mkUnivCo, mkSubCo, mkAxiomInstCo, mkProofIrrelCo, downgradeRole, mkAxiomRuleCo, mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo, mkKindCo, castCoercionKind, castCoercionKindI, mkHeteroCoercionType, mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, -- ** Decomposition instNewTyCon_maybe, NormaliseStepper, NormaliseStepResult(..), composeSteppers, mapStepResult, unwrapNewTypeStepper, topNormaliseNewType_maybe, topNormaliseTypeX, decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe, splitTyConAppCo_maybe, splitAppCo_maybe, splitFunCo_maybe, splitForAllCo_maybe, splitForAllCo_ty_maybe, splitForAllCo_co_maybe, nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, pickLR, isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe, isReflCoVar_maybe, isGReflMCo, coToMCo, -- ** Coercion variables mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, isCoVar_maybe, -- ** Free variables tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet, coercionSize, -- ** Substitution CvSubstEnv, emptyCvSubstEnv, lookupCoVar, substCo, substCos, substCoVar, substCoVars, substCoWith, substCoVarBndr, extendTvSubstAndInScope, getCvSubstEnv, -- ** Lifting liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx, emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope, liftCoSubstVarBndrUsing, isMappedByLC, mkSubstLiftingContext, zapLiftingContext, substForAllCoBndrUsingLC, lcTCvSubst, lcInScopeSet, LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, -- ** Comparison eqCoercion, eqCoercionX, -- ** Forcing evaluation of coercions seqCo, -- * Pretty-printing pprCo, pprParendCo, pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS, pprCoAxBranchUser, tidyCoAxBndrsForUser, etaExpandCoAxBranch, -- * Tidying tidyCo, tidyCos, -- * Other promoteCoercion, buildCoercion, simplifyArgsWorker ) where #include "GhclibHsVersions.h" import {-# SOURCE #-} ToIface (toIfaceTyCon, tidyToIfaceTcArgs) import GhcPrelude import IfaceType import TyCoRep import TyCoFVs import TyCoPpr import TyCoSubst import TyCoTidy import Type import TyCon import CoAxiom import Var import VarEnv import VarSet import Name hiding ( varName ) import Util import BasicTypes import Outputable import Unique import Pair import SrcLoc import PrelNames import TysPrim import ListSetOps import Maybes import UniqFM import Control.Monad (foldM, zipWithM) import Data.Function ( on ) import Data.Char( isDigit ) {- %************************************************************************ %* * -- The coercion arguments always *precisely* saturate -- arity of (that branch of) the CoAxiom. If there are -- any left over, we use AppCo. See -- See [Coercion axioms applied to coercions] in TyCoRep \subsection{Coercion variables} %* * %************************************************************************ -} coVarName :: CoVar -> Name coVarName = varName setCoVarUnique :: CoVar -> Unique -> CoVar setCoVarUnique = setVarUnique setCoVarName :: CoVar -> Name -> CoVar setCoVarName = setVarName {- %************************************************************************ %* * Pretty-printing CoAxioms %* * %************************************************************************ Defined here to avoid module loops. CoAxiom is loaded very early on. -} etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type) -- Return the (tvs,lhs,rhs) after eta-expanding, -- to the way in which the axiom was originally written -- See Note [Eta reduction for data families] in CoAxiom etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs , cab_eta_tvs = eta_tvs , cab_lhs = lhs , cab_rhs = rhs }) -- ToDo: what about eta_cvs? = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys) where eta_tys = mkTyVarTys eta_tvs pprCoAxiom :: CoAxiom br -> SDoc -- Used in debug-printing only pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) = hang (text "axiom" <+> ppr ax <+> dcolon) 2 (vcat (map (pprCoAxBranchUser tc) (fromBranches branches))) pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc -- Used when printing injectivity errors (FamInst.reportInjectivityErrors) -- and inaccessible branches (TcValidity.inaccessibleCoAxBranch) -- This happens in error messages: don't print the RHS of a data -- family axiom, which is meaningless to a user pprCoAxBranchUser tc br | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br | otherwise = pprCoAxBranch tc br pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc -- Print the family-instance equation when reporting -- a conflict between equations (FamInst.conflictInstErr) -- For type families the RHS is important; for data families not so. -- Indeed for data families the RHS is a mysterious internal -- type constructor, so we suppress it (#14179) -- See FamInstEnv Note [Family instance overlap conflicts] pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs where pp_rhs _ _ = empty pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc pprCoAxBranch = ppr_co_ax_branch ppr_rhs where ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc) -> TyCon -> CoAxBranch -> SDoc ppr_co_ax_branch ppr_rhs fam_tc branch = foldr1 (flip hangNotEmpty 2) [ pprUserForAll (mkTyCoVarBinders Inferred bndrs') -- See Note [Printing foralls in type family instances] in IfaceType , pp_lhs <+> ppr_rhs tidy_env ee_rhs , text "-- Defined" <+> pp_loc ] where loc = coAxBranchSpan branch pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc) | otherwise = text "in" <+> ppr loc -- Eta-expand LHS and RHS types, because sometimes data family -- instances are eta-reduced. -- See Note [Eta reduction for data families] in FamInstEnv. (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs) (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var]) -- Tidy wildcards "_1", "_2" to "_", and do not return them -- in the list of binders to be printed -- This is so that in error messages we see -- forall a. F _ [a] _ = ... -- rather than -- forall a _1 _2. F _1 [a] _2 = ... -- -- This is a rather disgusting function tidyCoAxBndrsForUser init_env tcvs = (tidy_env, reverse tidy_bndrs) where (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs tidy_one (env@(occ_env, subst), rev_bndrs') bndr | is_wildcard bndr = (env_wild, rev_bndrs') | otherwise = (env', bndr' : rev_bndrs') where (env', bndr') = tidyVarBndr env bndr env_wild = (occ_env, extendVarEnv subst bndr wild_bndr) wild_bndr = setVarName bndr $ tidyNameOcc (varName bndr) (mkTyVarOcc "_") -- Tidy the binder to "_" is_wildcard :: Var -> Bool is_wildcard tv = case occNameString (getOccName tv) of ('_' : rest) -> all isDigit rest _ -> False {- %************************************************************************ %* * Destructing coercions %* * %************************************************************************ Note [Function coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~ Remember that (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> TYPE LiftedRep Hence FunCo r co1 co2 :: (s1->t1) ~r (s2->t2) is short for TyConAppCo (->) co_rep1 co_rep2 co1 co2 where co_rep1, co_rep2 are the coercions on the representations. -} -- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into -- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: -- -- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c] decomposeCo :: Arity -> Coercion -> [Role] -- the roles of the output coercions -- this must have at least as many -- entries as the Arity provided -> [Coercion] decomposeCo arity co rs = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ] -- Remember, Nth is zero-indexed decomposeFunCo :: HasDebugCallStack => Role -- Role of the input coercion -> Coercion -- Input coercion -> (Coercion, Coercion) -- Expects co :: (s1 -> t1) ~ (s2 -> t2) -- Returns (co1 :: s1~s2, co2 :: t1~t2) -- See Note [Function coercions] for the "2" and "3" decomposeFunCo r co = ASSERT2( all_ok, ppr co ) (mkNthCo r 2 co, mkNthCo r 3 co) where Pair s1t1 s2t2 = coercionKind co all_ok = isFunTy s1t1 && isFunTy s2t2 {- Note [Pushing a coercion into a pi-type] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have this: (f |> co) t1 .. tn Then we want to push the coercion into the arguments, so as to make progress. For example of why you might want to do so, see Note [Respecting definitional equality] in TyCoRep. This is done by decomposePiCos. Specifically, if decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor) then (f |> co) t1 .. tn = (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn Notes: * k can be smaller than n! That is decomposePiCos can return *fewer* coercions than there are arguments (ie k < n), if the kind provided doesn't have enough binders. * If there is a type error, we might see (f |> co) t1 where co :: (forall a. ty) ~ (ty1 -> ty2) Here 'co' is insoluble, but we don't want to crash in decoposePiCos. So decomposePiCos carefully tests both sides of the coercion to check they are both foralls or both arrows. Not doing this caused #15343. -} decomposePiCos :: HasDebugCallStack => CoercionN -> Pair Type -- Coercion and its kind -> [Type] -> ([CoercionN], CoercionN) -- See Note [Pushing a coercion into a pi-type] decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args where orig_subst = mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co go :: [CoercionN] -- accumulator for argument coercions, reversed -> (TCvSubst,Kind) -- Lhs kind of coercion -> CoercionN -- coercion originally applied to the function -> (TCvSubst,Kind) -- Rhs kind of coercion -> [Type] -- Arguments to that function -> ([CoercionN], Coercion) -- Invariant: co :: subst1(k2) ~ subst2(k2) go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys) | Just (a, t1) <- splitForAllTy_maybe k1 , Just (b, t2) <- splitForAllTy_maybe k2 -- know co :: (forall a:s1.t1) ~ (forall b:s2.t2) -- function :: forall a:s1.t1 (the function is not passed to decomposePiCos) -- a :: s1 -- b :: s2 -- ty :: s2 -- need arg_co :: s2 ~ s1 -- res_co :: t1[ty |> arg_co / a] ~ t2[ty / b] = let arg_co = mkNthCo Nominal 0 (mkSymCo co) res_co = mkInstCo co (mkGReflLeftCo Nominal ty arg_co) subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co) subst2' = extendTCvSubst subst2 b ty in go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys | Just (_s1, t1) <- splitFunTy_maybe k1 , Just (_s2, t2) <- splitFunTy_maybe k2 -- know co :: (s1 -> t1) ~ (s2 -> t2) -- function :: s1 -> t1 -- ty :: s2 -- need arg_co :: s2 ~ s1 -- res_co :: t1 ~ t2 = let (sym_arg_co, res_co) = decomposeFunCo Nominal co arg_co = mkSymCo sym_arg_co in go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2) = go acc_arg_cos (zapTCvSubst subst1, substTy subst1 k1) co (zapTCvSubst subst2, substTy subst1 k2) (ty:tys) -- tys might not be empty, if the left-hand type of the original coercion -- didn't have enough binders go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co) -- | Attempts to obtain the type variable underlying a 'Coercion' getCoVar_maybe :: Coercion -> Maybe CoVar getCoVar_maybe (CoVarCo cv) = Just cv getCoVar_maybe _ = Nothing -- | Attempts to tease a coercion apart into a type constructor and the application -- of a number of coercion arguments to that constructor splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion]) splitTyConAppCo_maybe co | Just (ty, r) <- isReflCo_maybe co = do { (tc, tys) <- splitTyConApp_maybe ty ; let args = zipWith mkReflCo (tyConRolesX r tc) tys ; return (tc, args) } splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos) splitTyConAppCo_maybe (FunCo _ arg res) = Just (funTyCon, cos) where cos = [mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res] splitTyConAppCo_maybe _ = Nothing -- first result has role equal to input; third result is Nominal splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) -- ^ Attempt to take a coercion application apart. splitAppCo_maybe (AppCo co arg) = Just (co, arg) splitAppCo_maybe (TyConAppCo r tc args) | args `lengthExceeds` tyConArity tc , Just (args', arg') <- snocView args = Just ( mkTyConAppCo r tc args', arg' ) | not (mustBeSaturated tc) -- Never create unsaturated type family apps! , Just (args', arg') <- snocView args , Just arg'' <- setNominalRole_maybe (nthRole r tc (length args')) arg' = Just ( mkTyConAppCo r tc args', arg'' ) -- Use mkTyConAppCo to preserve the invariant -- that identity coercions are always represented by Refl splitAppCo_maybe co | Just (ty, r) <- isReflCo_maybe co , Just (ty1, ty2) <- splitAppTy_maybe ty = Just (mkReflCo r ty1, mkNomReflCo ty2) splitAppCo_maybe _ = Nothing splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) splitFunCo_maybe (FunCo _ arg res) = Just (arg, res) splitFunCo_maybe _ = Nothing splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion) splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co) splitForAllCo_maybe _ = Nothing -- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) splitForAllCo_ty_maybe (ForAllCo tv k_co co) | isTyVar tv = Just (tv, k_co, co) splitForAllCo_ty_maybe _ = Nothing -- | Like 'splitForAllCo_maybe', but only returns Just for covar binder splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) splitForAllCo_co_maybe (ForAllCo cv k_co co) | isCoVar cv = Just (cv, k_co, co) splitForAllCo_co_maybe _ = Nothing ------------------------------------------------------- -- and some coercion kind stuff coVarTypes :: HasDebugCallStack => CoVar -> Pair Type coVarTypes cv | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv = Pair ty1 ty2 coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind,Kind,Type,Type,Role) coVarKindsTypesRole cv | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv) = let role | tc `hasKey` eqPrimTyConKey = Nominal | tc `hasKey` eqReprPrimTyConKey = Representational | otherwise = panic "coVarKindsTypesRole" in (k1,k2,ty1,ty2,role) | otherwise = pprPanic "coVarKindsTypesRole, non coercion variable" (ppr cv $$ ppr (varType cv)) coVarKind :: CoVar -> Type coVarKind cv = ASSERT( isCoVar cv ) varType cv coVarRole :: CoVar -> Role coVarRole cv | tc `hasKey` eqPrimTyConKey = Nominal | tc `hasKey` eqReprPrimTyConKey = Representational | otherwise = pprPanic "coVarRole: unknown tycon" (ppr cv <+> dcolon <+> ppr (varType cv)) where tc = case tyConAppTyCon_maybe (varType cv) of Just tc0 -> tc0 Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv) -- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@, -- produce a coercion @rep_co :: r1 ~ r2@. mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion mkRuntimeRepCo co = mkNthCo Nominal 0 kind_co where kind_co = mkKindCo co -- kind_co :: TYPE r1 ~ TYPE r2 -- (up to silliness with Constraint) isReflCoVar_maybe :: Var -> Maybe Coercion -- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t) -- Works on all kinds of Vars, not just CoVars isReflCoVar_maybe cv | isCoVar cv , Pair ty1 ty2 <- coVarTypes cv , ty1 `eqType` ty2 = Just (mkReflCo (coVarRole cv) ty1) | otherwise = Nothing -- | Tests if this coercion is obviously a generalized reflexive coercion. -- Guaranteed to work very quickly. isGReflCo :: Coercion -> Bool isGReflCo (GRefl{}) = True isGReflCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl isGReflCo _ = False -- | Tests if this MCoercion is obviously generalized reflexive -- Guaranteed to work very quickly. isGReflMCo :: MCoercion -> Bool isGReflMCo MRefl = True isGReflMCo (MCo co) | isGReflCo co = True isGReflMCo _ = False -- | Tests if this coercion is obviously reflexive. Guaranteed to work -- very quickly. Sometimes a coercion can be reflexive, but not obviously -- so. c.f. 'isReflexiveCo' isReflCo :: Coercion -> Bool isReflCo (Refl{}) = True isReflCo (GRefl _ _ mco) | isGReflMCo mco = True isReflCo _ = False -- | Returns the type coerced if this coercion is a generalized reflexive -- coercion. Guaranteed to work very quickly. isGReflCo_maybe :: Coercion -> Maybe (Type, Role) isGReflCo_maybe (GRefl r ty _) = Just (ty, r) isGReflCo_maybe (Refl ty) = Just (ty, Nominal) isGReflCo_maybe _ = Nothing -- | Returns the type coerced if this coercion is reflexive. Guaranteed -- to work very quickly. Sometimes a coercion can be reflexive, but not -- obviously so. c.f. 'isReflexiveCo_maybe' isReflCo_maybe :: Coercion -> Maybe (Type, Role) isReflCo_maybe (Refl ty) = Just (ty, Nominal) isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) isReflCo_maybe _ = Nothing -- | Slowly checks if the coercion is reflexive. Don't call this in a loop, -- as it walks over the entire coercion. isReflexiveCo :: Coercion -> Bool isReflexiveCo = isJust . isReflexiveCo_maybe -- | Extracts the coerced type from a reflexive coercion. This potentially -- walks over the entire coercion, so avoid doing this in a loop. isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role) isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal) isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) isReflexiveCo_maybe co | ty1 `eqType` ty2 = Just (ty1, r) | otherwise = Nothing where (Pair ty1 ty2, r) = coercionKindRole co coToMCo :: Coercion -> MCoercion coToMCo c = if isReflCo c then MRefl else MCo c {- %************************************************************************ %* * Building coercions %* * %************************************************************************ These "smart constructors" maintain the invariants listed in the definition of Coercion, and they perform very basic optimizations. Note [Role twiddling functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are a plethora of functions for twiddling roles: mkSubCo: Requires a nominal input coercion and always produces a representational output. This is used when you (the programmer) are sure you know exactly that role you have and what you want. downgradeRole_maybe: This function takes both the input role and the output role as parameters. (The *output* role comes first!) It can only *downgrade* a role -- that is, change it from N to R or P, or from R to P. This one-way behavior is why there is the "_maybe". If an upgrade is requested, this function produces Nothing. This is used when you need to change the role of a coercion, but you're not sure (as you're writing the code) of which roles are involved. This function could have been written using coercionRole to ascertain the role of the input. But, that function is recursive, and the caller of downgradeRole_maybe often knows the input role. So, this is more efficient. downgradeRole: This is just like downgradeRole_maybe, but it panics if the conversion isn't a downgrade. setNominalRole_maybe: This is the only function that can *upgrade* a coercion. The result (if it exists) is always Nominal. The input can be at any role. It works on a "best effort" basis, as it should never be strictly necessary to upgrade a coercion during compilation. It is currently only used within GHC in splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable that splitAppCo_maybe is operating over a TyConAppCo that uses a representational coercion. Hence the need for setNominalRole_maybe. splitAppCo_maybe, in turn, is used only within coercion optimization -- thus, it is not absolutely critical that setNominalRole_maybe be complete. Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom UnivCos are perfectly type-safe, whereas representational and nominal ones are not. Indeed, `unsafeCoerce` is implemented via a representational UnivCo. (Nominal ones are no worse than representational ones, so this function *will* change a UnivCo Representational to a UnivCo Nominal.) Conal Elliott also came across a need for this function while working with the GHC API, as he was decomposing Core casts. The Core casts use representational coercions, as they must, but his use case required nominal coercions (he was building a GADT). So, that's why this function is exported from this module. One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as appropriate? I (Richard E.) have decided not to do this, because upgrading a role is bizarre and a caller should have to ask for this behavior explicitly. -} -- | Make a generalized reflexive coercion mkGReflCo :: Role -> Type -> MCoercionN -> Coercion mkGReflCo r ty mco | isGReflMCo mco = if r == Nominal then Refl ty else GRefl r ty MRefl | otherwise = GRefl r ty mco -- | Make a reflexive coercion mkReflCo :: Role -> Type -> Coercion mkReflCo Nominal ty = Refl ty mkReflCo r ty = GRefl r ty MRefl -- | Make a representational reflexive coercion mkRepReflCo :: Type -> Coercion mkRepReflCo ty = GRefl Representational ty MRefl -- | Make a nominal reflexive coercion mkNomReflCo :: Type -> Coercion mkNomReflCo = Refl -- | Apply a type constructor to a list of coercions. It is the -- caller's responsibility to get the roles correct on argument coercions. mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion mkTyConAppCo r tc cos | tc `hasKey` funTyConKey , [_rep1, _rep2, co1, co2] <- cos -- See Note [Function coercions] = -- (a :: TYPE ra) -> (b :: TYPE rb) ~ (c :: TYPE rc) -> (d :: TYPE rd) -- rep1 :: ra ~ rc rep2 :: rb ~ rd -- co1 :: a ~ c co2 :: b ~ d mkFunCo r co1 co2 -- Expand type synonyms | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos | Just tys_roles <- traverse isReflCo_maybe cos = mkReflCo r (mkTyConApp tc (map fst tys_roles)) -- See Note [Refl invariant] | otherwise = TyConAppCo r tc cos -- | Build a function 'Coercion' from two other 'Coercion's. That is, -- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@. mkFunCo :: Role -> Coercion -> Coercion -> Coercion mkFunCo r co1 co2 -- See Note [Refl invariant] | Just (ty1, _) <- isReflCo_maybe co1 , Just (ty2, _) <- isReflCo_maybe co2 = mkReflCo r (mkVisFunTy ty1 ty2) | otherwise = FunCo r co1 co2 -- | Apply a 'Coercion' to another 'Coercion'. -- The second coercion must be Nominal, unless the first is Phantom. -- If the first is Phantom, then the second can be either Phantom or Nominal. mkAppCo :: Coercion -- ^ :: t1 ~r t2 -> Coercion -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2 -> Coercion -- ^ :: t1 s1 ~r t2 s2 mkAppCo co arg | Just (ty1, r) <- isReflCo_maybe co , Just (ty2, _) <- isReflCo_maybe arg = mkReflCo r (mkAppTy ty1 ty2) | Just (ty1, r) <- isReflCo_maybe co , Just (tc, tys) <- splitTyConApp_maybe ty1 -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102) = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) where zip_roles (r1:_) [] = [downgradeRole r1 Nominal arg] zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... mkAppCo (TyConAppCo r tc args) arg = case r of Nominal -> mkTyConAppCo Nominal tc (args ++ [arg]) Representational -> mkTyConAppCo Representational tc (args ++ [arg']) where new_role = (tyConRolesRepresentational tc) !! (length args) arg' = downgradeRole new_role Nominal arg Phantom -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg]) mkAppCo co arg = AppCo co arg -- Note, mkAppCo is careful to maintain invariants regarding -- where Refl constructors appear; see the comments in the definition -- of Coercion and the Note [Refl invariant] in TyCoRep. -- | Applies multiple 'Coercion's to another 'Coercion', from left to right. -- See also 'mkAppCo'. mkAppCos :: Coercion -> [Coercion] -> Coercion mkAppCos co1 cos = foldl' mkAppCo co1 cos {- Note [Unused coercion variable in ForAllCo] See Note [Unused coercion variable in ForAllTy] in TyCoRep for the motivation for checking coercion variable in types. To lift the design choice to (ForAllCo cv kind_co body_co), we have two options: (1) In mkForAllCo, we check whether cv is a coercion variable and whether it is not used in body_co. If so we construct a FunCo. (2) We don't do this check in mkForAllCo. In coercionKind, we use mkTyCoForAllTy to perform the check and construct a FunTy when necessary. We chose (2) for two reasons: * for a coercion, all that matters is its kind, So ForAllCo or FunCo does not make a difference. * even if cv occurs in body_co, it is possible that cv does not occur in the kind of body_co. Therefore the check in coercionKind is inevitable. The last wrinkle is that there are restrictions around the use of the cv in the coercion, as described in Section 5.8.5.2 of Richard's thesis. The idea is that we cannot prove that the type system is consistent with unrestricted use of this cv; the consistency proof uses an untyped rewrite relation that works over types with all coercions and casts removed. So, we can allow the cv to appear only in positions that are erased. As an approximation of this (and keeping close to the published theory), we currently allow the cv only within the type in a Refl node and under a GRefl node (including in the Coercion stored in a GRefl). It's possible other places are OK, too, but this is a safe approximation. Sadly, with heterogeneous equality, this restriction might be able to be violated; Richard's thesis is unable to prove that it isn't. Specifically, the liftCoSubst function might create an invalid coercion. Because a violation of the restriction might lead to a program that "goes wrong", it is checked all the time, even in a production compiler and without -dcore-list. We *have* proved that the problem does not occur with homogeneous equality, so this check can be dropped once ~# is made to be homogeneous. -} -- | Make a Coercion from a tycovar, a kind coercion, and a body coercion. -- The kind of the tycovar should be the left-hand kind of the kind coercion. -- See Note [Unused coercion variable in ForAllCo] mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion mkForAllCo v kind_co co | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True , Just (ty, r) <- isReflCo_maybe co , isGReflCo kind_co = mkReflCo r (mkTyCoInvForAllTy v ty) | otherwise = ForAllCo v kind_co co -- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious -- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'. -- The kind of the tycovar should be the left-hand kind of the kind coercion. mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion mkForAllCo_NoRefl v kind_co co | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True , ASSERT( not (isReflCo co)) True , isCoVar v , not (v `elemVarSet` tyCoVarsOfCo co) = FunCo (coercionRole co) kind_co co | otherwise = ForAllCo v kind_co co -- | Make nested ForAllCos mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion mkForAllCos bndrs co | Just (ty, r ) <- isReflCo_maybe co = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in foldl' (flip $ uncurry mkForAllCo_NoRefl) (mkReflCo r (mkTyCoInvForAllTys (reverse (map fst refls_rev'd)) ty)) non_refls_rev'd | otherwise = foldr (uncurry mkForAllCo_NoRefl) co bndrs -- | Make a Coercion quantified over a type/coercion variable; -- the variable has the same type in both sides of the coercion mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion mkHomoForAllCos vs co | Just (ty, r) <- isReflCo_maybe co = mkReflCo r (mkTyCoInvForAllTys vs ty) | otherwise = mkHomoForAllCos_NoRefl vs co -- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious -- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'. mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion mkHomoForAllCos_NoRefl vs orig_co = ASSERT( not (isReflCo orig_co)) foldr go orig_co vs where go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) co mkCoVarCo :: CoVar -> Coercion -- cv :: s ~# t -- See Note [mkCoVarCo] mkCoVarCo cv = CoVarCo cv mkCoVarCos :: [CoVar] -> [Coercion] mkCoVarCos = map mkCoVarCo {- Note [mkCoVarCo] ~~~~~~~~~~~~~~~~~~~ In the past, mkCoVarCo optimised (c :: t~t) to (Refl t). That is valid (although see Note [Unbound RULE binders] in Rules), but it's a relatively expensive test and perhaps better done in optCoercion. Not a big deal either way. -} -- | Extract a covar, if possible. This check is dirty. Be ashamed -- of yourself. (It's dirty because it cares about the structure of -- a coercion, which is morally reprehensible.) isCoVar_maybe :: Coercion -> Maybe CoVar isCoVar_maybe (CoVarCo cv) = Just cv isCoVar_maybe _ = Nothing mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Coercion -- mkAxInstCo can legitimately be called over-staturated; -- i.e. with more type arguments than the coercion requires mkAxInstCo role ax index tys cos | arity == n_tys = downgradeRole role ax_role $ mkAxiomInstCo ax_br index (rtys `chkAppend` cos) | otherwise = ASSERT( arity < n_tys ) downgradeRole role ax_role $ mkAppCos (mkAxiomInstCo ax_br index (ax_args `chkAppend` cos)) leftover_args where n_tys = length tys ax_br = toBranchedAxiom ax branch = coAxiomNthBranch ax_br index tvs = coAxBranchTyVars branch arity = length tvs arg_roles = coAxBranchRoles branch rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys (ax_args, leftover_args) = splitAt arity rtys ax_role = coAxiomRole ax -- worker function mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion mkAxiomInstCo ax index args = ASSERT( args `lengthIs` coAxiomArity ax index ) AxiomInstCo ax index args -- to be used only with unbranched axioms mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion mkUnbranchedAxInstCo role ax tys cos = mkAxInstCo role ax 0 tys cos mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type -- Instantiate the axiom with specified types, -- returning the instantiated RHS -- A companion to mkAxInstCo: -- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) mkAxInstRHS ax index tys cos = ASSERT( tvs `equalLength` tys1 ) mkAppTys rhs' tys2 where branch = coAxiomNthBranch ax index tvs = coAxBranchTyVars branch cvs = coAxBranchCoVars branch (tys1, tys2) = splitAtList tvs tys rhs' = substTyWith tvs tys1 $ substTyWithCoVars cvs cos $ coAxBranchRHS branch mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 -- | Return the left-hand type of the axiom, when the axiom is instantiated -- at the types given. mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type mkAxInstLHS ax index tys cos = ASSERT( tvs `equalLength` tys1 ) mkTyConApp fam_tc (lhs_tys `chkAppend` tys2) where branch = coAxiomNthBranch ax index tvs = coAxBranchTyVars branch cvs = coAxBranchCoVars branch (tys1, tys2) = splitAtList tvs tys lhs_tys = substTysWith tvs tys1 $ substTysWithCoVars cvs cos $ coAxBranchLHS branch fam_tc = coAxiomTyCon ax -- | Instantiate the left-hand side of an unbranched axiom mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0 -- | Manufacture an unsafe coercion from thin air. -- Currently (May 14) this is used only to implement the -- @unsafeCoerce#@ primitive. Optimise by pushing -- down through type constructors. mkUnsafeCo :: Role -> Type -> Type -> Coercion mkUnsafeCo role ty1 ty2 = mkUnivCo UnsafeCoerceProv role ty1 ty2 -- | Make a coercion from a coercion hole mkHoleCo :: CoercionHole -> Coercion mkHoleCo h = HoleCo h -- | Make a universal coercion between two arbitrary types. mkUnivCo :: UnivCoProvenance -> Role -- ^ role of the built coercion, "r" -> Type -- ^ t1 :: k1 -> Type -- ^ t2 :: k2 -> Coercion -- ^ :: t1 ~r t2 mkUnivCo prov role ty1 ty2 | ty1 `eqType` ty2 = mkReflCo role ty1 | otherwise = UnivCo prov role ty1 ty2 -- | Create a symmetric version of the given 'Coercion' that asserts -- equality between the same types but in the other "direction", so -- a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@. mkSymCo :: Coercion -> Coercion -- Do a few simple optimizations, but don't bother pushing occurrences -- of symmetry to the leaves; the optimizer will take care of that. mkSymCo co | isReflCo co = co mkSymCo (SymCo co) = co mkSymCo (SubCo (SymCo co)) = SubCo co mkSymCo co = SymCo co -- | Create a new 'Coercion' by composing the two given 'Coercion's transitively. -- (co1 ; co2) mkTransCo :: Coercion -> Coercion -> Coercion mkTransCo co1 co2 | isReflCo co1 = co2 | isReflCo co2 = co1 mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2)) = GRefl r t1 (MCo $ mkTransCo co1 co2) mkTransCo co1 co2 = TransCo co1 co2 -- | Compose two MCoercions via transitivity mkTransMCo :: MCoercion -> MCoercion -> MCoercion mkTransMCo MRefl co2 = co2 mkTransMCo co1 MRefl = co1 mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2) mkNthCo :: HasDebugCallStack => Role -- The role of the coercion you're creating -> Int -- Zero-indexed -> Coercion -> Coercion mkNthCo r n co = ASSERT2( good_call, bad_call_msg ) go r n co where Pair ty1 ty2 = coercionKind co go r 0 co | Just (ty, _) <- isReflCo_maybe co , Just (tv, _) <- splitForAllTy_maybe ty = -- works for both tyvar and covar ASSERT( r == Nominal ) mkNomReflCo (varType tv) go r n co | Just (ty, r0) <- isReflCo_maybe co , let tc = tyConAppTyCon ty = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty ) ASSERT( nthRole r0 tc n == r ) mkReflCo r (tyConAppArgN n ty) where ok_tc_app :: Type -> Int -> Bool ok_tc_app ty n | Just (_, tys) <- splitTyConApp_maybe ty = tys `lengthExceeds` n | isForAllTy ty -- nth:0 pulls out a kind coercion from a hetero forall = n == 0 | otherwise = False go r 0 (ForAllCo _ kind_co _) = ASSERT( r == Nominal ) kind_co -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) -- then (nth 0 co :: k1 ~N k2) -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4)) go r n co@(FunCo r0 arg res) -- See Note [Function coercions] -- If FunCo _ arg_co res_co :: (s1:TYPE sk1 -> s2:TYPE sk2) -- ~ (t1:TYPE tk1 -> t2:TYPE tk2) -- Then we want to behave as if co was -- TyConAppCo argk_co resk_co arg_co res_co -- where -- argk_co :: sk1 ~ tk1 = mkNthCo 0 (mkKindCo arg_co) -- resk_co :: sk2 ~ tk2 = mkNthCo 0 (mkKindCo res_co) -- i.e. mkRuntimeRepCo = case n of 0 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg 1 -> ASSERT( r == Nominal ) mkRuntimeRepCo res 2 -> ASSERT( r == r0 ) arg 3 -> ASSERT( r == r0 ) res _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co) go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n , (vcat [ ppr tc , ppr arg_cos , ppr r0 , ppr n , ppr r ]) ) arg_cos `getNth` n go r n co = NthCo r n co -- Assertion checking bad_call_msg = vcat [ text "Coercion =" <+> ppr co , text "LHS ty =" <+> ppr ty1 , text "RHS ty =" <+> ppr ty2 , text "n =" <+> ppr n, text "r =" <+> ppr r , text "coercion role =" <+> ppr (coercionRole co) ] good_call -- If the Coercion passed in is between forall-types, then the Int must -- be 0 and the role must be Nominal. | Just (_tv1, _) <- splitForAllTy_maybe ty1 , Just (_tv2, _) <- splitForAllTy_maybe ty2 = n == 0 && r == Nominal -- If the Coercion passed in is between T tys and T tys', then the Int -- must be less than the length of tys/tys' (which must be the same -- lengths). -- -- If the role of the Coercion is nominal, then the role passed in must -- be nominal. If the role of the Coercion is representational, then the -- role passed in must be tyConRolesRepresentational T !! n. If the role -- of the Coercion is Phantom, then the role passed in must be Phantom. -- -- See also Note [NthCo Cached Roles] if you're wondering why it's -- blaringly obvious that we should be *computing* this role instead of -- passing it in. | Just (tc1, tys1) <- splitTyConApp_maybe ty1 , Just (tc2, tys2) <- splitTyConApp_maybe ty2 , tc1 == tc2 = let len1 = length tys1 len2 = length tys2 good_role = case coercionRole co of Nominal -> r == Nominal Representational -> r == (tyConRolesRepresentational tc1 !! n) Phantom -> r == Phantom in len1 == len2 && n < len1 && good_role | otherwise = True -- | If you're about to call @mkNthCo r n co@, then @r@ should be -- whatever @nthCoRole n co@ returns. nthCoRole :: Int -> Coercion -> Role nthCoRole n co | Just (tc, _) <- splitTyConApp_maybe lty = nthRole r tc n | Just _ <- splitForAllTy_maybe lty = Nominal | otherwise = pprPanic "nthCoRole" (ppr co) where (Pair lty _, r) = coercionKindRole co mkLRCo :: LeftOrRight -> Coercion -> Coercion mkLRCo lr co | Just (ty, eq) <- isReflCo_maybe co = mkReflCo eq (pickLR lr (splitAppTy ty)) | otherwise = LRCo lr co -- | Instantiates a 'Coercion'. mkInstCo :: Coercion -> Coercion -> Coercion mkInstCo (ForAllCo tcv _kind_co body_co) co | Just (arg, _) <- isReflCo_maybe co -- works for both tyvar and covar = substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co mkInstCo co arg = InstCo co arg -- | Given @ty :: k1@, @co :: k1 ~ k2@, -- produces @co' :: ty ~r (ty |> co)@ mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion mkGReflRightCo r ty co | isGReflCo co = mkReflCo r ty -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ -- instead of @isReflCo@ | otherwise = GRefl r ty (MCo co) -- | Given @ty :: k1@, @co :: k1 ~ k2@, -- produces @co' :: (ty |> co) ~r ty@ mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion mkGReflLeftCo r ty co | isGReflCo co = mkReflCo r ty -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ -- instead of @isReflCo@ | otherwise = mkSymCo $ GRefl r ty (MCo co) -- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@, -- produces @co' :: (ty |> co) ~r ty' -- It is not only a utility function, but it saves allocation when co -- is a GRefl coercion. mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion mkCoherenceLeftCo r ty co co2 | isGReflCo co = co2 | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2 -- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@, -- produces @co' :: ty' ~r (ty |> co) -- It is not only a utility function, but it saves allocation when co -- is a GRefl coercion. mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion mkCoherenceRightCo r ty co co2 | isGReflCo co = co2 | otherwise = co2 `mkTransCo` GRefl r ty (MCo co) -- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@. mkKindCo :: Coercion -> Coercion mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty) mkKindCo (GRefl _ _ (MCo co)) = co mkKindCo (UnivCo (PhantomProv h) _ _ _) = h mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h mkKindCo co | Pair ty1 ty2 <- coercionKind co -- generally, calling coercionKind during coercion creation is a bad idea, -- as it can lead to exponential behavior. But, we don't have nested mkKindCos, -- so it's OK here. , let tk1 = typeKind ty1 tk2 = typeKind ty2 , tk1 `eqType` tk2 = Refl tk1 | otherwise = KindCo co mkSubCo :: Coercion -> Coercion -- Input coercion is Nominal, result is Representational -- see also Note [Role twiddling functions] mkSubCo (Refl ty) = GRefl Representational ty MRefl mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co mkSubCo (TyConAppCo Nominal tc cos) = TyConAppCo Representational tc (applyRoles tc cos) mkSubCo (FunCo Nominal arg res) = FunCo Representational (downgradeRole Representational Nominal arg) (downgradeRole Representational Nominal res) mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) ) SubCo co -- | Changes a role, but only a downgrade. See Note [Role twiddling functions] downgradeRole_maybe :: Role -- ^ desired role -> Role -- ^ current role -> Coercion -> Maybe Coercion -- In (downgradeRole_maybe dr cr co) it's a precondition that -- cr = coercionRole co downgradeRole_maybe Nominal Nominal co = Just co downgradeRole_maybe Nominal _ _ = Nothing downgradeRole_maybe Representational Nominal co = Just (mkSubCo co) downgradeRole_maybe Representational Representational co = Just co downgradeRole_maybe Representational Phantom _ = Nothing downgradeRole_maybe Phantom Phantom co = Just co downgradeRole_maybe Phantom _ co = Just (toPhantomCo co) -- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade. -- See Note [Role twiddling functions] downgradeRole :: Role -- desired role -> Role -- current role -> Coercion -> Coercion downgradeRole r1 r2 co = case downgradeRole_maybe r1 r2 co of Just co' -> co' Nothing -> pprPanic "downgradeRole" (ppr co) mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion mkAxiomRuleCo = AxiomRuleCo -- | Make a "coercion between coercions". mkProofIrrelCo :: Role -- ^ role of the created coercion, "r" -> Coercion -- ^ :: phi1 ~N phi2 -> Coercion -- ^ g1 :: phi1 -> Coercion -- ^ g2 :: phi2 -> Coercion -- ^ :: g1 ~r g2 -- if the two coercion prove the same fact, I just don't care what -- the individual coercions are. mkProofIrrelCo r co g _ | isGReflCo co = mkReflCo r (mkCoercionTy g) -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@ mkProofIrrelCo r kco g1 g2 = mkUnivCo (ProofIrrelProv kco) r (mkCoercionTy g1) (mkCoercionTy g2) {- %************************************************************************ %* * Roles %* * %************************************************************************ -} -- | Converts a coercion to be nominal, if possible. -- See Note [Role twiddling functions] setNominalRole_maybe :: Role -- of input coercion -> Coercion -> Maybe Coercion setNominalRole_maybe r co | r == Nominal = Just co | otherwise = setNominalRole_maybe_helper co where setNominalRole_maybe_helper (SubCo co) = Just co setNominalRole_maybe_helper co@(Refl _) = Just co setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co setNominalRole_maybe_helper (TyConAppCo Representational tc cos) = do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos ; return $ TyConAppCo Nominal tc cos' } setNominalRole_maybe_helper (FunCo Representational co1 co2) = do { co1' <- setNominalRole_maybe Representational co1 ; co2' <- setNominalRole_maybe Representational co2 ; return $ FunCo Nominal co1' co2' } setNominalRole_maybe_helper (SymCo co) = SymCo <$> setNominalRole_maybe_helper co setNominalRole_maybe_helper (TransCo co1 co2) = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2 setNominalRole_maybe_helper (AppCo co1 co2) = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2 setNominalRole_maybe_helper (ForAllCo tv kind_co co) = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co setNominalRole_maybe_helper (NthCo _r n co) -- NB, this case recurses via setNominalRole_maybe, not -- setNominalRole_maybe_helper! = NthCo Nominal n <$> setNominalRole_maybe (coercionRole co) co setNominalRole_maybe_helper (InstCo co arg) = InstCo <$> setNominalRole_maybe_helper co <*> pure arg setNominalRole_maybe_helper (UnivCo prov _ co1 co2) | case prov of UnsafeCoerceProv -> True -- it's always unsafe PhantomProv _ -> False -- should always be phantom ProofIrrelProv _ -> True -- it's always safe PluginProv _ -> False -- who knows? This choice is conservative. = Just $ UnivCo prov Nominal co1 co2 setNominalRole_maybe_helper _ = Nothing -- | Make a phantom coercion between two types. The coercion passed -- in must be a nominal coercion between the kinds of the -- types. mkPhantomCo :: Coercion -> Type -> Type -> Coercion mkPhantomCo h t1 t2 = mkUnivCo (PhantomProv h) Phantom t1 t2 -- takes any coercion and turns it into a Phantom coercion toPhantomCo :: Coercion -> Coercion toPhantomCo co = mkPhantomCo (mkKindCo co) ty1 ty2 where Pair ty1 ty2 = coercionKind co -- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational applyRoles :: TyCon -> [Coercion] -> [Coercion] applyRoles tc cos = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos -- the Role parameter is the Role of the TyConAppCo -- defined here because this is intimately concerned with the implementation -- of TyConAppCo -- Always returns an infinite list (with a infinite tail of Nominal) tyConRolesX :: Role -> TyCon -> [Role] tyConRolesX Representational tc = tyConRolesRepresentational tc tyConRolesX role _ = repeat role -- Returns the roles of the parameters of a tycon, with an infinite tail -- of Nominal tyConRolesRepresentational :: TyCon -> [Role] tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal nthRole :: Role -> TyCon -> Int -> Role nthRole Nominal _ _ = Nominal nthRole Phantom _ _ = Phantom nthRole Representational tc n = (tyConRolesRepresentational tc) `getNth` n ltRole :: Role -> Role -> Bool -- Is one role "less" than another? -- Nominal < Representational < Phantom ltRole Phantom _ = False ltRole Representational Phantom = True ltRole Representational _ = False ltRole Nominal Nominal = False ltRole Nominal _ = True ------------------------------- -- | like mkKindCo, but aggressively & recursively optimizes to avoid using -- a KindCo constructor. The output role is nominal. promoteCoercion :: Coercion -> CoercionN -- First cases handles anything that should yield refl. promoteCoercion co = case co of _ | ki1 `eqType` ki2 -> mkNomReflCo (typeKind ty1) -- no later branch should return refl -- The ASSERT( False )s throughout -- are these cases explicitly, but they should never fire. Refl _ -> ASSERT( False ) mkNomReflCo ki1 GRefl _ _ MRefl -> ASSERT( False ) mkNomReflCo ki1 GRefl _ _ (MCo co) -> co TyConAppCo _ tc args | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args -> co' | otherwise -> mkKindCo co AppCo co1 arg | Just co' <- instCoercion (coercionKind (mkKindCo co1)) (promoteCoercion co1) arg -> co' | otherwise -> mkKindCo co ForAllCo tv _ g | isTyVar tv -> promoteCoercion g ForAllCo _ _ _ -> ASSERT( False ) mkNomReflCo liftedTypeKind -- See Note [Weird typing rule for ForAllTy] in Type FunCo _ _ _ -> ASSERT( False ) mkNomReflCo liftedTypeKind CoVarCo {} -> mkKindCo co HoleCo {} -> mkKindCo co AxiomInstCo {} -> mkKindCo co AxiomRuleCo {} -> mkKindCo co UnivCo UnsafeCoerceProv _ t1 t2 -> mkUnsafeCo Nominal (typeKind t1) (typeKind t2) UnivCo (PhantomProv kco) _ _ _ -> kco UnivCo (ProofIrrelProv kco) _ _ _ -> kco UnivCo (PluginProv _) _ _ _ -> mkKindCo co SymCo g -> mkSymCo (promoteCoercion g) TransCo co1 co2 -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) NthCo _ n co1 | Just (_, args) <- splitTyConAppCo_maybe co1 , args `lengthExceeds` n -> promoteCoercion (args !! n) | Just _ <- splitForAllCo_maybe co , n == 0 -> ASSERT( False ) mkNomReflCo liftedTypeKind | otherwise -> mkKindCo co LRCo lr co1 | Just (lco, rco) <- splitAppCo_maybe co1 -> case lr of CLeft -> promoteCoercion lco CRight -> promoteCoercion rco | otherwise -> mkKindCo co InstCo g _ | isForAllTy_ty ty1 -> ASSERT( isForAllTy_ty ty2 ) promoteCoercion g | otherwise -> ASSERT( False) mkNomReflCo liftedTypeKind -- See Note [Weird typing rule for ForAllTy] in Type KindCo _ -> ASSERT( False ) mkNomReflCo liftedTypeKind SubCo g -> promoteCoercion g where Pair ty1 ty2 = coercionKind co ki1 = typeKind ty1 ki2 = typeKind ty2 -- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@, -- where @g' = promoteCoercion (h w)@. -- fails if this is not possible, if @g@ coerces between a forall and an -> -- or if second parameter has a representational role and can't be used -- with an InstCo. instCoercion :: Pair Type -- g :: lty ~ rty -> CoercionN -- ^ must be nominal -> Coercion -> Maybe CoercionN instCoercion (Pair lty rty) g w | (isForAllTy_ty lty && isForAllTy_ty rty) || (isForAllTy_co lty && isForAllTy_co rty) , Just w' <- setNominalRole_maybe (coercionRole w) w -- g :: (forall t1. t2) ~ (forall t1. t3) -- w :: s1 ~ s2 -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2] = Just $ mkInstCo g w' | isFunTy lty && isFunTy rty -- g :: (t1 -> t2) ~ (t3 -> t4) -- returns t2 ~ t4 = Just $ mkNthCo Nominal 3 g -- extract result type, which is the 4th argument to (->) | otherwise -- one forall, one funty... = Nothing -- | Repeated use of 'instCoercion' instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN instCoercions g ws = let arg_ty_pairs = map coercionKind ws in snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws) where go :: (Pair Type, Coercion) -> (Pair Type, Coercion) -> Maybe (Pair Type, Coercion) go (g_tys, g) (w_tys, w) = do { g' <- instCoercion g_tys g w ; return (piResultTy <$> g_tys <*> w_tys, g') } -- | Creates a new coercion with both of its types casted by different casts -- @castCoercionKind g r t1 t2 h1 h2@, where @g :: t1 ~r t2@, -- has type @(t1 |> h1) ~r (t2 |> h2)@. -- @h1@ and @h2@ must be nominal. castCoercionKind :: Coercion -> Role -> Type -> Type -> CoercionN -> CoercionN -> Coercion castCoercionKind g r t1 t2 h1 h2 = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) -- | Creates a new coercion with both of its types casted by different casts -- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@, -- has type @(t1 |> h1) ~r (t2 |> h2)@. -- @h1@ and @h2@ must be nominal. -- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for) -- Use @castCoercionKind@ instead if @t1@, @t2@, and @r@ are known beforehand. castCoercionKindI :: Coercion -> CoercionN -> CoercionN -> Coercion castCoercionKindI g h1 h2 = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) where (Pair t1 t2, r) = coercionKindRole g -- See note [Newtype coercions] in TyCon mkPiCos :: Role -> [Var] -> Coercion -> Coercion mkPiCos r vs co = foldr (mkPiCo r) co vs -- | Make a forall 'Coercion', where both types related by the coercion -- are quantified over the same variable. mkPiCo :: Role -> Var -> Coercion -> Coercion mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co | isCoVar v = ASSERT( not (v `elemVarSet` tyCoVarsOfCo co) ) -- We didn't call mkForAllCo here because if v does not appear -- in co, the argement coercion will be nominal. But here we -- want it to be r. It is only called in 'mkPiCos', which is -- only used in SimplUtils, where we are sure for -- now (Aug 2018) v won't occur in co. mkFunCo r (mkReflCo r (varType v)) co | otherwise = mkFunCo r (mkReflCo r (varType v)) co -- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 -- The first coercion might be lifted or unlifted; thus the ~? above -- Lifted and unlifted equalities take different numbers of arguments, -- so we have to make sure to supply the right parameter to decomposeCo. -- Also, note that the role of the first coercion is the same as the role of -- the equalities related by the second coercion. The second coercion is -- itself always representational. mkCoCast :: Coercion -> CoercionR -> Coercion mkCoCast c g | (g2:g1:_) <- reverse co_list = mkSymCo g1 `mkTransCo` c `mkTransCo` g2 | otherwise = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g)) where -- g :: (s1 ~# t1) ~# (s2 ~# t2) -- g1 :: s1 ~# s2 -- g2 :: t1 ~# t2 (tc, _) = splitTyConApp (pFst $ coercionKind g) co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc) {- %************************************************************************ %* * Newtypes %* * %************************************************************************ -} -- | If @co :: T ts ~ rep_ty@ then: -- -- > instNewTyCon_maybe T ts = Just (rep_ty, co) -- -- Checks for a newtype, and for being saturated instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) instNewTyCon_maybe tc tys | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype , tvs `leLength` tys -- Check saturated enough = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys []) | otherwise = Nothing {- ************************************************************************ * * Type normalisation * * ************************************************************************ -} -- | A function to check if we can reduce a type by one step. Used -- with 'topNormaliseTypeX'. type NormaliseStepper ev = RecTcChecker -> TyCon -- tc -> [Type] -- tys -> NormaliseStepResult ev -- | The result of stepping in a normalisation function. -- See 'topNormaliseTypeX'. data NormaliseStepResult ev = NS_Done -- ^ Nothing more to do | NS_Abort -- ^ Utter failure. The outer function should fail too. | NS_Step RecTcChecker Type ev -- ^ We stepped, yielding new bits; -- ^ ev is evidence; -- Usually a co :: old type ~ new type mapStepResult :: (ev1 -> ev2) -> NormaliseStepResult ev1 -> NormaliseStepResult ev2 mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev) mapStepResult _ NS_Done = NS_Done mapStepResult _ NS_Abort = NS_Abort -- | Try one stepper and then try the next, if the first doesn't make -- progress. -- So if it returns NS_Done, it means that both steppers are satisfied composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev -> NormaliseStepper ev composeSteppers step1 step2 rec_nts tc tys = case step1 rec_nts tc tys of success@(NS_Step {}) -> success NS_Done -> step2 rec_nts tc tys NS_Abort -> NS_Abort -- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into -- a loop. If it would fall into a loop, it produces 'NS_Abort'. unwrapNewTypeStepper :: NormaliseStepper Coercion unwrapNewTypeStepper rec_nts tc tys | Just (ty', co) <- instNewTyCon_maybe tc tys = case checkRecTc rec_nts tc of Just rec_nts' -> NS_Step rec_nts' ty' co Nothing -> NS_Abort | otherwise = NS_Done -- | A general function for normalising the top-level of a type. It continues -- to use the provided 'NormaliseStepper' until that function fails, and then -- this function returns. The roles of the coercions produced by the -- 'NormaliseStepper' must all be the same, which is the role returned from -- the call to 'topNormaliseTypeX'. -- -- Typically ev is Coercion. -- -- If topNormaliseTypeX step plus ty = Just (ev, ty') -- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty' -- and ev = ev1 `plus` ev2 `plus` ... `plus` evn -- If it returns Nothing then no newtype unwrapping could happen topNormaliseTypeX :: NormaliseStepper ev -> (ev -> ev -> ev) -> Type -> Maybe (ev, Type) topNormaliseTypeX stepper plus ty | Just (tc, tys) <- splitTyConApp_maybe ty , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys = go rec_nts ev ty' | otherwise = Nothing where go rec_nts ev ty | Just (tc, tys) <- splitTyConApp_maybe ty = case stepper rec_nts tc tys of NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty' NS_Done -> Just (ev, ty) NS_Abort -> Nothing | otherwise = Just (ev, ty) topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) -- ^ Sometimes we want to look through a @newtype@ and get its associated coercion. -- This function strips off @newtype@ layers enough to reveal something that isn't -- a @newtype@. Specifically, here's the invariant: -- -- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') -- -- then (a) @co : ty0 ~ ty'@. -- (b) ty' is not a newtype. -- -- The function returns @Nothing@ for non-@newtypes@, -- or unsaturated applications -- -- This function does *not* look through type families, because it has no access to -- the type family environment. If you do have that at hand, consider to use -- topNormaliseType_maybe, which should be a drop-in replacement for -- topNormaliseNewType_maybe -- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty' topNormaliseNewType_maybe ty = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty {- %************************************************************************ %* * Comparison of coercions %* * %************************************************************************ -} -- | Syntactic equality of coercions eqCoercion :: Coercion -> Coercion -> Bool eqCoercion = eqType `on` coercionType -- | Compare two 'Coercion's, with respect to an RnEnv2 eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool eqCoercionX env = eqTypeX env `on` coercionType {- %************************************************************************ %* * "Lifting" substitution [(TyCoVar,Coercion)] -> Type -> Coercion %* * %************************************************************************ Note [Lifting coercions over types: liftCoSubst] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The KPUSH rule deals with this situation data T a = K (a -> Maybe a) g :: T t1 ~ T t2 x :: t1 -> Maybe t1 case (K @t1 x) |> g of K (y:t2 -> Maybe t2) -> rhs We want to push the coercion inside the constructor application. So we do this g' :: t1~t2 = Nth 0 g case K @t2 (x |> g' -> Maybe g') of K (y:t2 -> Maybe t2) -> rhs The crucial operation is that we * take the type of K's argument: a -> Maybe a * and substitute g' for a thus giving *coercion*. This is what liftCoSubst does. In the presence of kind coercions, this is a bit of a hairy operation. So, we refer you to the paper introducing kind coercions, available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf Note [extendLiftingContextEx] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider we have datatype K :: \/k. \/a::k. P -> T k -- P be some type g :: T k1 ~ T k2 case (K @k1 @t1 x) |> g of K y -> rhs We want to push the coercion inside the constructor application. We first get the coercion mapped by the universal type variable k: lc = k |-> Nth 0 g :: k1~k2 Here, the important point is that the kind of a is coerced, and P might be dependent on the existential type variable a. Thus we first get the coercion of a's kind g2 = liftCoSubst lc k :: k1 ~ k2 Then we store a new mapping into the lifting context lc2 = a |-> (t1 ~ t1 |> g2), lc So later when we can correctly deal with the argument type P liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)] This is exactly what extendLiftingContextEx does. * For each (tyvar:k, ty) pair, we product the mapping tyvar |-> (ty ~ ty |> (liftCoSubst lc k)) * For each (covar:s1~s2, ty) pair, we produce the mapping covar |-> (co ~ co') co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2' This follows the lifting context extension definition in the "FC with Explicit Kind Equality" paper. -} -- ---------------------------------------------------- -- See Note [Lifting coercions over types: liftCoSubst] -- ---------------------------------------------------- data LiftingContext = LC TCvSubst LiftCoEnv -- in optCoercion, we need to lift when optimizing InstCo. -- See Note [Optimising InstCo] in OptCoercion -- We thus propagate the substitution from OptCoercion here. instance Outputable LiftingContext where ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env) type LiftCoEnv = VarEnv Coercion -- Maps *type variables* to *coercions*. -- That's the whole point of this function! -- Also maps coercion variables to ProofIrrelCos. -- like liftCoSubstWith, but allows for existentially-bound types as well liftCoSubstWithEx :: Role -- desired role for output coercion -> [TyVar] -- universally quantified tyvars -> [Coercion] -- coercions to substitute for those -> [TyCoVar] -- existentially quantified tycovars -> [Type] -- types and coercions to be bound to ex vars -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args) liftCoSubstWithEx role univs omegas exs rhos = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas) psi = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos) in (ty_co_subst psi role, substTys (lcSubstRight psi) (mkTyCoVarTys exs)) liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion liftCoSubstWith r tvs cos ty = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty -- | @liftCoSubst role lc ty@ produces a coercion (at role @role@) -- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where -- @lc_left@ is a substitution mapping type variables to the left-hand -- types of the mapped coercions in @lc@, and similar for @lc_right@. liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion liftCoSubst r lc@(LC subst env) ty | isEmptyVarEnv env = mkReflCo r (substTy subst ty) | otherwise = ty_co_subst lc r ty emptyLiftingContext :: InScopeSet -> LiftingContext emptyLiftingContext in_scope = LC (mkEmptyTCvSubst in_scope) emptyVarEnv mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext mkLiftingContext pairs = LC (mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) (mkVarEnv pairs) mkSubstLiftingContext :: TCvSubst -> LiftingContext mkSubstLiftingContext subst = LC subst emptyVarEnv -- | Extend a lifting context with a new mapping. extendLiftingContext :: LiftingContext -- ^ original LC -> TyCoVar -- ^ new variable to map... -> Coercion -- ^ ...to this lifted version -> LiftingContext -- mappings to reflexive coercions are just substitutions extendLiftingContext (LC subst env) tv arg | Just (ty, _) <- isReflCo_maybe arg = LC (extendTCvSubst subst tv ty) env | otherwise = LC subst (extendVarEnv env tv arg) -- | Extend a lifting context with a new mapping, and extend the in-scope set extendLiftingContextAndInScope :: LiftingContext -- ^ Original LC -> TyCoVar -- ^ new variable to map... -> Coercion -- ^ to this coercion -> LiftingContext extendLiftingContextAndInScope (LC subst env) tv co = extendLiftingContext (LC (extendTCvInScopeSet subst (tyCoVarsOfCo co)) env) tv co -- | Extend a lifting context with existential-variable bindings. -- See Note [extendLiftingContextEx] extendLiftingContextEx :: LiftingContext -- ^ original lifting context -> [(TyCoVar,Type)] -- ^ ex. var / value pairs -> LiftingContext -- Note that this is more involved than extendLiftingContext. That function -- takes a coercion to extend with, so it's assumed that the caller has taken -- into account any of the kind-changing stuff worried about here. extendLiftingContextEx lc [] = lc extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) -- This function adds bindings for *Nominal* coercions. Why? Because it -- works with existentially bound variables, which are considered to have -- nominal roles. | isTyVar v = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty) (extendVarEnv env v $ mkGReflRightCo Nominal ty (ty_co_subst lc Nominal (tyVarKind v))) in extendLiftingContextEx lc' rest | CoercionTy co <- ty = -- co :: s1 ~r s2 -- lift_s1 :: s1 ~r s1' -- lift_s2 :: s2 ~r s2' -- kco :: (s1 ~r s2) ~N (s1' ~r s2') ASSERT( isCoVar v ) let (_, _, s1, s2, r) = coVarKindsTypesRole v lift_s1 = ty_co_subst lc r s1 lift_s2 = ty_co_subst lc r s2 kco = mkTyConAppCo Nominal (equalityTyCon r) [ mkKindCo lift_s1, mkKindCo lift_s2 , lift_s1 , lift_s2 ] lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfCo co) (extendVarEnv env v (mkProofIrrelCo Nominal kco co $ (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2)) in extendLiftingContextEx lc' rest | otherwise = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty) -- | Erase the environments in a lifting context zapLiftingContext :: LiftingContext -> LiftingContext zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv -- | Like 'substForAllCoBndr', but works on a lifting context substForAllCoBndrUsingLC :: Bool -> (Coercion -> Coercion) -> LiftingContext -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion) substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co = (LC subst' lc_env, tv', co') where (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co -- | The \"lifting\" operation which substitutes coercions for type -- variables in a type to produce a coercion. -- -- For the inverse operation, see 'liftCoMatch' ty_co_subst :: LiftingContext -> Role -> Type -> Coercion ty_co_subst lc role ty = go role ty where go :: Role -> Type -> Coercion go r ty | Just ty' <- coreView ty = go r ty' go Phantom ty = lift_phantom ty go r (TyVarTy tv) = expectJust "ty_co_subst bad roles" $ liftCoSubstTyVar lc r tv go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys) go r (FunTy _ ty1 ty2) = mkFunCo r (go r ty1) (go r ty2) go r t@(ForAllTy (Bndr v _) ty) = let (lc', v', h) = liftCoSubstVarBndr lc v body_co = ty_co_subst lc' r ty in if isTyVar v' || almostDevoidCoVarOfCo v' body_co -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo -- imposes an extra restriction on where a covar can appear. See last -- wrinkle in Note [Unused coercion variable in ForAllCo]. -- We specifically check for this and panic because we know that -- there's a hole in the type system here, and we'd rather panic than -- fall into it. then mkForAllCo v' h body_co else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t) go r ty@(LitTy {}) = ASSERT( r == Nominal ) mkNomReflCo ty go r (CastTy ty co) = castCoercionKindI (go r ty) (substLeftCo lc co) (substRightCo lc co) go r (CoercionTy co) = mkProofIrrelCo r kco (substLeftCo lc co) (substRightCo lc co) where kco = go Nominal (coercionType co) lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty)) (substTy (lcSubstLeft lc) ty) (substTy (lcSubstRight lc) ty) {- Note [liftCoSubstTyVar] ~~~~~~~~~~~~~~~~~~~~~~~~~ This function can fail if a coercion in the environment is of too low a role. liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and also in matchAxiom in OptCoercion. From liftCoSubst, the so-called lifting lemma guarantees that the roles work out. If we fail in this case, we really should panic -- something is deeply wrong. But, in matchAxiom, failing is fine. matchAxiom is trying to find a set of coercions that match, but it may fail, and this is healthy behavior. -} -- See Note [liftCoSubstTyVar] liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion liftCoSubstTyVar (LC subst env) r v | Just co_arg <- lookupVarEnv env v = downgradeRole_maybe r (coercionRole co_arg) co_arg | otherwise = Just $ mkReflCo r (substTyVar subst v) {- Note [liftCoSubstVarBndr] callback: We want 'liftCoSubstVarBndrUsing' to be general enough to be reused in FamInstEnv, therefore the input arg 'fun' returns a pair with polymophic type in snd. However in 'liftCoSubstVarBndr', we don't need the snd, so we use unit and ignore the fourth component of the return value. liftCoSubstTyVarBndrUsing: Given forall tv:k. t We want to get forall (tv:k1) (kind_co :: k1 ~ k2) body_co We lift the kind k to get the kind_co kind_co = ty_co_subst k :: k1 ~ k2 Now in the LiftingContext, we add the new mapping tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2) liftCoSubstCoVarBndrUsing: Given forall cv:(s1 ~ s2). t We want to get forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co We lift s1 and s2 respectively to get eta1 :: s1' ~ t1 eta2 :: s2' ~ t2 And kind_co = TyConAppCo Nominal (~#) eta1 eta2 Now in the liftingContext, we add the new mapping cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2) -} -- See Note [liftCoSubstVarBndr] liftCoSubstVarBndr :: LiftingContext -> TyCoVar -> (LiftingContext, TyCoVar, Coercion) liftCoSubstVarBndr lc tv = let (lc', tv', h, _) = liftCoSubstVarBndrUsing callback lc tv in (lc', tv', h) where callback lc' ty' = (ty_co_subst lc' Nominal ty', ()) -- the callback must produce a nominal coercion liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) -> LiftingContext -> TyCoVar -> (LiftingContext, TyCoVar, CoercionN, a) liftCoSubstVarBndrUsing fun lc old_var | isTyVar old_var = liftCoSubstTyVarBndrUsing fun lc old_var | otherwise = liftCoSubstCoVarBndrUsing fun lc old_var -- Works for tyvar binder liftCoSubstTyVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) -> LiftingContext -> TyVar -> (LiftingContext, TyVar, CoercionN, a) liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var = ASSERT( isTyVar old_var ) ( LC (subst `extendTCvInScope` new_var) new_cenv , new_var, eta, stuff ) where old_kind = tyVarKind old_var (eta, stuff) = fun lc old_kind Pair k1 _ = coercionKind eta new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta -- :: new_var ~ new_var |> eta new_cenv = extendVarEnv cenv old_var lifted -- Works for covar binder liftCoSubstCoVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) -> LiftingContext -> CoVar -> (LiftingContext, CoVar, CoercionN, a) liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var = ASSERT( isCoVar old_var ) ( LC (subst `extendTCvInScope` new_var) new_cenv , new_var, kind_co, stuff ) where old_kind = coVarKind old_var (eta, stuff) = fun lc old_kind Pair k1 _ = coercionKind eta new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) -- old_var :: s1 ~r s2 -- eta :: (s1' ~r s2') ~N (t1 ~r t2) -- eta1 :: s1' ~r t1 -- eta2 :: s2' ~r t2 -- co1 :: s1' ~r s2' -- co2 :: t1 ~r t2 -- kind_co :: (s1' ~r s2') ~N (t1 ~r t2) -- lifted :: co1 ~N co2 role = coVarRole old_var eta' = downgradeRole role Nominal eta eta1 = mkNthCo role 2 eta' eta2 = mkNthCo role 3 eta' co1 = mkCoVarCo new_var co2 = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2 kind_co = mkTyConAppCo Nominal (equalityTyCon role) [ mkKindCo co1, mkKindCo co2 , co1 , co2 ] lifted = mkProofIrrelCo Nominal kind_co co1 co2 new_cenv = extendVarEnv cenv old_var lifted -- | Is a var in the domain of a lifting context? isMappedByLC :: TyCoVar -> LiftingContext -> Bool isMappedByLC tv (LC _ env) = tv `elemVarEnv` env -- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1 -- If [a |-> (g1, g2)] is in the substitution, substitute a for g1 substLeftCo :: LiftingContext -> Coercion -> Coercion substLeftCo lc co = substCo (lcSubstLeft lc) co -- Ditto, but for t2 and g2 substRightCo :: LiftingContext -> Coercion -> Coercion substRightCo lc co = substCo (lcSubstRight lc) co -- | Apply "sym" to all coercions in a 'LiftCoEnv' swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv swapLiftCoEnv = mapVarEnv mkSymCo lcSubstLeft :: LiftingContext -> TCvSubst lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env lcSubstRight :: LiftingContext -> TCvSubst lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst liftEnvSubstLeft = liftEnvSubst pFst liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst liftEnvSubstRight = liftEnvSubst pSnd liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst liftEnvSubst selector subst lc_env = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst where pairs = nonDetUFMToList lc_env -- It's OK to use nonDetUFMToList here because we -- immediately forget the ordering by creating -- a VarEnv (tpairs, cpairs) = partitionWith ty_or_co pairs tenv = mkVarEnv_Directly tpairs cenv = mkVarEnv_Directly cpairs ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion) ty_or_co (u, co) | Just equality_co <- isCoercionTy_maybe equality_ty = Right (u, equality_co) | otherwise = Left (u, equality_ty) where equality_ty = selector (coercionKind co) -- | Extract the underlying substitution from the LiftingContext lcTCvSubst :: LiftingContext -> TCvSubst lcTCvSubst (LC subst _) = subst -- | Get the 'InScopeSet' from a 'LiftingContext' lcInScopeSet :: LiftingContext -> InScopeSet lcInScopeSet (LC subst _) = getTCvInScope subst {- %************************************************************************ %* * Sequencing on coercions %* * %************************************************************************ -} seqMCo :: MCoercion -> () seqMCo MRefl = () seqMCo (MCo co) = seqCo co seqCo :: Coercion -> () seqCo (Refl ty) = seqType ty seqCo (GRefl r ty mco) = r `seq` seqType ty `seq` seqMCo mco seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 seqCo (ForAllCo tv k co) = seqType (varType tv) `seq` seqCo k `seq` seqCo co seqCo (FunCo r co1 co2) = r `seq` seqCo co1 `seq` seqCo co2 seqCo (CoVarCo cv) = cv `seq` () seqCo (HoleCo h) = coHoleCoVar h `seq` () seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos seqCo (UnivCo p r t1 t2) = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2 seqCo (SymCo co) = seqCo co seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 seqCo (NthCo r n co) = r `seq` n `seq` seqCo co seqCo (LRCo lr co) = lr `seq` seqCo co seqCo (InstCo co arg) = seqCo co `seq` seqCo arg seqCo (KindCo co) = seqCo co seqCo (SubCo co) = seqCo co seqCo (AxiomRuleCo _ cs) = seqCos cs seqProv :: UnivCoProvenance -> () seqProv UnsafeCoerceProv = () seqProv (PhantomProv co) = seqCo co seqProv (ProofIrrelProv co) = seqCo co seqProv (PluginProv _) = () seqCos :: [Coercion] -> () seqCos [] = () seqCos (co:cos) = seqCo co `seq` seqCos cos {- %************************************************************************ %* * The kind of a type, and of a coercion %* * %************************************************************************ -} coercionType :: Coercion -> Type coercionType co = case coercionKindRole co of (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 ------------------ -- | If it is the case that -- -- > c :: (t1 ~ t2) -- -- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@. coercionKind :: Coercion -> Pair Type coercionKind co = go co where go (Refl ty) = Pair ty ty go (GRefl _ ty MRefl) = Pair ty ty go (GRefl _ ty (MCo co1)) = Pair ty (mkCastTy ty co1) go (TyConAppCo _ tc cos)= mkTyConApp tc <$> (sequenceA $ map go cos) go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar | isGReflCo k_co = mkTyCoInvForAllTy tv1 <$> go co1 -- kind_co always has kind @Type@, thus @isGReflCo@ | otherwise = go_forall empty_subst co where empty_subst = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfCo co) go (FunCo _ co1 co2) = mkVisFunTy <$> go co1 <*> go co2 go (CoVarCo cv) = coVarTypes cv go (HoleCo h) = coVarTypes (coHoleCoVar h) go (AxiomInstCo ax ind cos) | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs , cab_lhs = lhs, cab_rhs = rhs } <- coAxiomNthBranch ax ind , let Pair tycos1 tycos2 = sequenceA (map go cos) (tys1, cotys1) = splitAtList tvs tycos1 (tys2, cotys2) = splitAtList tvs tycos2 cos1 = map stripCoercionTy cotys1 cos2 = map stripCoercionTy cotys2 = ASSERT( cos `equalLength` (tvs ++ cvs) ) -- Invariant of AxiomInstCo: cos should -- exactly saturate the axiom branch Pair (substTyWith tvs tys1 $ substTyWithCoVars cvs cos1 $ mkTyConApp (coAxiomTyCon ax) lhs) (substTyWith tvs tys2 $ substTyWithCoVars cvs cos2 rhs) go (UnivCo _ _ ty1 ty2) = Pair ty1 ty2 go (SymCo co) = swap $ go co go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2) go g@(NthCo _ d co) | Just argss <- traverse tyConAppArgs_maybe tys = ASSERT( and $ (`lengthExceeds` d) <$> argss ) (`getNth` d) <$> argss | d == 0 , Just splits <- traverse splitForAllTy_maybe tys = (tyVarKind . fst) <$> splits | otherwise = pprPanic "coercionKind" (ppr g) where tys = go co go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co go (InstCo aco arg) = go_app aco [arg] go (KindCo co) = typeKind <$> go co go (SubCo co) = go co go (AxiomRuleCo ax cos) = expectJust "coercionKind" $ coaxrProves ax (map go cos) go_app :: Coercion -> [Coercion] -> Pair Type -- Collect up all the arguments and apply all at once -- See Note [Nested InstCos] go_app (InstCo co arg) args = go_app co (arg:args) go_app co args = piResultTys <$> go co <*> (sequenceA $ map go args) go_forall subst (ForAllCo tv1 k_co co) -- See Note [Nested ForAllCos] | isTyVar tv1 = mkInvForAllTy <$> Pair tv1 tv2 <*> go_forall subst' co where Pair _ k2 = go k_co tv2 = setTyVarKind tv1 (substTy subst k2) subst' | isGReflCo k_co = extendTCvInScope subst tv1 -- kind_co always has kind @Type@, thus @isGReflCo@ | otherwise = extendTvSubst (extendTCvInScope subst tv2) tv1 $ TyVarTy tv2 `mkCastTy` mkSymCo k_co go_forall subst (ForAllCo cv1 k_co co) | isCoVar cv1 = mkTyCoInvForAllTy <$> Pair cv1 cv2 <*> go_forall subst' co where Pair _ k2 = go k_co r = coVarRole cv1 eta1 = mkNthCo r 2 (downgradeRole r Nominal k_co) eta2 = mkNthCo r 3 (downgradeRole r Nominal k_co) -- k_co :: (t1 ~r t2) ~N (s1 ~r s2) -- k1 = t1 ~r t2 -- k2 = s1 ~r s2 -- cv1 :: t1 ~r t2 -- cv2 :: s1 ~r s2 -- eta1 :: t1 ~r s1 -- eta2 :: t2 ~r s2 -- n_subst = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2 cv2 = setVarType cv1 (substTy subst k2) n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2) subst' | isReflCo k_co = extendTCvInScope subst cv1 | otherwise = extendCvSubst (extendTCvInScope subst cv2) cv1 n_subst go_forall subst other_co -- when other_co is not a ForAllCo = substTy subst `pLiftSnd` go other_co {- Note [Nested ForAllCos] ~~~~~~~~~~~~~~~~~~~~~~~ Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an co)...) )`. We do not want to perform `n` single-type-variable substitutions over the kind of `co`; rather we want to do one substitution which substitutes for all of `a1`, `a2` ... simultaneously. If we do one at a time we get the performance hole reported in #11735. Solution: gather up the type variables for nested `ForAllCos`, and substitute for them all at once. Remarkably, for #11735 this single change reduces /total/ compile time by a factor of more than ten. -} -- | Apply 'coercionKind' to multiple 'Coercion's coercionKinds :: [Coercion] -> Pair [Type] coercionKinds tys = sequenceA $ map coercionKind tys -- | Get a coercion's kind and role. coercionKindRole :: Coercion -> (Pair Type, Role) coercionKindRole co = (coercionKind co, coercionRole co) -- | Retrieve the role from a coercion. coercionRole :: Coercion -> Role coercionRole = go where go (Refl _) = Nominal go (GRefl r _ _) = r go (TyConAppCo r _ _) = r go (AppCo co1 _) = go co1 go (ForAllCo _ _ co) = go co go (FunCo r _ _) = r go (CoVarCo cv) = coVarRole cv go (HoleCo h) = coVarRole (coHoleCoVar h) go (AxiomInstCo ax _ _) = coAxiomRole ax go (UnivCo _ r _ _) = r go (SymCo co) = go co go (TransCo co1 _co2) = go co1 go (NthCo r _d _co) = r go (LRCo {}) = Nominal go (InstCo co _) = go co go (KindCo {}) = Nominal go (SubCo _) = Representational go (AxiomRuleCo ax _) = coaxrRole ax {- Note [Nested InstCos] ~~~~~~~~~~~~~~~~~~~~~ In #5631 we found that 70% of the entire compilation time was being spent in coercionKind! The reason was that we had (g @ ty1 @ ty2 .. @ ty100) -- The "@s" are InstCos where g :: forall a1 a2 .. a100. phi If we deal with the InstCos one at a time, we'll do this: 1. Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi' 2. Substitute phi'[ ty100/a100 ], a single tyvar->type subst But this is a *quadratic* algorithm, and the blew up #5631. So it's very important to do the substitution simultaneously; cf Type.piResultTys (which in fact we call here). -} -- | Makes a coercion type from two types: the types whose equality -- is proven by the relevant 'Coercion' mkCoercionType :: Role -> Type -> Type -> Type mkCoercionType Nominal = mkPrimEqPred mkCoercionType Representational = mkReprPrimEqPred mkCoercionType Phantom = \ty1 ty2 -> let ki1 = typeKind ty1 ki2 = typeKind ty2 in TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type mkHeteroCoercionType Nominal = mkHeteroPrimEqPred mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred mkHeteroCoercionType Phantom = panic "mkHeteroCoercionType" -- | Creates a primitive type equality predicate. -- Invariant: the types are not Coercions mkPrimEqPred :: Type -> Type -> Type mkPrimEqPred ty1 ty2 = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] where k1 = typeKind ty1 k2 = typeKind ty2 -- | Makes a lifted equality predicate at the given role mkPrimEqPredRole :: Role -> Type -> Type -> PredType mkPrimEqPredRole Nominal = mkPrimEqPred mkPrimEqPredRole Representational = mkReprPrimEqPred mkPrimEqPredRole Phantom = panic "mkPrimEqPredRole phantom" -- | Creates a primite type equality predicate with explicit kinds mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type mkHeteroPrimEqPred k1 k2 ty1 ty2 = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] -- | Creates a primitive representational type equality predicate -- with explicit kinds mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type mkHeteroReprPrimEqPred k1 k2 ty1 ty2 = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] mkReprPrimEqPred :: Type -> Type -> Type mkReprPrimEqPred ty1 ty2 = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] where k1 = typeKind ty1 k2 = typeKind ty2 -- | Assuming that two types are the same, ignoring coercions, find -- a nominal coercion between the types. This is useful when optimizing -- transitivity over coercion applications, where splitting two -- AppCos might yield different kinds. See Note [EtaAppCo] in OptCoercion. buildCoercion :: Type -> Type -> CoercionN buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 where go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 | Just ty2' <- coreView ty2 = go ty1 ty2' go (CastTy ty1 co) ty2 = let co' = go ty1 ty2 r = coercionRole co' in mkCoherenceLeftCo r ty1 co co' go ty1 (CastTy ty2 co) = let co' = go ty1 ty2 r = coercionRole co' in mkCoherenceRightCo r ty2 co co' go ty1@(TyVarTy tv1) _tyvarty = ASSERT( case _tyvarty of { TyVarTy tv2 -> tv1 == tv2 ; _ -> False } ) mkNomReflCo ty1 go (FunTy { ft_arg = arg1, ft_res = res1 }) (FunTy { ft_arg = arg2, ft_res = res2 }) = mkFunCo Nominal (go arg1 arg2) (go res1 res2) go (TyConApp tc1 args1) (TyConApp tc2 args2) = ASSERT( tc1 == tc2 ) mkTyConAppCo Nominal tc1 (zipWith go args1 args2) go (AppTy ty1a ty1b) ty2 | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2 = mkAppCo (go ty1a ty2a) (go ty1b ty2b) go ty1 (AppTy ty2a ty2b) | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 = mkAppCo (go ty1a ty2a) (go ty1b ty2b) go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2) | isTyVar tv1 = ASSERT( isTyVar tv2 ) mkForAllCo tv1 kind_co (go ty1 ty2') where kind_co = go (tyVarKind tv1) (tyVarKind tv2) in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co ty2' = substTyWithInScope in_scope [tv2] [mkTyVarTy tv1 `mkCastTy` kind_co] ty2 go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2) = ASSERT( isCoVar cv1 && isCoVar cv2 ) mkForAllCo cv1 kind_co (go ty1 ty2') where s1 = varType cv1 s2 = varType cv2 kind_co = go s1 s2 -- s1 = t1 ~r t2 -- s2 = t3 ~r t4 -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4) -- eta1 :: t1 ~r t3 -- eta2 :: t2 ~r t4 r = coVarRole cv1 kind_co' = downgradeRole r Nominal kind_co eta1 = mkNthCo r 2 kind_co' eta2 = mkNthCo r 3 kind_co' subst = mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo` mkCoVarCo cv1 `mkTransCo` eta2) ty2 go ty1@(LitTy lit1) _lit2 = ASSERT( case _lit2 of { LitTy lit2 -> lit1 == lit2 ; _ -> False } ) mkNomReflCo ty1 go (CoercionTy co1) (CoercionTy co2) = mkProofIrrelCo Nominal kind_co co1 co2 where kind_co = go (coercionType co1) (coercionType co2) go ty1 ty2 = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2 , ppr ty1, ppr ty2 ]) {- %************************************************************************ %* * Simplifying types %* * %************************************************************************ The function below morally belongs in TcFlatten, but it is used also in FamInstEnv, and so lives here. Note [simplifyArgsWorker] ~~~~~~~~~~~~~~~~~~~~~~~~~ Invariant (F2) of Note [Flattening] says that flattening is homogeneous. This causes some trouble when flattening a function applied to a telescope of arguments, perhaps with dependency. For example, suppose type family F :: forall (j :: Type) (k :: Type). Maybe j -> Either j k -> Bool -> [k] and we wish to flatten the args of (with kind applications explicit) F a b (Just a c) (Right a b d) False where all variables are skolems and a :: Type b :: Type c :: a d :: k [G] aco :: a ~ fa [G] bco :: b ~ fb [G] cco :: c ~ fc [G] dco :: d ~ fd The first step is to flatten all the arguments. This is done before calling simplifyArgsWorker. We start from a b Just a c Right a b d False and get (fa, co1 :: fa ~ a) (fb, co2 :: fb ~ b) (Just fa (fc |> aco) |> co6, co3 :: (Just fa (fc |> aco) |> co6) ~ (Just a c)) (Right fa fb (fd |> bco) |> co7, co4 :: (Right fa fb (fd |> bco) |> co7) ~ (Right a b d)) (False, co5 :: False ~ False) where co6 :: Maybe fa ~ Maybe a co7 :: Either fa fb ~ Either a b We now process the flattened args in left-to-right order. The first two args need no further processing. But now consider the third argument. Let f3 = the flattened result, Just fa (fc |> aco) |> co6. This f3 flattened argument has kind (Maybe a), due to (F2). And yet, when we build the application (F fa fb ...), we need this argument to have kind (Maybe fa), not (Maybe a). We must cast this argument. The coercion to use is determined by the kind of F: we see in F's kind that the third argument has kind Maybe j. Critically, we also know that the argument corresponding to j (in our example, a) flattened with a coercion co1. We can thus know the coercion needed for the 3rd argument is (Maybe (sym co1)), thus building (f3 |> Maybe (sym co1)) More generally, we must use the Lifting Lemma, as implemented in Coercion.liftCoSubst. As we work left-to-right, any variable that is a dependent parameter (j and k, in our example) gets mapped in a lifting context to the coercion that is output from flattening the corresponding argument (co1 and co2, in our example). Then, after flattening later arguments, we lift the kind of these arguments in the lifting context that we've be building up. This coercion is then used to keep the result of flattening well-kinded. Working through our example, this is what happens: 1. Extend the (empty) LC with [j |-> co1]. No new casting must be done, because the binder associated with the first argument has a closed type (no variables). 2. Extend the LC with [k |-> co2]. No casting to do. 3. Lifting the kind (Maybe j) with our LC yields co8 :: Maybe fa ~ Maybe a. Use (f3 |> sym co8) as the argument to F. 4. Lifting the kind (Either j k) with our LC yields co9 :: Either fa fb ~ Either a b. Use (f4 |> sym co9) as the 4th argument to F, where f4 is the flattened form of argument 4, written above. 5. We lift Bool with our LC, getting ; casting has no effect. We're now almost done, but the new application (F fa fb (f3 |> sym co8) (f4 > sym co9) False) has the wrong kind. Its kind is [fb], instead of the original [b]. So we must use our LC one last time to lift the result kind [k], getting res_co :: [fb] ~ [b], and we cast our result. Accordingly, the final result is F fa fb (Just fa (fc |> aco) |> Maybe (sym aco) |> sym (Maybe (sym aco))) (Right fa fb (fd |> bco) |> Either (sym aco) (sym bco) |> sym (Either (sym aco) (sym bco))) False |> [sym bco] The res_co (in this case, [sym bco]) is returned as the third return value from simplifyArgsWorker. Note [Last case in simplifyArgsWorker] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In writing simplifyArgsWorker's `go`, we know here that args cannot be empty, because that case is first. We've run out of binders. But perhaps inner_ki is a tyvar that has been instantiated with a Π-type. Here is an example. a :: forall (k :: Type). k -> k type family Star Proxy :: forall j. j -> Type axStar :: Star ~ Type type family NoWay :: Bool axNoWay :: NoWay ~ False bo :: Type [G] bc :: bo ~ Bool (in inert set) co :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star) co = forall (j :: sym axStar). ( -> sym axStar) We are flattening: a (forall (j :: Star). (j |> axStar) -> Star) -- 1 (Proxy |> co) -- 2 (bo |> sym axStar) -- 3 (NoWay |> sym bc) -- 4 :: Star First, we flatten all the arguments (before simplifyArgsWorker), like so: (forall j. j -> Type, co1 :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star)) -- 1 (Proxy |> co, co2 :: (Proxy |> co) ~ (Proxy |> co)) -- 2 (Bool |> sym axStar, co3 :: (Bool |> sym axStar) ~ (bo |> sym axStar)) -- 3 (False |> sym bc, co4 :: (False |> sym bc) ~ (NoWay |> sym bc)) -- 4 Then we do the process described in Note [simplifyArgsWorker]. 1. Lifting Type (the kind of the first arg) gives us a reflexive coercion, so we don't use it. But we do build a lifting context [k -> co1] (where co1 is a result of flattening an argument, written above). 2. Lifting k gives us co1, so the second argument becomes (Proxy |> co |> sym co1). This is not a dependent argument, so we don't extend the lifting context. Now we need to deal with argument (3). The way we normally proceed is to lift the kind of the binder, to see whether it's dependent. But here, the remainder of the kind of `a` that we're left with after processing two arguments is just `k`. The way forward is look up k in the lifting context, getting co1. If we're at all well-typed, co1 will be a coercion between Π-types, with at least one binder. So, let's decompose co1 with decomposePiCos. This decomposition needs arguments to use to instantiate any kind parameters. Look at the type of co1. If we just decomposed it, we would end up with coercions whose types include j, which is out of scope here. Accordingly, decomposePiCos takes a list of types whose kinds are the *right-hand* types in the decomposed coercion. (See comments on decomposePiCos.) Because the flattened types have unflattened kinds (because flattening is homogeneous), passing the list of flattened types to decomposePiCos just won't do: later arguments' kinds won't be as expected. So we need to get the *unflattened* types to pass to decomposePiCos. We can do this easily enough by taking the kind of the argument coercions, passed in originally. (Alternative 1: We could re-engineer decomposePiCos to deal with this situation. But that function is already gnarly, and taking the right-hand types is correct at its other call sites, which are much more common than this one.) (Alternative 2: We could avoid calling decomposePiCos entirely, integrating its behavior into simplifyArgsWorker. This would work, I think, but then all of the complication of decomposePiCos would end up layered on top of all the complication here. Please, no.) (Alternative 3: We could pass the unflattened arguments into simplifyArgsWorker so that we don't have to recreate them. But that would complicate the interface of this function to handle a very dark, dark corner case. Better to keep our demons to ourselves here instead of exposing them to callers. This decision is easily reversed if there is ever any performance trouble due to the call of coercionKind.) So we now call decomposePiCos co1 (Pair (forall j. j -> Type) (forall (j :: Star). (j |> axStar) -> Star)) [bo |> sym axStar, NoWay |> sym bc] to get co5 :: Star ~ Type co6 :: (j |> axStar) ~ (j |> co5), substituted to (bo |> sym axStar |> axStar) ~ (bo |> sym axStar |> co5) == bo ~ bo res_co :: Type ~ Star We then use these casts on (the flattened) (3) and (4) to get (Bool |> sym axStar |> co5 :: Type) -- (C3) (False |> sym bc |> co6 :: bo) -- (C4) We can simplify to Bool -- (C3) (False |> sym bc :: bo) -- (C4) Of course, we still must do the processing in Note [simplifyArgsWorker] to finish the job. We thus want to recur. Our new function kind is the left-hand type of co1 (gotten, recall, by lifting the variable k that was the return kind of the original function). Why the left-hand type (as opposed to the right-hand type)? Because we have casted all the arguments according to decomposePiCos, which gets us from the right-hand type to the left-hand one. We thus recur with that new function kind, zapping our lifting context, because we have essentially applied it. This recursive call returns ([Bool, False], [...], Refl). The Bool and False are the correct arguments we wish to return. But we must be careful about the result coercion: our new, flattened application will have kind Type, but we want to make sure that the result coercion casts this back to Star. (Why? Because we started with an application of kind Star, and flattening is homogeneous.) So, we have to twiddle the result coercion appropriately. Let's check whether this is well-typed. We know a :: forall (k :: Type). k -> k a (forall j. j -> Type) :: (forall j. j -> Type) -> forall j. j -> Type a (forall j. j -> Type) Proxy :: forall j. j -> Type a (forall j. j -> Type) Proxy Bool :: Bool -> Type a (forall j. j -> Type) Proxy Bool False :: Type a (forall j. j -> Type) Proxy Bool False |> res_co :: Star as desired. Whew. Historical note: I (Richard E) once thought that the final part of the kind had to be a variable k (as in the example above). But it might not be: it could be an application of a variable. Here is the example: let f :: forall (a :: Type) (b :: a -> Type). b (Any @a) k :: Type x :: k flatten (f @Type @((->) k) x) After instantiating [a |-> Type, b |-> ((->) k)], we see that `b (Any @a)` is `k -> Any @a`, and thus the third argument of `x :: k` is well-kinded. -} -- This is shared between the flattener and the normaliser in FamInstEnv. -- See Note [simplifyArgsWorker] {-# INLINE simplifyArgsWorker #-} simplifyArgsWorker :: [TyCoBinder] -> Kind -- the binders & result kind (not a Π-type) of the function applied to the args -- list of binders can be shorter or longer than the list of args -> TyCoVarSet -- free vars of the args -> [Role] -- list of roles, r -> [(Type, Coercion)] -- flattened type arguments, arg -- each comes with the coercion used to flatten it, -- with co :: flattened_type ~ original_type -> ([Type], [Coercion], CoercionN) -- Returns (xis, cos, res_co), where each co :: xi ~ arg, -- and res_co :: kind (f xis) ~ kind (f tys), where f is the function applied to the args -- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in), -- then (f orig_tys) is well kinded. Note that (f flattened_tys) might *not* be well-kinded. -- Massaging the flattened_tys in order to make (f flattened_tys) well-kinded is what this -- function is all about. That is, (f xis), where xis are the returned arguments, *is* -- well kinded. simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs orig_roles orig_simplified_args = go [] [] orig_lc orig_ki_binders orig_inner_ki orig_roles orig_simplified_args where orig_lc = emptyLiftingContext $ mkInScopeSet $ orig_fvs go :: [Type] -- Xis accumulator, in reverse order -> [Coercion] -- Coercions accumulator, in reverse order -- These are in 1-to-1 correspondence -> LiftingContext -- mapping from tyvars to flattening coercions -> [TyCoBinder] -- Unsubsted binders of function's kind -> Kind -- Unsubsted result kind of function (not a Pi-type) -> [Role] -- Roles at which to flatten these ... -> [(Type, Coercion)] -- flattened arguments, with their flattening coercions -> ([Type], [Coercion], CoercionN) go acc_xis acc_cos lc binders inner_ki _ [] = (reverse acc_xis, reverse acc_cos, kind_co) where final_kind = mkPiTys binders inner_ki kind_co = liftCoSubst Nominal lc final_kind go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) ((xi,co):args) = -- By Note [Flattening] in TcFlatten invariant (F2), -- tcTypeKind(xi) = tcTypeKind(ty). But, it's possible that xi will be -- used as an argument to a function whose kind is different, if -- earlier arguments have been flattened to new types. We thus -- need a coercion (kind_co :: old_kind ~ new_kind). -- -- The bangs here have been observed to improve performance -- significantly in optimized builds. let kind_co = mkSymCo $ liftCoSubst Nominal lc (tyCoBinderType binder) !casted_xi = xi `mkCastTy` kind_co casted_co = mkCoherenceLeftCo role xi kind_co co -- now, extend the lifting context with the new binding !new_lc | Just tv <- tyCoBinderVar_maybe binder = extendLiftingContextAndInScope lc tv casted_co | otherwise = lc in go (casted_xi : acc_xis) (casted_co : acc_cos) new_lc binders inner_ki roles args -- See Note [Last case in simplifyArgsWorker] go acc_xis acc_cos lc [] inner_ki roles args = let co1 = liftCoSubst Nominal lc inner_ki co1_kind = coercionKind co1 unflattened_tys = map (pSnd . coercionKind . snd) args (arg_cos, res_co) = decomposePiCos co1 co1_kind unflattened_tys casted_args = ASSERT2( equalLength args arg_cos , ppr args $$ ppr arg_cos ) [ (casted_xi, casted_co) | ((xi, co), arg_co, role) <- zip3 args arg_cos roles , let casted_xi = xi `mkCastTy` arg_co casted_co = mkCoherenceLeftCo role xi arg_co co ] -- In general decomposePiCos can return fewer cos than tys, -- but not here; because we're well typed, there will be enough -- binders. Note that decomposePiCos does substitutions, so even -- if the original substitution results in something ending with -- ... -> k, that k will be substituted to perhaps reveal more -- binders. zapped_lc = zapLiftingContext lc Pair flattened_kind _ = co1_kind (bndrs, new_inner) = splitPiTys flattened_kind (xis_out, cos_out, res_co_out) = go acc_xis acc_cos zapped_lc bndrs new_inner roles casted_args in (xis_out, cos_out, res_co_out `mkTransCo` res_co) go _ _ _ _ _ _ _ = panic "simplifyArgsWorker wandered into deeper water than usual" -- This debug information is commented out because leaving it in -- causes a ~2% increase in allocations in T9872d. -- That's independent of the analagous case in flatten_args_fast -- in TcFlatten: -- each of these causes a 2% increase on its own, so commenting them -- both out gives a 4% decrease in T9872d. {- (vcat [ppr orig_binders, ppr orig_inner_ki, ppr (take 10 orig_roles), -- often infinite! ppr orig_tys]) -} ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/ConLike.hs0000644000000000000000000001533613713635744021316 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1998 \section[ConLike]{@ConLike@: Constructor-like things} -} {-# LANGUAGE CPP #-} module ConLike ( ConLike(..) , conLikeArity , conLikeFieldLabels , conLikeInstOrigArgTys , conLikeExTyCoVars , conLikeName , conLikeStupidTheta , conLikeWrapId_maybe , conLikeImplBangs , conLikeFullSig , conLikeResTy , conLikeFieldType , conLikesWithFields , conLikeIsInfix ) where #include "GhclibHsVersions.h" import GhcPrelude import DataCon import PatSyn import Outputable import Unique import Util import Name import BasicTypes import TyCoRep (Type, ThetaType) import Var import Type (mkTyConApp) import qualified Data.Data as Data {- ************************************************************************ * * \subsection{Constructor-like things} * * ************************************************************************ -} -- | A constructor-like thing data ConLike = RealDataCon DataCon | PatSynCon PatSyn {- ************************************************************************ * * \subsection{Instances} * * ************************************************************************ -} instance Eq ConLike where (==) = eqConLike eqConLike :: ConLike -> ConLike -> Bool eqConLike x y = getUnique x == getUnique y -- There used to be an Ord ConLike instance here that used Unique for ordering. -- It was intentionally removed to prevent determinism problems. -- See Note [Unique Determinism] in Unique. instance Uniquable ConLike where getUnique (RealDataCon dc) = getUnique dc getUnique (PatSynCon ps) = getUnique ps instance NamedThing ConLike where getName (RealDataCon dc) = getName dc getName (PatSynCon ps) = getName ps instance Outputable ConLike where ppr (RealDataCon dc) = ppr dc ppr (PatSynCon ps) = ppr ps instance OutputableBndr ConLike where pprInfixOcc (RealDataCon dc) = pprInfixOcc dc pprInfixOcc (PatSynCon ps) = pprInfixOcc ps pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps instance Data.Data ConLike where -- don't traverse? toConstr _ = abstractConstr "ConLike" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "ConLike" -- | Number of arguments conLikeArity :: ConLike -> Arity conLikeArity (RealDataCon data_con) = dataConSourceArity data_con conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn -- | Names of fields used for selectors conLikeFieldLabels :: ConLike -> [FieldLabel] conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn -- | Returns just the instantiated /value/ argument types of a 'ConLike', -- (excluding dictionary args) conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type] conLikeInstOrigArgTys (RealDataCon data_con) tys = dataConInstOrigArgTys data_con tys conLikeInstOrigArgTys (PatSynCon pat_syn) tys = patSynInstArgTys pat_syn tys -- | Existentially quantified type/coercion variables conLikeExTyCoVars :: ConLike -> [TyCoVar] conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1 conLikeExTyCoVars (PatSynCon psyn1) = patSynExTyVars psyn1 conLikeName :: ConLike -> Name conLikeName (RealDataCon data_con) = dataConName data_con conLikeName (PatSynCon pat_syn) = patSynName pat_syn -- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in: -- -- > data Eq a => T a = ... -- It is empty for `PatSynCon` as they do not allow such contexts. conLikeStupidTheta :: ConLike -> ThetaType conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con conLikeStupidTheta (PatSynCon {}) = [] -- | Returns the `Id` of the wrapper. This is also known as the builder in -- some contexts. The value is Nothing only in the case of unidirectional -- pattern synonyms. conLikeWrapId_maybe :: ConLike -> Maybe Id conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con conLikeWrapId_maybe (PatSynCon pat_syn) = fst <$> patSynBuilder pat_syn -- | Returns the strictness information for each constructor conLikeImplBangs :: ConLike -> [HsImplBang] conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con conLikeImplBangs (PatSynCon pat_syn) = replicate (patSynArity pat_syn) HsLazy -- | Returns the type of the whole pattern conLikeResTy :: ConLike -> [Type] -> Type conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys -- | The \"full signature\" of the 'ConLike' returns, in order: -- -- 1) The universally quantified type variables -- -- 2) The existentially quantified type/coercion variables -- -- 3) The equality specification -- -- 4) The provided theta (the constraints provided by a match) -- -- 5) The required theta (the constraints required for a match) -- -- 6) The original argument types (i.e. before -- any change of the representation of the type) -- -- 7) The original result type conLikeFullSig :: ConLike -> ([TyVar], [TyCoVar], [EqSpec] -- Why tyvars for universal but tycovars for existential? -- See Note [Existential coercion variables] in DataCon , ThetaType, ThetaType, [Type], Type) conLikeFullSig (RealDataCon con) = let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con -- Required theta is empty as normal data cons require no additional -- constraints for a match in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty) conLikeFullSig (PatSynCon pat_syn) = let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn -- eqSpec is empty in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty) -- | Extract the type for any given labelled field of the 'ConLike' conLikeFieldType :: ConLike -> FieldLabelString -> Type conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label -- | The ConLikes that have *all* the given fields conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike] conLikesWithFields con_likes lbls = filter has_flds con_likes where has_flds dc = all (has_fld dc) lbls has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc) conLikeIsInfix :: ConLike -> Bool conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/Config.hs0000644000000000000000000000113013713636006022633 0ustar0000000000000000{-# LANGUAGE CPP #-} module Config ( module GHC.Version , cBuildPlatformString , cHostPlatformString , cProjectName , cBooterVersion , cStage ) where import GhcPrelude import GHC.Version cBuildPlatformString :: String cBuildPlatformString = "x86_64-apple-darwin" cHostPlatformString :: String cHostPlatformString = "x86_64-apple-darwin" cProjectName :: String cProjectName = "The Glorious Glasgow Haskell Compilation System" cBooterVersion :: String cBooterVersion = "8.6.5" cStage :: String cStage = show (1 :: Int) ghc-lib-parser-8.10.2.20200808/compiler/main/Constants.hs0000644000000000000000000000202513713635745020554 0ustar0000000000000000{- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[Constants]{Info about this compilation} -} module Constants (module Constants) where import GhcPrelude import Config hiVersion :: Integer hiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer -- All pretty arbitrary: mAX_TUPLE_SIZE :: Int mAX_TUPLE_SIZE = 62 -- Should really match the number -- of decls in Data.Tuple mAX_CTUPLE_SIZE :: Int -- Constraint tuples mAX_CTUPLE_SIZE = 62 -- Should match the number of decls in GHC.Classes mAX_SUM_SIZE :: Int mAX_SUM_SIZE = 62 -- | Default maximum depth for both class instance search and type family -- reduction. See also #5395. mAX_REDUCTION_DEPTH :: Int mAX_REDUCTION_DEPTH = 200 -- | Default maximum constraint-solver iterations -- Typically there should be very few mAX_SOLVER_ITERATIONS :: Int mAX_SOLVER_ITERATIONS = 4 wORD64_SIZE :: Int wORD64_SIZE = 8 -- Size of float in bytes. fLOAT_SIZE :: Int fLOAT_SIZE = 4 tARGET_MAX_CHAR :: Int tARGET_MAX_CHAR = 0x10ffff ghc-lib-parser-8.10.2.20200808/compiler/typecheck/Constraint.hs0000644000000000000000000020710613713635745021766 0ustar0000000000000000{- This module defines types and simple operations over constraints, as used in the type-checker and constraint solver. -} {-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} module Constraint ( -- QCInst QCInst(..), isPendingScInst, -- Canonical constraints Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts, singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, isEmptyCts, isCTyEqCan, isCFunEqCan, isPendingScDict, superClassesMightHelp, getPendingWantedScs, isCDictCan_Maybe, isCFunEqCan_maybe, isCNonCanonical, isWantedCt, isDerivedCt, isGivenCt, isHoleCt, isOutOfScopeCt, isExprHoleCt, isTypeHoleCt, isUserTypeErrorCt, getUserTypeErrorMsg, ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, ctEvId, mkTcEqPredLikeEv, mkNonCanonical, mkNonCanonicalCt, mkGivens, mkIrredCt, mkInsolubleCt, ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel, ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId, tyCoVarsOfCt, tyCoVarsOfCts, tyCoVarsOfCtList, tyCoVarsOfCtsList, WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC, addInsols, insolublesOnly, addSimples, addImplics, tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples, tyCoVarsOfWCList, insolubleCt, insolubleEqCt, isDroppableCt, insolubleImplic, arisesFromGivens, Implication(..), implicationPrototype, ImplicStatus(..), isInsolubleStatus, isSolvedStatus, SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, bumpSubGoalDepth, subGoalDepthExceeded, CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin, ctLocTypeOrKind_maybe, ctLocDepth, bumpCtLocDepth, isGivenLoc, setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan, pprCtLoc, -- CtEvidence CtEvidence(..), TcEvDest(..), mkKindLoc, toKindLoc, mkGivenLoc, isWanted, isGiven, isDerived, isGivenOrWDeriv, ctEvRole, wrapType, wrapTypeWithImplication, CtFlavour(..), ShadowInfo(..), ctEvFlavour, CtFlavourRole, ctEvFlavourRole, ctFlavourRole, eqCanRewrite, eqCanRewriteFR, eqMayRewriteFR, eqCanDischargeFR, funEqCanDischarge, funEqCanDischargeF, -- Pretty printing pprEvVarTheta, pprEvVars, pprEvVarWithType, -- holes Hole(..), holeOcc, ) where #include "GhclibHsVersions.h" import GhcPrelude import {-# SOURCE #-} TcRnTypes ( TcLclEnv, setLclEnvTcLevel, getLclEnvTcLevel , setLclEnvLoc, getLclEnvLoc ) import GHC.Hs.Expr ( UnboundVar(..), unboundVarOcc ) import Predicate import Type import Coercion import Class import TyCon import Var import Id import TcType import TcEvidence import TcOrigin import CoreSyn import TyCoPpr import OccName import FV import VarSet import DynFlags import BasicTypes import Outputable import SrcLoc import Bag import Util import Control.Monad ( msum ) {- ************************************************************************ * * * Canonical constraints * * * * These are the constraints the low-level simplifier works with * * * ************************************************************************ -} -- The syntax of xi (ξ) types: -- xi ::= a | T xis | xis -> xis | ... | forall a. tau -- Two important notes: -- (i) No type families, unless we are under a ForAll -- (ii) Note that xi types can contain unexpanded type synonyms; -- however, the (transitive) expansions of those type synonyms -- will not contain any type functions, unless we are under a ForAll. -- We enforce the structure of Xi types when we flatten (TcCanonical) type Xi = Type -- In many comments, "xi" ranges over Xi type Cts = Bag Ct data Ct -- Atomic canonical constraints = CDictCan { -- e.g. Num xi cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_class :: Class, cc_tyargs :: [Xi], -- cc_tyargs are function-free, hence Xi cc_pend_sc :: Bool -- See Note [The superclass story] in TcCanonical -- True <=> (a) cc_class has superclasses -- (b) we have not (yet) added those -- superclasses as Givens } | CIrredCan { -- These stand for yet-unusable predicates cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_insol :: Bool -- True <=> definitely an error, can never be solved -- False <=> might be soluble -- For the might-be-soluble case, the ctev_pred of the evidence is -- of form (tv xi1 xi2 ... xin) with a tyvar at the head -- or (tv1 ~ ty2) where the CTyEqCan kind invariant fails -- or (F tys ~ ty) where the CFunEqCan kind invariant fails -- See Note [CIrredCan constraints] -- The definitely-insoluble case is for things like -- Int ~ Bool tycons don't match -- a ~ [a] occurs check } | CTyEqCan { -- tv ~ rhs -- Invariants: -- * See Note [inert_eqs: the inert equalities] in TcSMonad -- * tv not in tvs(rhs) (occurs check) -- * If tv is a TauTv, then rhs has no foralls -- (this avoids substituting a forall for the tyvar in other types) -- * tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant] -- * rhs may have at most one top-level cast -- * rhs (perhaps under the one cast) is *almost function-free*, -- See Note [Almost function-free] -- * If the equality is representational, rhs has no top-level newtype -- See Note [No top-level newtypes on RHS of representational -- equalities] in TcCanonical -- * If rhs (perhaps under the cast) is also a tv, then it is oriented -- to give best chance of -- unification happening; eg if rhs is touchable then lhs is too cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_tyvar :: TcTyVar, cc_rhs :: TcType, -- Not necessarily function-free (hence not Xi) -- See invariants above cc_eq_rel :: EqRel -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev } | CFunEqCan { -- F xis ~ fsk -- Invariants: -- * isTypeFamilyTyCon cc_fun -- * tcTypeKind (F xis) = tyVarKind fsk; Note [Ct kind invariant] -- * always Nominal role cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_fun :: TyCon, -- A type function cc_tyargs :: [Xi], -- cc_tyargs are function-free (hence Xi) -- Either under-saturated or exactly saturated -- *never* over-saturated (because if so -- we should have decomposed) cc_fsk :: TcTyVar -- [G] always a FlatSkolTv -- [W], [WD], or [D] always a FlatMetaTv -- See Note [The flattening story] in TcFlatten } | CNonCanonical { -- See Note [NonCanonical Semantics] in TcSMonad cc_ev :: CtEvidence } | CHoleCan { -- See Note [Hole constraints] -- Treated as an "insoluble" constraint -- See Note [Insoluble constraints] cc_ev :: CtEvidence, cc_hole :: Hole } | CQuantCan QCInst -- A quantified constraint -- NB: I expect to make more of the cases in Ct -- look like this, with the payload in an -- auxiliary type ------------ data QCInst -- A much simplified version of ClsInst -- See Note [Quantified constraints] in TcCanonical = QCI { qci_ev :: CtEvidence -- Always of type forall tvs. context => ty -- Always Given , qci_tvs :: [TcTyVar] -- The tvs , qci_pred :: TcPredType -- The ty , qci_pend_sc :: Bool -- Same as cc_pend_sc flag in CDictCan -- Invariant: True => qci_pred is a ClassPred } instance Outputable QCInst where ppr (QCI { qci_ev = ev }) = ppr ev ------------ -- | An expression or type hole data Hole = ExprHole UnboundVar -- ^ Either an out-of-scope variable or a "true" hole in an -- expression (TypedHoles) | TypeHole OccName -- ^ A hole in a type (PartialTypeSignatures) instance Outputable Hole where ppr (ExprHole ub) = ppr ub ppr (TypeHole occ) = text "TypeHole" <> parens (ppr occ) holeOcc :: Hole -> OccName holeOcc (ExprHole uv) = unboundVarOcc uv holeOcc (TypeHole occ) = occ {- Note [Hole constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~ CHoleCan constraints are used for two kinds of holes, distinguished by cc_hole: * For holes in expressions (includings variables not in scope) e.g. f x = g _ x * For holes in type signatures e.g. f :: _ -> _ f x = [x,True] Note [CIrredCan constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ CIrredCan constraints are used for constraints that are "stuck" - we can't solve them (yet) - we can't use them to solve other constraints - but they may become soluble if we substitute for some of the type variables in the constraint Example 1: (c Int), where c :: * -> Constraint. We can't do anything with this yet, but if later c := Num, *then* we can solve it Example 2: a ~ b, where a :: *, b :: k, where k is a kind variable We don't want to use this to substitute 'b' for 'a', in case 'k' is subsequently unifed with (say) *->*, because then we'd have ill-kinded types floating about. Rather we want to defer using the equality altogether until 'k' get resolved. Note [Ct/evidence invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field of (cc_ev ct), and is fully rewritten wrt the substitution. Eg for CDictCan, ctev_pred (cc_ev ct) = (cc_class ct) (cc_tyargs ct) This holds by construction; look at the unique place where CDictCan is built (in TcCanonical). In contrast, the type of the evidence *term* (ctev_dest / ctev_evar) in the evidence may *not* be fully zonked; we are careful not to look at it during constraint solving. See Note [Evidence field of CtEvidence]. Note [Ct kind invariant] ~~~~~~~~~~~~~~~~~~~~~~~~ CTyEqCan and CFunEqCan both require that the kind of the lhs matches the kind of the rhs. This is necessary because both constraints are used for substitutions during solving. If the kinds differed, then the substitution would take a well-kinded type to an ill-kinded one. Note [Almost function-free] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ A type is *almost function-free* if it has no type functions (something that responds True to isTypeFamilyTyCon), except (possibly) * under a forall, or * in a coercion (either in a CastTy or a CercionTy) The RHS of a CTyEqCan must be almost function-free. This is for two reasons: 1. There cannot be a top-level function. If there were, the equality should really be a CFunEqCan, not a CTyEqCan. 2. Nested functions aren't too bad, on the other hand. However, consider this scenario: type family F a = r | r -> a [D] F ty1 ~ fsk1 [D] F ty2 ~ fsk2 [D] fsk1 ~ [G Int] [D] fsk2 ~ [G Bool] type instance G Int = Char type instance G Bool = Char If it was the case that fsk1 = fsk2, then we could unifty ty1 and ty2 -- good! They don't look equal -- but if we aggressively reduce that G Int and G Bool they would become equal. The "almost function free" makes sure that these redexes are exposed. Note that this equality does *not* depend on casts or coercions, and so skipping these forms is OK. In addition, the result of a type family cannot be a polytype, so skipping foralls is OK, too. We skip foralls because we want the output of the flattener to be almost function-free. See Note [Flattening under a forall] in TcFlatten. As I (Richard E) write this, it is unclear if the scenario pictured above can happen -- I would expect the G Int and G Bool to be reduced. But perhaps it can arise somehow, and maintaining almost function-free is cheap. Historical note: CTyEqCans used to require only condition (1) above: that no type family was at the top of an RHS. But work on #16512 suggested that the injectivity checks were not complete, and adding the requirement that functions do not appear even in a nested fashion was easy (it was already true, but unenforced). The almost-function-free property is checked by isAlmostFunctionFree in TcType. The flattener (in TcFlatten) produces types that are almost function-free. -} mkNonCanonical :: CtEvidence -> Ct mkNonCanonical ev = CNonCanonical { cc_ev = ev } mkNonCanonicalCt :: Ct -> Ct mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct } mkIrredCt :: CtEvidence -> Ct mkIrredCt ev = CIrredCan { cc_ev = ev, cc_insol = False } mkInsolubleCt :: CtEvidence -> Ct mkInsolubleCt ev = CIrredCan { cc_ev = ev, cc_insol = True } mkGivens :: CtLoc -> [EvId] -> [Ct] mkGivens loc ev_ids = map mk ev_ids where mk ev_id = mkNonCanonical (CtGiven { ctev_evar = ev_id , ctev_pred = evVarPred ev_id , ctev_loc = loc }) ctEvidence :: Ct -> CtEvidence ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev ctEvidence ct = cc_ev ct ctLoc :: Ct -> CtLoc ctLoc = ctEvLoc . ctEvidence setCtLoc :: Ct -> CtLoc -> Ct setCtLoc ct loc = ct { cc_ev = (cc_ev ct) { ctev_loc = loc } } ctOrigin :: Ct -> CtOrigin ctOrigin = ctLocOrigin . ctLoc ctPred :: Ct -> PredType -- See Note [Ct/evidence invariant] ctPred ct = ctEvPred (ctEvidence ct) ctEvId :: Ct -> EvVar -- The evidence Id for this Ct ctEvId ct = ctEvEvId (ctEvidence ct) -- | Makes a new equality predicate with the same role as the given -- evidence. mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType mkTcEqPredLikeEv ev = case predTypeEqRel pred of NomEq -> mkPrimEqPred ReprEq -> mkReprPrimEqPred where pred = ctEvPred ev -- | Get the flavour of the given 'Ct' ctFlavour :: Ct -> CtFlavour ctFlavour = ctEvFlavour . ctEvidence -- | Get the equality relation for the given 'Ct' ctEqRel :: Ct -> EqRel ctEqRel = ctEvEqRel . ctEvidence instance Outputable Ct where ppr ct = ppr (ctEvidence ct) <+> parens pp_sort where pp_sort = case ct of CTyEqCan {} -> text "CTyEqCan" CFunEqCan {} -> text "CFunEqCan" CNonCanonical {} -> text "CNonCanonical" CDictCan { cc_pend_sc = pend_sc } | pend_sc -> text "CDictCan(psc)" | otherwise -> text "CDictCan" CIrredCan { cc_insol = insol } | insol -> text "CIrredCan(insol)" | otherwise -> text "CIrredCan(sol)" CHoleCan { cc_hole = hole } -> text "CHoleCan:" <+> ppr hole CQuantCan (QCI { qci_pend_sc = pend_sc }) | pend_sc -> text "CQuantCan(psc)" | otherwise -> text "CQuantCan" {- ************************************************************************ * * Simple functions over evidence variables * * ************************************************************************ -} ---------------- Getting free tyvars ------------------------- -- | Returns free variables of constraints as a non-deterministic set tyCoVarsOfCt :: Ct -> TcTyCoVarSet tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt -- | Returns free variables of constraints as a deterministically ordered. -- list. See Note [Deterministic FV] in FV. tyCoVarsOfCtList :: Ct -> [TcTyCoVar] tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt -- | Returns free variables of constraints as a composable FV computation. -- See Note [Deterministic FV] in FV. tyCoFVsOfCt :: Ct -> FV tyCoFVsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = tyCoFVsOfType xi `unionFV` FV.unitFV tv `unionFV` tyCoFVsOfType (tyVarKind tv) tyCoFVsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) = tyCoFVsOfTypes tys `unionFV` FV.unitFV fsk `unionFV` tyCoFVsOfType (tyVarKind fsk) tyCoFVsOfCt (CDictCan { cc_tyargs = tys }) = tyCoFVsOfTypes tys tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct) -- | Returns free variables of a bag of constraints as a non-deterministic -- set. See Note [Deterministic FV] in FV. tyCoVarsOfCts :: Cts -> TcTyCoVarSet tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts -- | Returns free variables of a bag of constraints as a deterministically -- odered list. See Note [Deterministic FV] in FV. tyCoVarsOfCtsList :: Cts -> [TcTyCoVar] tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts -- | Returns free variables of a bag of constraints as a composable FV -- computation. See Note [Deterministic FV] in FV. tyCoFVsOfCts :: Cts -> FV tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV -- | Returns free variables of WantedConstraints as a non-deterministic -- set. See Note [Deterministic FV] in FV. tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet -- Only called on *zonked* things, hence no need to worry about flatten-skolems tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC -- | Returns free variables of WantedConstraints as a deterministically -- ordered list. See Note [Deterministic FV] in FV. tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar] -- Only called on *zonked* things, hence no need to worry about flatten-skolems tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC -- | Returns free variables of WantedConstraints as a composable FV -- computation. See Note [Deterministic FV] in FV. tyCoFVsOfWC :: WantedConstraints -> FV -- Only called on *zonked* things, hence no need to worry about flatten-skolems tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic }) = tyCoFVsOfCts simple `unionFV` tyCoFVsOfBag tyCoFVsOfImplic implic -- | Returns free variables of Implication as a composable FV computation. -- See Note [Deterministic FV] in FV. tyCoFVsOfImplic :: Implication -> FV -- Only called on *zonked* things, hence no need to worry about flatten-skolems tyCoFVsOfImplic (Implic { ic_skols = skols , ic_given = givens , ic_wanted = wanted }) | isEmptyWC wanted = emptyFV | otherwise = tyCoFVsVarBndrs skols $ tyCoFVsVarBndrs givens $ tyCoFVsOfWC wanted tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV tyCoFVsOfBag tvs_of = foldr (unionFV . tvs_of) emptyFV --------------------------- dropDerivedWC :: WantedConstraints -> WantedConstraints -- See Note [Dropping derived constraints] dropDerivedWC wc@(WC { wc_simple = simples }) = wc { wc_simple = dropDerivedSimples simples } -- The wc_impl implications are already (recursively) filtered -------------------------- dropDerivedSimples :: Cts -> Cts -- Drop all Derived constraints, but make [W] back into [WD], -- so that if we re-simplify these constraints we will get all -- the right derived constraints re-generated. Forgetting this -- step led to #12936 dropDerivedSimples simples = mapMaybeBag dropDerivedCt simples dropDerivedCt :: Ct -> Maybe Ct dropDerivedCt ct = case ctEvFlavour ev of Wanted WOnly -> Just (ct' { cc_ev = ev_wd }) Wanted _ -> Just ct' _ | isDroppableCt ct -> Nothing | otherwise -> Just ct where ev = ctEvidence ct ev_wd = ev { ctev_nosh = WDeriv } ct' = setPendingScDict ct -- See Note [Resetting cc_pend_sc] {- Note [Resetting cc_pend_sc] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we discard Derived constraints, in dropDerivedSimples, we must set the cc_pend_sc flag to True, so that if we re-process this CDictCan we will re-generate its derived superclasses. Otherwise we might miss some fundeps. #13662 showed this up. See Note [The superclass story] in TcCanonical. -} isDroppableCt :: Ct -> Bool isDroppableCt ct = isDerived ev && not keep_deriv -- Drop only derived constraints, and then only if they -- obey Note [Dropping derived constraints] where ev = ctEvidence ct loc = ctEvLoc ev orig = ctLocOrigin loc keep_deriv = case ct of CHoleCan {} -> True CIrredCan { cc_insol = insoluble } -> keep_eq insoluble _ -> keep_eq False keep_eq definitely_insoluble | isGivenOrigin orig -- Arising only from givens = definitely_insoluble -- Keep only definitely insoluble | otherwise = case orig of KindEqOrigin {} -> True -- See Note [Dropping derived constraints] -- See Note [Dropping derived constraints] -- For fundeps, drop wanted/wanted interactions FunDepOrigin2 {} -> True -- Top-level/Wanted FunDepOrigin1 _ orig1 _ _ orig2 _ | g1 || g2 -> True -- Given/Wanted errors: keep all | otherwise -> False -- Wanted/Wanted errors: discard where g1 = isGivenOrigin orig1 g2 = isGivenOrigin orig2 _ -> False arisesFromGivens :: Ct -> Bool arisesFromGivens ct = case ctEvidence ct of CtGiven {} -> True CtWanted {} -> False CtDerived { ctev_loc = loc } -> isGivenLoc loc isGivenLoc :: CtLoc -> Bool isGivenLoc loc = isGivenOrigin (ctLocOrigin loc) {- Note [Dropping derived constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In general we discard derived constraints at the end of constraint solving; see dropDerivedWC. For example * Superclasses: if we have an unsolved [W] (Ord a), we don't want to complain about an unsolved [D] (Eq a) as well. * If we have [W] a ~ Int, [W] a ~ Bool, improvement will generate [D] Int ~ Bool, and we don't want to report that because it's incomprehensible. That is why we don't rewrite wanteds with wanteds! * We might float out some Wanteds from an implication, leaving behind their insoluble Deriveds. For example: forall a[2]. [W] alpha[1] ~ Int [W] alpha[1] ~ Bool [D] Int ~ Bool The Derived is insoluble, but we very much want to drop it when floating out. But (tiresomely) we do keep *some* Derived constraints: * Type holes are derived constraints, because they have no evidence and we want to keep them, so we get the error report * Insoluble kind equalities (e.g. [D] * ~ (* -> *)), with KindEqOrigin, may arise from a type equality a ~ Int#, say. See Note [Equalities with incompatible kinds] in TcCanonical. Keeping these around produces better error messages, in practice. E.g., test case dependent/should_fail/T11471 * We keep most derived equalities arising from functional dependencies - Given/Given interactions (subset of FunDepOrigin1): The definitely-insoluble ones reflect unreachable code. Others not-definitely-insoluble ones like [D] a ~ Int do not reflect unreachable code; indeed if fundeps generated proofs, it'd be a useful equality. See #14763. So we discard them. - Given/Wanted interacGiven or Wanted interacting with an instance declaration (FunDepOrigin2) - Given/Wanted interactions (FunDepOrigin1); see #9612 - But for Wanted/Wanted interactions we do /not/ want to report an error (#13506). Consider [W] C Int Int, [W] C Int Bool, with a fundep on class C. We don't want to report an insoluble Int~Bool; c.f. "wanteds do not rewrite wanteds". To distinguish these cases we use the CtOrigin. NB: we keep *all* derived insolubles under some circumstances: * They are looked at by simplifyInfer, to decide whether to generalise. Example: [W] a ~ Int, [W] a ~ Bool We get [D] Int ~ Bool, and indeed the constraints are insoluble, and we want simplifyInfer to see that, even though we don't ultimately want to generate an (inexplicable) error message from it ************************************************************************ * * CtEvidence The "flavor" of a canonical constraint * * ************************************************************************ -} isWantedCt :: Ct -> Bool isWantedCt = isWanted . ctEvidence isGivenCt :: Ct -> Bool isGivenCt = isGiven . ctEvidence isDerivedCt :: Ct -> Bool isDerivedCt = isDerived . ctEvidence isCTyEqCan :: Ct -> Bool isCTyEqCan (CTyEqCan {}) = True isCTyEqCan (CFunEqCan {}) = False isCTyEqCan _ = False isCDictCan_Maybe :: Ct -> Maybe Class isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls isCDictCan_Maybe _ = Nothing isCFunEqCan_maybe :: Ct -> Maybe (TyCon, [Type]) isCFunEqCan_maybe (CFunEqCan { cc_fun = tc, cc_tyargs = xis }) = Just (tc, xis) isCFunEqCan_maybe _ = Nothing isCFunEqCan :: Ct -> Bool isCFunEqCan (CFunEqCan {}) = True isCFunEqCan _ = False isCNonCanonical :: Ct -> Bool isCNonCanonical (CNonCanonical {}) = True isCNonCanonical _ = False isHoleCt:: Ct -> Bool isHoleCt (CHoleCan {}) = True isHoleCt _ = False isOutOfScopeCt :: Ct -> Bool -- We treat expression holes representing out-of-scope variables a bit -- differently when it comes to error reporting isOutOfScopeCt (CHoleCan { cc_hole = ExprHole (OutOfScope {}) }) = True isOutOfScopeCt _ = False isExprHoleCt :: Ct -> Bool isExprHoleCt (CHoleCan { cc_hole = ExprHole {} }) = True isExprHoleCt _ = False isTypeHoleCt :: Ct -> Bool isTypeHoleCt (CHoleCan { cc_hole = TypeHole {} }) = True isTypeHoleCt _ = False {- Note [Custom type errors in constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When GHC reports a type-error about an unsolved-constraint, we check to see if the constraint contains any custom-type errors, and if so we report them. Here are some examples of constraints containing type errors: TypeError msg -- The actual constraint is a type error TypError msg ~ Int -- Some type was supposed to be Int, but ended up -- being a type error instead Eq (TypeError msg) -- A class constraint is stuck due to a type error F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err It is also possible to have constraints where the type error is nested deeper, for example see #11990, and also: Eq (F (TypeError msg)) -- Here the type error is nested under a type-function -- call, which failed to evaluate because of it, -- and so the `Eq` constraint was unsolved. -- This may happen when one function calls another -- and the called function produced a custom type error. -} -- | A constraint is considered to be a custom type error, if it contains -- custom type errors anywhere in it. -- See Note [Custom type errors in constraints] getUserTypeErrorMsg :: Ct -> Maybe Type getUserTypeErrorMsg ct = findUserTypeError (ctPred ct) where findUserTypeError t = msum ( userTypeError_maybe t : map findUserTypeError (subTys t) ) subTys t = case splitAppTys t of (t,[]) -> case splitTyConApp_maybe t of Nothing -> [] Just (_,ts) -> ts (t,ts) -> t : ts isUserTypeErrorCt :: Ct -> Bool isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of Just _ -> True _ -> False isPendingScDict :: Ct -> Maybe Ct -- Says whether this is a CDictCan with cc_pend_sc is True, -- AND if so flips the flag isPendingScDict ct@(CDictCan { cc_pend_sc = True }) = Just (ct { cc_pend_sc = False }) isPendingScDict _ = Nothing isPendingScInst :: QCInst -> Maybe QCInst -- Same as isPrendinScDict, but for QCInsts isPendingScInst qci@(QCI { qci_pend_sc = True }) = Just (qci { qci_pend_sc = False }) isPendingScInst _ = Nothing setPendingScDict :: Ct -> Ct -- Set the cc_pend_sc flag to True setPendingScDict ct@(CDictCan { cc_pend_sc = False }) = ct { cc_pend_sc = True } setPendingScDict ct = ct superClassesMightHelp :: WantedConstraints -> Bool -- ^ True if taking superclasses of givens, or of wanteds (to perhaps -- expose more equalities or functional dependencies) might help to -- solve this constraint. See Note [When superclasses help] superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics }) = anyBag might_help_ct simples || anyBag might_help_implic implics where might_help_implic ic | IC_Unsolved <- ic_status ic = superClassesMightHelp (ic_wanted ic) | otherwise = False might_help_ct ct = isWantedCt ct && not (is_ip ct) is_ip (CDictCan { cc_class = cls }) = isIPClass cls is_ip _ = False getPendingWantedScs :: Cts -> ([Ct], Cts) getPendingWantedScs simples = mapAccumBagL get [] simples where get acc ct | Just ct' <- isPendingScDict ct = (ct':acc, ct') | otherwise = (acc, ct) {- Note [When superclasses help] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ First read Note [The superclass story] in TcCanonical. We expand superclasses and iterate only if there is at unsolved wanted for which expansion of superclasses (e.g. from given constraints) might actually help. The function superClassesMightHelp tells if doing this superclass expansion might help solve this constraint. Note that * We look inside implications; maybe it'll help to expand the Givens at level 2 to help solve an unsolved Wanted buried inside an implication. E.g. forall a. Ord a => forall b. [W] Eq a * Superclasses help only for Wanted constraints. Derived constraints are not really "unsolved" and we certainly don't want them to trigger superclass expansion. This was a good part of the loop in #11523 * Even for Wanted constraints, we say "no" for implicit parameters. we have [W] ?x::ty, expanding superclasses won't help: - Superclasses can't be implicit parameters - If we have a [G] ?x:ty2, then we'll have another unsolved [D] ty ~ ty2 (from the functional dependency) which will trigger superclass expansion. It's a bit of a special case, but it's easy to do. The runtime cost is low because the unsolved set is usually empty anyway (errors aside), and the first non-imlicit-parameter will terminate the search. The special case is worth it (#11480, comment:2) because it applies to CallStack constraints, which aren't type errors. If we have f :: (C a) => blah f x = ...undefined... we'll get a CallStack constraint. If that's the only unsolved constraint it'll eventually be solved by defaulting. So we don't want to emit warnings about hitting the simplifier's iteration limit. A CallStack constraint really isn't an unsolved constraint; it can always be solved by defaulting. -} singleCt :: Ct -> Cts singleCt = unitBag andCts :: Cts -> Cts -> Cts andCts = unionBags listToCts :: [Ct] -> Cts listToCts = listToBag ctsElts :: Cts -> [Ct] ctsElts = bagToList consCts :: Ct -> Cts -> Cts consCts = consBag snocCts :: Cts -> Ct -> Cts snocCts = snocBag extendCtsList :: Cts -> [Ct] -> Cts extendCtsList cts xs | null xs = cts | otherwise = cts `unionBags` listToBag xs andManyCts :: [Cts] -> Cts andManyCts = unionManyBags emptyCts :: Cts emptyCts = emptyBag isEmptyCts :: Cts -> Bool isEmptyCts = isEmptyBag pprCts :: Cts -> SDoc pprCts cts = vcat (map ppr (bagToList cts)) {- ************************************************************************ * * Wanted constraints These are forced to be in TcRnTypes because TcLclEnv mentions WantedConstraints WantedConstraint mentions CtLoc CtLoc mentions ErrCtxt ErrCtxt mentions TcM * * v%************************************************************************ -} data WantedConstraints = WC { wc_simple :: Cts -- Unsolved constraints, all wanted , wc_impl :: Bag Implication } emptyWC :: WantedConstraints emptyWC = WC { wc_simple = emptyBag, wc_impl = emptyBag } mkSimpleWC :: [CtEvidence] -> WantedConstraints mkSimpleWC cts = WC { wc_simple = listToBag (map mkNonCanonical cts) , wc_impl = emptyBag } mkImplicWC :: Bag Implication -> WantedConstraints mkImplicWC implic = WC { wc_simple = emptyBag, wc_impl = implic } isEmptyWC :: WantedConstraints -> Bool isEmptyWC (WC { wc_simple = f, wc_impl = i }) = isEmptyBag f && isEmptyBag i -- | Checks whether a the given wanted constraints are solved, i.e. -- that there are no simple constraints left and all the implications -- are solved. isSolvedWC :: WantedConstraints -> Bool isSolvedWC WC {wc_simple = wc_simple, wc_impl = wc_impl} = isEmptyBag wc_simple && allBag (isSolvedStatus . ic_status) wc_impl andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints andWC (WC { wc_simple = f1, wc_impl = i1 }) (WC { wc_simple = f2, wc_impl = i2 }) = WC { wc_simple = f1 `unionBags` f2 , wc_impl = i1 `unionBags` i2 } unionsWC :: [WantedConstraints] -> WantedConstraints unionsWC = foldr andWC emptyWC addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints addSimples wc cts = wc { wc_simple = wc_simple wc `unionBags` cts } -- Consider: Put the new constraints at the front, so they get solved first addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints addInsols wc cts = wc { wc_simple = wc_simple wc `unionBags` cts } insolublesOnly :: WantedConstraints -> WantedConstraints -- Keep only the definitely-insoluble constraints insolublesOnly (WC { wc_simple = simples, wc_impl = implics }) = WC { wc_simple = filterBag insolubleCt simples , wc_impl = mapBag implic_insols_only implics } where implic_insols_only implic = implic { ic_wanted = insolublesOnly (ic_wanted implic) } isSolvedStatus :: ImplicStatus -> Bool isSolvedStatus (IC_Solved {}) = True isSolvedStatus _ = False isInsolubleStatus :: ImplicStatus -> Bool isInsolubleStatus IC_Insoluble = True isInsolubleStatus IC_BadTelescope = True isInsolubleStatus _ = False insolubleImplic :: Implication -> Bool insolubleImplic ic = isInsolubleStatus (ic_status ic) insolubleWC :: WantedConstraints -> Bool insolubleWC (WC { wc_impl = implics, wc_simple = simples }) = anyBag insolubleCt simples || anyBag insolubleImplic implics insolubleCt :: Ct -> Bool -- Definitely insoluble, in particular /excluding/ type-hole constraints -- Namely: a) an equality constraint -- b) that is insoluble -- c) and does not arise from a Given insolubleCt ct | isHoleCt ct = isOutOfScopeCt ct -- See Note [Insoluble holes] | not (insolubleEqCt ct) = False | arisesFromGivens ct = False -- See Note [Given insolubles] | otherwise = True insolubleEqCt :: Ct -> Bool -- Returns True of /equality/ constraints -- that are /definitely/ insoluble -- It won't detect some definite errors like -- F a ~ T (F a) -- where F is a type family, which actually has an occurs check -- -- The function is tuned for application /after/ constraint solving -- i.e. assuming canonicalisation has been done -- E.g. It'll reply True for a ~ [a] -- but False for [a] ~ a -- and -- True for Int ~ F a Int -- but False for Maybe Int ~ F a Int Int -- (where F is an arity-1 type function) insolubleEqCt (CIrredCan { cc_insol = insol }) = insol insolubleEqCt _ = False instance Outputable WantedConstraints where ppr (WC {wc_simple = s, wc_impl = i}) = text "WC" <+> braces (vcat [ ppr_bag (text "wc_simple") s , ppr_bag (text "wc_impl") i ]) ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc ppr_bag doc bag | isEmptyBag bag = empty | otherwise = hang (doc <+> equals) 2 (foldr (($$) . ppr) empty bag) {- Note [Given insolubles] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (#14325, comment:) class (a~b) => C a b foo :: C a c => a -> c foo x = x hm3 :: C (f b) b => b -> f b hm3 x = foo x In the RHS of hm3, from the [G] C (f b) b we get the insoluble [G] f b ~# b. Then we also get an unsolved [W] C b (f b). Residual implication looks like forall b. C (f b) b => [G] f b ~# b [W] C f (f b) We do /not/ want to set the implication status to IC_Insoluble, because that'll suppress reports of [W] C b (f b). But we may not report the insoluble [G] f b ~# b either (see Note [Given errors] in TcErrors), so we may fail to report anything at all! Yikes. The same applies to Derived constraints that /arise from/ Givens. E.g. f :: (C Int [a]) => blah where a fundep means we get [D] Int ~ [a] By the same reasoning we must not suppress other errors (#15767) Bottom line: insolubleWC (called in TcSimplify.setImplicationStatus) should ignore givens even if they are insoluble. Note [Insoluble holes] ~~~~~~~~~~~~~~~~~~~~~~ Hole constraints that ARE NOT treated as truly insoluble: a) type holes, arising from PartialTypeSignatures, b) "true" expression holes arising from TypedHoles An "expression hole" or "type hole" constraint isn't really an error at all; it's a report saying "_ :: Int" here. But an out-of-scope variable masquerading as expression holes IS treated as truly insoluble, so that it trumps other errors during error reporting. Yuk! ************************************************************************ * * Implication constraints * * ************************************************************************ -} data Implication = Implic { -- Invariants for a tree of implications: -- see TcType Note [TcLevel and untouchable type variables] ic_tclvl :: TcLevel, -- TcLevel of unification variables -- allocated /inside/ this implication ic_skols :: [TcTyVar], -- Introduced skolems ic_info :: SkolemInfo, -- See Note [Skolems in an implication] -- See Note [Shadowing in a constraint] ic_telescope :: Maybe SDoc, -- User-written telescope, if there is one -- See Note [Checking telescopes] ic_given :: [EvVar], -- Given evidence variables -- (order does not matter) -- See Invariant (GivenInv) in TcType ic_no_eqs :: Bool, -- True <=> ic_givens have no equalities, for sure -- False <=> ic_givens might have equalities ic_warn_inaccessible :: Bool, -- True <=> -Winaccessible-code is enabled -- at construction. See -- Note [Avoid -Winaccessible-code when deriving] -- in TcInstDcls ic_env :: TcLclEnv, -- Records the TcLClEnv at the time of creation. -- -- The TcLclEnv gives the source location -- and error context for the implication, and -- hence for all the given evidence variables. ic_wanted :: WantedConstraints, -- The wanteds -- See Invariang (WantedInf) in TcType ic_binds :: EvBindsVar, -- Points to the place to fill in the -- abstraction and bindings. -- The ic_need fields keep track of which Given evidence -- is used by this implication or its children -- NB: including stuff used by nested implications that have since -- been discarded -- See Note [Needed evidence variables] ic_need_inner :: VarSet, -- Includes all used Given evidence ic_need_outer :: VarSet, -- Includes only the free Given evidence -- i.e. ic_need_inner after deleting -- (a) givens (b) binders of ic_binds ic_status :: ImplicStatus } implicationPrototype :: Implication implicationPrototype = Implic { -- These fields must be initialised ic_tclvl = panic "newImplic:tclvl" , ic_binds = panic "newImplic:binds" , ic_info = panic "newImplic:info" , ic_env = panic "newImplic:env" , ic_warn_inaccessible = panic "newImplic:warn_inaccessible" -- The rest have sensible default values , ic_skols = [] , ic_telescope = Nothing , ic_given = [] , ic_wanted = emptyWC , ic_no_eqs = False , ic_status = IC_Unsolved , ic_need_inner = emptyVarSet , ic_need_outer = emptyVarSet } data ImplicStatus = IC_Solved -- All wanteds in the tree are solved, all the way down { ics_dead :: [EvVar] } -- Subset of ic_given that are not needed -- See Note [Tracking redundant constraints] in TcSimplify | IC_Insoluble -- At least one insoluble constraint in the tree | IC_BadTelescope -- solved, but the skolems in the telescope are out of -- dependency order | IC_Unsolved -- Neither of the above; might go either way instance Outputable Implication where ppr (Implic { ic_tclvl = tclvl, ic_skols = skols , ic_given = given, ic_no_eqs = no_eqs , ic_wanted = wanted, ic_status = status , ic_binds = binds , ic_need_inner = need_in, ic_need_outer = need_out , ic_info = info }) = hang (text "Implic" <+> lbrace) 2 (sep [ text "TcLevel =" <+> ppr tclvl , text "Skolems =" <+> pprTyVars skols , text "No-eqs =" <+> ppr no_eqs , text "Status =" <+> ppr status , hang (text "Given =") 2 (pprEvVars given) , hang (text "Wanted =") 2 (ppr wanted) , text "Binds =" <+> ppr binds , whenPprDebug (text "Needed inner =" <+> ppr need_in) , whenPprDebug (text "Needed outer =" <+> ppr need_out) , pprSkolInfo info ] <+> rbrace) instance Outputable ImplicStatus where ppr IC_Insoluble = text "Insoluble" ppr IC_BadTelescope = text "Bad telescope" ppr IC_Unsolved = text "Unsolved" ppr (IC_Solved { ics_dead = dead }) = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead)) {- Note [Checking telescopes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When kind-checking a /user-written/ type, we might have a "bad telescope" like this one: data SameKind :: forall k. k -> k -> Type type Foo :: forall a k (b :: k). SameKind a b -> Type The kind of 'a' mentions 'k' which is bound after 'a'. Oops. Knowing this means that unification etc must have happened, so it's convenient to detect it in the constraint solver: * We make a single implication constraint when kind-checking the 'forall' in Foo's kind, something like forall a k (b::k). { wanted constraints } * Having solved {wanted}, before discarding the now-solved implication, the costraint solver checks the dependency order of the skolem variables (ic_skols). This is done in setImplicationStatus. * This check is only necessary if the implication was born from a user-written signature. If, say, it comes from checking a pattern match that binds existentials, where the type of the data constructor is known to be valid (it in tcConPat), no need for the check. So the check is done if and only if ic_telescope is (Just blah). * If ic_telesope is (Just d), the d::SDoc displays the original, user-written type variables. * Be careful /NOT/ to discard an implication with non-Nothing ic_telescope, even if ic_wanted is empty. We must give the constraint solver a chance to make that bad-telesope test! Hence the extra guard in emitResidualTvConstraint; see #16247 See also TcHsType Note [Keeping scoped variables in order: Explicit] Note [Needed evidence variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Th ic_need_evs field holds the free vars of ic_binds, and all the ic_binds in nested implications. * Main purpose: if one of the ic_givens is not mentioned in here, it is redundant. * solveImplication may drop an implication altogether if it has no remaining 'wanteds'. But we still track the free vars of its evidence binds, even though it has now disappeared. Note [Shadowing in a constraint] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We assume NO SHADOWING in a constraint. Specifically * The unification variables are all implicitly quantified at top level, and are all unique * The skolem variables bound in ic_skols are all freah when the implication is created. So we can safely substitute. For example, if we have forall a. a~Int => ...(forall b. ...a...)... we can push the (a~Int) constraint inwards in the "givens" without worrying that 'b' might clash. Note [Skolems in an implication] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The skolems in an implication are not there to perform a skolem escape check. That happens because all the environment variables are in the untouchables, and therefore cannot be unified with anything at all, let alone the skolems. Instead, ic_skols is used only when considering floating a constraint outside the implication in TcSimplify.floatEqualities or TcSimplify.approximateImplications Note [Insoluble constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some of the errors that we get during canonicalization are best reported when all constraints have been simplified as much as possible. For instance, assume that during simplification the following constraints arise: [Wanted] F alpha ~ uf1 [Wanted] beta ~ uf1 beta When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail we will simply see a message: 'Can't construct the infinite type beta ~ uf1 beta' and the user has no idea what the uf1 variable is. Instead our plan is that we will NOT fail immediately, but: (1) Record the "frozen" error in the ic_insols field (2) Isolate the offending constraint from the rest of the inerts (3) Keep on simplifying/canonicalizing At the end, we will hopefully have substituted uf1 := F alpha, and we will be able to report a more informative error: 'Can't construct the infinite type beta ~ F alpha beta' Insoluble constraints *do* include Derived constraints. For example, a functional dependency might give rise to [D] Int ~ Bool, and we must report that. If insolubles did not contain Deriveds, reportErrors would never see it. ************************************************************************ * * Pretty printing * * ************************************************************************ -} pprEvVars :: [EvVar] -> SDoc -- Print with their types pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) pprEvVarTheta :: [EvVar] -> SDoc pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) pprEvVarWithType :: EvVar -> SDoc pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) -- | Wraps the given type with the constraints (via ic_given) in the given -- implication, according to the variables mentioned (via ic_skols) -- in the implication, but taking care to only wrap those variables -- that are mentioned in the type or the implication. wrapTypeWithImplication :: Type -> Implication -> Type wrapTypeWithImplication ty impl = wrapType ty mentioned_skols givens where givens = map idType $ ic_given impl skols = ic_skols impl freeVars = fvVarSet $ tyCoFVsOfTypes (ty:givens) mentioned_skols = filter (`elemVarSet` freeVars) skols wrapType :: Type -> [TyVar] -> [PredType] -> Type wrapType ty skols givens = mkSpecForAllTys skols $ mkPhiTy givens ty {- ************************************************************************ * * CtEvidence * * ************************************************************************ Note [Evidence field of CtEvidence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ During constraint solving we never look at the type of ctev_evar/ctev_dest; instead we look at the ctev_pred field. The evtm/evar field may be un-zonked. Note [Bind new Givens immediately] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For Givens we make new EvVars and bind them immediately. Two main reasons: * Gain sharing. E.g. suppose we start with g :: C a b, where class D a => C a b class (E a, F a) => D a If we generate all g's superclasses as separate EvTerms we might get selD1 (selC1 g) :: E a selD2 (selC1 g) :: F a selC1 g :: D a which we could do more economically as: g1 :: D a = selC1 g g2 :: E a = selD1 g1 g3 :: F a = selD2 g1 * For *coercion* evidence we *must* bind each given: class (a~b) => C a b where .... f :: C a b => .... Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b. But that superclass selector can't (yet) appear in a coercion (see evTermCoercion), so the easy thing is to bind it to an Id. So a Given has EvVar inside it rather than (as previously) an EvTerm. -} -- | A place for type-checking evidence to go after it is generated. -- Wanted equalities are always HoleDest; other wanteds are always -- EvVarDest. data TcEvDest = EvVarDest EvVar -- ^ bind this var to the evidence -- EvVarDest is always used for non-type-equalities -- e.g. class constraints | HoleDest CoercionHole -- ^ fill in this hole with the evidence -- HoleDest is always used for type-equalities -- See Note [Coercion holes] in TyCoRep data CtEvidence = CtGiven -- Truly given, not depending on subgoals { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] , ctev_evar :: EvVar -- See Note [Evidence field of CtEvidence] , ctev_loc :: CtLoc } | CtWanted -- Wanted goal { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] , ctev_dest :: TcEvDest , ctev_nosh :: ShadowInfo -- See Note [Constraint flavours] , ctev_loc :: CtLoc } | CtDerived -- A goal that we don't really have to solve and can't -- immediately rewrite anything other than a derived -- (there's no evidence!) but if we do manage to solve -- it may help in solving other goals. { ctev_pred :: TcPredType , ctev_loc :: CtLoc } ctEvPred :: CtEvidence -> TcPredType -- The predicate of a flavor ctEvPred = ctev_pred ctEvLoc :: CtEvidence -> CtLoc ctEvLoc = ctev_loc ctEvOrigin :: CtEvidence -> CtOrigin ctEvOrigin = ctLocOrigin . ctEvLoc -- | Get the equality relation relevant for a 'CtEvidence' ctEvEqRel :: CtEvidence -> EqRel ctEvEqRel = predTypeEqRel . ctEvPred -- | Get the role relevant for a 'CtEvidence' ctEvRole :: CtEvidence -> Role ctEvRole = eqRelRole . ctEvEqRel ctEvTerm :: CtEvidence -> EvTerm ctEvTerm ev = EvExpr (ctEvExpr ev) ctEvExpr :: CtEvidence -> EvExpr ctEvExpr ev@(CtWanted { ctev_dest = HoleDest _ }) = Coercion $ ctEvCoercion ev ctEvExpr ev = evId (ctEvEvId ev) ctEvCoercion :: HasDebugCallStack => CtEvidence -> TcCoercion ctEvCoercion (CtGiven { ctev_evar = ev_id }) = mkTcCoVarCo ev_id ctEvCoercion (CtWanted { ctev_dest = dest }) | HoleDest hole <- dest = -- ctEvCoercion is only called on type equalities -- and they always have HoleDests mkHoleCo hole ctEvCoercion ev = pprPanic "ctEvCoercion" (ppr ev) ctEvEvId :: CtEvidence -> EvVar ctEvEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev ctEvEvId (CtWanted { ctev_dest = HoleDest h }) = coHoleCoVar h ctEvEvId (CtGiven { ctev_evar = ev }) = ev ctEvEvId ctev@(CtDerived {}) = pprPanic "ctEvId:" (ppr ctev) instance Outputable TcEvDest where ppr (HoleDest h) = text "hole" <> ppr h ppr (EvVarDest ev) = ppr ev instance Outputable CtEvidence where ppr ev = ppr (ctEvFlavour ev) <+> pp_ev <+> braces (ppr (ctl_depth (ctEvLoc ev))) <> dcolon -- Show the sub-goal depth too <+> ppr (ctEvPred ev) where pp_ev = case ev of CtGiven { ctev_evar = v } -> ppr v CtWanted {ctev_dest = d } -> ppr d CtDerived {} -> text "_" isWanted :: CtEvidence -> Bool isWanted (CtWanted {}) = True isWanted _ = False isGiven :: CtEvidence -> Bool isGiven (CtGiven {}) = True isGiven _ = False isDerived :: CtEvidence -> Bool isDerived (CtDerived {}) = True isDerived _ = False {- %************************************************************************ %* * CtFlavour %* * %************************************************************************ Note [Constraint flavours] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Constraints come in four flavours: * [G] Given: we have evidence * [W] Wanted WOnly: we want evidence * [D] Derived: any solution must satisfy this constraint, but we don't need evidence for it. Examples include: - superclasses of [W] class constraints - equalities arising from functional dependencies or injectivity * [WD] Wanted WDeriv: a single constraint that represents both [W] and [D] We keep them paired as one both for efficiency, and because when we have a finite map F tys -> CFunEqCan, it's inconvenient to have two CFunEqCans in the range The ctev_nosh field of a Wanted distinguishes between [W] and [WD] Wanted constraints are born as [WD], but are split into [W] and its "shadow" [D] in TcSMonad.maybeEmitShadow. See Note [The improvement story and derived shadows] in TcSMonad -} data CtFlavour -- See Note [Constraint flavours] = Given | Wanted ShadowInfo | Derived deriving Eq data ShadowInfo = WDeriv -- [WD] This Wanted constraint has no Derived shadow, -- so it behaves like a pair of a Wanted and a Derived | WOnly -- [W] It has a separate derived shadow -- See Note [The improvement story and derived shadows] in TcSMonad deriving( Eq ) isGivenOrWDeriv :: CtFlavour -> Bool isGivenOrWDeriv Given = True isGivenOrWDeriv (Wanted WDeriv) = True isGivenOrWDeriv _ = False instance Outputable CtFlavour where ppr Given = text "[G]" ppr (Wanted WDeriv) = text "[WD]" ppr (Wanted WOnly) = text "[W]" ppr Derived = text "[D]" ctEvFlavour :: CtEvidence -> CtFlavour ctEvFlavour (CtWanted { ctev_nosh = nosh }) = Wanted nosh ctEvFlavour (CtGiven {}) = Given ctEvFlavour (CtDerived {}) = Derived -- | Whether or not one 'Ct' can rewrite another is determined by its -- flavour and its equality relation. See also -- Note [Flavours with roles] in TcSMonad type CtFlavourRole = (CtFlavour, EqRel) -- | Extract the flavour, role, and boxity from a 'CtEvidence' ctEvFlavourRole :: CtEvidence -> CtFlavourRole ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel ev) -- | Extract the flavour and role from a 'Ct' ctFlavourRole :: Ct -> CtFlavourRole -- Uses short-cuts to role for special cases ctFlavourRole (CDictCan { cc_ev = ev }) = (ctEvFlavour ev, NomEq) ctFlavourRole (CTyEqCan { cc_ev = ev, cc_eq_rel = eq_rel }) = (ctEvFlavour ev, eq_rel) ctFlavourRole (CFunEqCan { cc_ev = ev }) = (ctEvFlavour ev, NomEq) ctFlavourRole (CHoleCan { cc_ev = ev }) = (ctEvFlavour ev, NomEq) -- NomEq: CHoleCans can be rewritten by -- by nominal equalities but empahatically -- not by representational equalities ctFlavourRole ct = ctEvFlavourRole (ctEvidence ct) {- Note [eqCanRewrite] ~~~~~~~~~~~~~~~~~~~~~~ (eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form tv ~ ty) can be used to rewrite ct2. It must satisfy the properties of a can-rewrite relation, see Definition [Can-rewrite relation] in TcSMonad. With the solver handling Coercible constraints like equality constraints, the rewrite conditions must take role into account, never allowing a representational equality to rewrite a nominal one. Note [Wanteds do not rewrite Wanteds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We don't allow Wanteds to rewrite Wanteds, because that can give rise to very confusing type error messages. A good example is #8450. Here's another f :: a -> Bool f x = ( [x,'c'], [x,True] ) `seq` True Here we get [W] a ~ Char [W] a ~ Bool but we do not want to complain about Bool ~ Char! Note [Deriveds do rewrite Deriveds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ However we DO allow Deriveds to rewrite Deriveds, because that's how improvement works; see Note [The improvement story] in TcInteract. However, for now at least I'm only letting (Derived,NomEq) rewrite (Derived,NomEq) and not doing anything for ReprEq. If we have eqCanRewriteFR (Derived, NomEq) (Derived, _) = True then we lose property R2 of Definition [Can-rewrite relation] in TcSMonad R2. If f1 >= f, and f2 >= f, then either f1 >= f2 or f2 >= f1 Consider f1 = (Given, ReprEq) f2 = (Derived, NomEq) f = (Derived, ReprEq) I thought maybe we could never get Derived ReprEq constraints, but we can; straight from the Wanteds during improvement. And from a Derived ReprEq we could conceivably get a Derived NomEq improvement (by decomposing a type constructor with Nomninal role), and hence unify. -} eqCanRewrite :: EqRel -> EqRel -> Bool eqCanRewrite NomEq _ = True eqCanRewrite ReprEq ReprEq = True eqCanRewrite ReprEq NomEq = False eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool -- Can fr1 actually rewrite fr2? -- Very important function! -- See Note [eqCanRewrite] -- See Note [Wanteds do not rewrite Wanteds] -- See Note [Deriveds do rewrite Deriveds] eqCanRewriteFR (Given, r1) (_, r2) = eqCanRewrite r1 r2 eqCanRewriteFR (Wanted WDeriv, NomEq) (Derived, NomEq) = True eqCanRewriteFR (Derived, NomEq) (Derived, NomEq) = True eqCanRewriteFR _ _ = False eqMayRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool -- Is it /possible/ that fr1 can rewrite fr2? -- This is used when deciding which inerts to kick out, -- at which time a [WD] inert may be split into [W] and [D] eqMayRewriteFR (Wanted WDeriv, NomEq) (Wanted WDeriv, NomEq) = True eqMayRewriteFR (Derived, NomEq) (Wanted WDeriv, NomEq) = True eqMayRewriteFR fr1 fr2 = eqCanRewriteFR fr1 fr2 ----------------- {- Note [funEqCanDischarge] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have two CFunEqCans with the same LHS: (x1:F ts ~ f1) `funEqCanDischarge` (x2:F ts ~ f2) Can we drop x2 in favour of x1, either unifying f2 (if it's a flatten meta-var) or adding a new Given (f1 ~ f2), if x2 is a Given? Answer: yes if funEqCanDischarge is true. -} funEqCanDischarge :: CtEvidence -> CtEvidence -> ( SwapFlag -- NotSwapped => lhs can discharge rhs -- Swapped => rhs can discharge lhs , Bool) -- True <=> upgrade non-discharded one -- from [W] to [WD] -- See Note [funEqCanDischarge] funEqCanDischarge ev1 ev2 = ASSERT2( ctEvEqRel ev1 == NomEq, ppr ev1 ) ASSERT2( ctEvEqRel ev2 == NomEq, ppr ev2 ) -- CFunEqCans are all Nominal, hence asserts funEqCanDischargeF (ctEvFlavour ev1) (ctEvFlavour ev2) funEqCanDischargeF :: CtFlavour -> CtFlavour -> (SwapFlag, Bool) funEqCanDischargeF Given _ = (NotSwapped, False) funEqCanDischargeF _ Given = (IsSwapped, False) funEqCanDischargeF (Wanted WDeriv) _ = (NotSwapped, False) funEqCanDischargeF _ (Wanted WDeriv) = (IsSwapped, True) funEqCanDischargeF (Wanted WOnly) (Wanted WOnly) = (NotSwapped, False) funEqCanDischargeF (Wanted WOnly) Derived = (NotSwapped, True) funEqCanDischargeF Derived (Wanted WOnly) = (IsSwapped, True) funEqCanDischargeF Derived Derived = (NotSwapped, False) {- Note [eqCanDischarge] ~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have two identical CTyEqCan equality constraints (i.e. both LHS and RHS are the same) (x1:a~t) `eqCanDischarge` (xs:a~t) Can we just drop x2 in favour of x1? Answer: yes if eqCanDischarge is true. Note that we do /not/ allow Wanted to discharge Derived. We must keep both. Why? Because the Derived may rewrite other Deriveds in the model whereas the Wanted cannot. However a Wanted can certainly discharge an identical Wanted. So eqCanDischarge does /not/ define a can-rewrite relation in the sense of Definition [Can-rewrite relation] in TcSMonad. We /do/ say that a [W] can discharge a [WD]. In evidence terms it certainly can, and the /caller/ arranges that the otherwise-lost [D] is spat out as a new Derived. -} eqCanDischargeFR :: CtFlavourRole -> CtFlavourRole -> Bool -- See Note [eqCanDischarge] eqCanDischargeFR (f1,r1) (f2, r2) = eqCanRewrite r1 r2 && eqCanDischargeF f1 f2 eqCanDischargeF :: CtFlavour -> CtFlavour -> Bool eqCanDischargeF Given _ = True eqCanDischargeF (Wanted _) (Wanted _) = True eqCanDischargeF (Wanted WDeriv) Derived = True eqCanDischargeF Derived Derived = True eqCanDischargeF _ _ = False {- ************************************************************************ * * SubGoalDepth * * ************************************************************************ Note [SubGoalDepth] ~~~~~~~~~~~~~~~~~~~ The 'SubGoalDepth' takes care of stopping the constraint solver from looping. The counter starts at zero and increases. It includes dictionary constraints, equality simplification, and type family reduction. (Why combine these? Because it's actually quite easy to mistake one for another, in sufficiently involved scenarios, like ConstraintKinds.) The flag -freduction-depth=n fixes the maximium level. * The counter includes the depth of type class instance declarations. Example: [W] d{7} : Eq [Int] That is d's dictionary-constraint depth is 7. If we use the instance $dfEqList :: Eq a => Eq [a] to simplify it, we get d{7} = $dfEqList d'{8} where d'{8} : Eq Int, and d' has depth 8. For civilised (decidable) instance declarations, each increase of depth removes a type constructor from the type, so the depth never gets big; i.e. is bounded by the structural depth of the type. * The counter also increments when resolving equalities involving type functions. Example: Assume we have a wanted at depth 7: [W] d{7} : F () ~ a If there is a type function equation "F () = Int", this would be rewritten to [W] d{8} : Int ~ a and remembered as having depth 8. Again, without UndecidableInstances, this counter is bounded, but without it can resolve things ad infinitum. Hence there is a maximum level. * Lastly, every time an equality is rewritten, the counter increases. Again, rewriting an equality constraint normally makes progress, but it's possible the "progress" is just the reduction of an infinitely-reducing type family. Hence we need to track the rewrites. When compiling a program requires a greater depth, then GHC recommends turning off this check entirely by setting -freduction-depth=0. This is because the exact number that works is highly variable, and is likely to change even between minor releases. Because this check is solely to prevent infinite compilation times, it seems safe to disable it when a user has ascertained that their program doesn't loop at the type level. -} -- | See Note [SubGoalDepth] newtype SubGoalDepth = SubGoalDepth Int deriving (Eq, Ord, Outputable) initialSubGoalDepth :: SubGoalDepth initialSubGoalDepth = SubGoalDepth 0 bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n + 1) maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth maxSubGoalDepth (SubGoalDepth n) (SubGoalDepth m) = SubGoalDepth (n `max` m) subGoalDepthExceeded :: DynFlags -> SubGoalDepth -> Bool subGoalDepthExceeded dflags (SubGoalDepth d) = mkIntWithInf d > reductionDepth dflags {- ************************************************************************ * * CtLoc * * ************************************************************************ The 'CtLoc' gives information about where a constraint came from. This is important for decent error message reporting because dictionaries don't appear in the original source code. type will evolve... -} data CtLoc = CtLoc { ctl_origin :: CtOrigin , ctl_env :: TcLclEnv , ctl_t_or_k :: Maybe TypeOrKind -- OK if we're not sure , ctl_depth :: !SubGoalDepth } -- The TcLclEnv includes particularly -- source location: tcl_loc :: RealSrcSpan -- context: tcl_ctxt :: [ErrCtxt] -- binder stack: tcl_bndrs :: TcBinderStack -- level: tcl_tclvl :: TcLevel mkKindLoc :: TcType -> TcType -- original *types* being compared -> CtLoc -> CtLoc mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc) (KindEqOrigin s1 (Just s2) (ctLocOrigin loc) (ctLocTypeOrKind_maybe loc)) -- | Take a CtLoc and moves it to the kind level toKindLoc :: CtLoc -> CtLoc toKindLoc loc = loc { ctl_t_or_k = Just KindLevel } mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc mkGivenLoc tclvl skol_info env = CtLoc { ctl_origin = GivenOrigin skol_info , ctl_env = setLclEnvTcLevel env tclvl , ctl_t_or_k = Nothing -- this only matters for error msgs , ctl_depth = initialSubGoalDepth } ctLocEnv :: CtLoc -> TcLclEnv ctLocEnv = ctl_env ctLocLevel :: CtLoc -> TcLevel ctLocLevel loc = getLclEnvTcLevel (ctLocEnv loc) ctLocDepth :: CtLoc -> SubGoalDepth ctLocDepth = ctl_depth ctLocOrigin :: CtLoc -> CtOrigin ctLocOrigin = ctl_origin ctLocSpan :: CtLoc -> RealSrcSpan ctLocSpan (CtLoc { ctl_env = lcl}) = getLclEnvLoc lcl ctLocTypeOrKind_maybe :: CtLoc -> Maybe TypeOrKind ctLocTypeOrKind_maybe = ctl_t_or_k setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (setLclEnvLoc lcl loc) bumpCtLocDepth :: CtLoc -> CtLoc bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth d } setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc setCtLocOrigin ctl orig = ctl { ctl_origin = orig } updateCtLocOrigin :: CtLoc -> (CtOrigin -> CtOrigin) -> CtLoc updateCtLocOrigin ctl@(CtLoc { ctl_origin = orig }) upd = ctl { ctl_origin = upd orig } setCtLocEnv :: CtLoc -> TcLclEnv -> CtLoc setCtLocEnv ctl env = ctl { ctl_env = env } pprCtLoc :: CtLoc -> SDoc -- "arising from ... at ..." -- Not an instance of Outputable because of the "arising from" prefix pprCtLoc (CtLoc { ctl_origin = o, ctl_env = lcl}) = sep [ pprCtOrigin o , text "at" <+> ppr (getLclEnvLoc lcl)] ghc-lib-parser-8.10.2.20200808/compiler/coreSyn/CoreArity.hs0000644000000000000000000012440713713635744021207 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 Arity and eta expansion -} {-# LANGUAGE CPP #-} -- | Arity and eta expansion module CoreArity ( manifestArity, joinRhsArity, exprArity, typeArity, exprEtaExpandArity, findRhsArity, etaExpand, etaExpandToJoinPoint, etaExpandToJoinPointRule, exprBotStrictness_maybe ) where #include "GhclibHsVersions.h" import GhcPrelude import CoreSyn import CoreFVs import CoreUtils import CoreSubst import Demand import Var import VarEnv import Id import Type import TyCon ( initRecTc, checkRecTc ) import Predicate ( isDictTy ) import Coercion import BasicTypes import Unique import DynFlags ( DynFlags, GeneralFlag(..), gopt ) import Outputable import FastString import Pair import Util ( debugIsOn ) {- ************************************************************************ * * manifestArity and exprArity * * ************************************************************************ exprArity is a cheap-and-cheerful version of exprEtaExpandArity. It tells how many things the expression can be applied to before doing any work. It doesn't look inside cases, lets, etc. The idea is that exprEtaExpandArity will do the hard work, leaving something that's easy for exprArity to grapple with. In particular, Simplify uses exprArity to compute the ArityInfo for the Id. Originally I thought that it was enough just to look for top-level lambdas, but it isn't. I've seen this foo = PrelBase.timesInt We want foo to get arity 2 even though the eta-expander will leave it unchanged, in the expectation that it'll be inlined. But occasionally it isn't, because foo is blacklisted (used in a rule). Similarly, see the ok_note check in exprEtaExpandArity. So f = __inline_me (\x -> e) won't be eta-expanded. And in any case it seems more robust to have exprArity be a bit more intelligent. But note that (\x y z -> f x y z) should have arity 3, regardless of f's arity. -} manifestArity :: CoreExpr -> Arity -- ^ manifestArity sees how many leading value lambdas there are, -- after looking through casts manifestArity (Lam v e) | isId v = 1 + manifestArity e | otherwise = manifestArity e manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e manifestArity (Cast e _) = manifestArity e manifestArity _ = 0 joinRhsArity :: CoreExpr -> JoinArity -- Join points are supposed to have manifestly-visible -- lambdas at the top: no ticks, no casts, nothing -- Moreover, type lambdas count in JoinArity joinRhsArity (Lam _ e) = 1 + joinRhsArity e joinRhsArity _ = 0 --------------- exprArity :: CoreExpr -> Arity -- ^ An approximate, fast, version of 'exprEtaExpandArity' exprArity e = go e where go (Var v) = idArity v go (Lam x e) | isId x = go e + 1 | otherwise = go e go (Tick t e) | not (tickishIsCode t) = go e go (Cast e co) = trim_arity (go e) (pSnd (coercionKind co)) -- Note [exprArity invariant] go (App e (Type _)) = go e go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 -- See Note [exprArity for applications] -- NB: coercions count as a value argument go _ = 0 trim_arity :: Arity -> Type -> Arity trim_arity arity ty = arity `min` length (typeArity ty) --------------- typeArity :: Type -> [OneShotInfo] -- How many value arrows are visible in the type? -- We look through foralls, and newtypes -- See Note [exprArity invariant] typeArity ty = go initRecTc ty where go rec_nts ty | Just (_, ty') <- splitForAllTy_maybe ty = go rec_nts ty' | Just (arg,res) <- splitFunTy_maybe ty = typeOneShot arg : go rec_nts res | Just (tc,tys) <- splitTyConApp_maybe ty , Just (ty', _) <- instNewTyCon_maybe tc tys , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] -- in TyCon -- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes -- -- See Note [Newtype classes and eta expansion] -- (no longer required) = go rec_nts' ty' -- Important to look through non-recursive newtypes, so that, eg -- (f x) where f has arity 2, f :: Int -> IO () -- Here we want to get arity 1 for the result! -- -- AND through a layer of recursive newtypes -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b))) | otherwise = [] --------------- exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig) -- A cheap and cheerful function that identifies bottoming functions -- and gives them a suitable strictness signatures. It's used during -- float-out exprBotStrictness_maybe e = case getBotArity (arityType env e) of Nothing -> Nothing Just ar -> Just (ar, sig ar) where env = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False } sig ar = mkClosedStrictSig (replicate ar topDmd) botRes {- Note [exprArity invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~ exprArity has the following invariants: (1) If typeArity (exprType e) = n, then manifestArity (etaExpand e n) = n That is, etaExpand can always expand as much as typeArity says So the case analysis in etaExpand and in typeArity must match (2) exprArity e <= typeArity (exprType e) (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n That is, if exprArity says "the arity is n" then etaExpand really can get "n" manifest lambdas to the top. Why is this important? Because - In TidyPgm we use exprArity to fix the *final arity* of each top-level Id, and in - In CorePrep we use etaExpand on each rhs, so that the visible lambdas actually match that arity, which in turn means that the StgRhs has the right number of lambdas An alternative would be to do the eta-expansion in TidyPgm, at least for top-level bindings, in which case we would not need the trim_arity in exprArity. That is a less local change, so I'm going to leave it for today! Note [Newtype classes and eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: this nasty special case is no longer required, because for newtype classes we don't use the class-op rule mechanism at all. See Note [Single-method classes] in TcInstDcls. SLPJ May 2013 -------- Old out of date comments, just for interest ----------- We have to be careful when eta-expanding through newtypes. In general it's a good idea, but annoyingly it interacts badly with the class-op rule mechanism. Consider class C a where { op :: a -> a } instance C b => C [b] where op x = ... These translate to co :: forall a. (a->a) ~ C a $copList :: C b -> [b] -> [b] $copList d x = ... $dfList :: C b -> C [b] {-# DFunUnfolding = [$copList] #-} $dfList d = $copList d |> co@[b] Now suppose we have: dCInt :: C Int blah :: [Int] -> [Int] blah = op ($dfList dCInt) Now we want the built-in op/$dfList rule will fire to give blah = $copList dCInt But with eta-expansion 'blah' might (and in #3772, which is slightly more complicated, does) turn into blah = op (\eta. ($dfList dCInt |> sym co) eta) and now it is *much* harder for the op/$dfList rule to fire, because exprIsConApp_maybe won't hold of the argument to op. I considered trying to *make* it hold, but it's tricky and I gave up. The test simplCore/should_compile/T3722 is an excellent example. -------- End of old out of date comments, just for interest ----------- Note [exprArity for applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we come to an application we check that the arg is trivial. eg f (fac x) does not have arity 2, even if f has arity 3! * We require that is trivial rather merely cheap. Suppose f has arity 2. Then f (Just y) has arity 0, because if we gave it arity 1 and then inlined f we'd get let v = Just y in \w. which has arity 0. And we try to maintain the invariant that we don't have arity decreases. * The `max 0` is important! (\x y -> f x) has arity 2, even if f is unknown, hence arity 0 ************************************************************************ * * Computing the "arity" of an expression * * ************************************************************************ Note [Definition of arity] ~~~~~~~~~~~~~~~~~~~~~~~~~~ The "arity" of an expression 'e' is n if applying 'e' to *fewer* than n *value* arguments converges rapidly Or, to put it another way there is no work lost in duplicating the partial application (e x1 .. x(n-1)) In the divegent case, no work is lost by duplicating because if the thing is evaluated once, that's the end of the program. Or, to put it another way, in any context C C[ (\x1 .. xn. e x1 .. xn) ] is as efficient as C[ e ] It's all a bit more subtle than it looks: Note [One-shot lambdas] ~~~~~~~~~~~~~~~~~~~~~~~ Consider one-shot lambdas let x = expensive in \y z -> E We want this to have arity 1 if the \y-abstraction is a 1-shot lambda. Note [Dealing with bottom] ~~~~~~~~~~~~~~~~~~~~~~~~~~ A Big Deal with computing arities is expressions like f = \x -> case x of True -> \s -> e1 False -> \s -> e2 This happens all the time when f :: Bool -> IO () In this case we do eta-expand, in order to get that \s to the top, and give f arity 2. This isn't really right in the presence of seq. Consider (f bot) `seq` 1 This should diverge! But if we eta-expand, it won't. We ignore this "problem" (unless -fpedantic-bottoms is on), because being scrupulous would lose an important transformation for many programs. (See #5587 for an example.) Consider also f = \x -> error "foo" Here, arity 1 is fine. But if it is f = \x -> case x of True -> error "foo" False -> \y -> x+y then we want to get arity 2. Technically, this isn't quite right, because (f True) `seq` 1 should diverge, but it'll converge if we eta-expand f. Nevertheless, we do so; it improves some programs significantly, and increasing convergence isn't a bad thing. Hence the ABot/ATop in ArityType. So these two transformations aren't always the Right Thing, and we have several tickets reporting unexpected behaviour resulting from this transformation. So we try to limit it as much as possible: (1) Do NOT move a lambda outside a known-bottom case expression case undefined of { (a,b) -> \y -> e } This showed up in #5557 (2) Do NOT move a lambda outside a case if all the branches of the case are known to return bottom. case x of { (a,b) -> \y -> error "urk" } This case is less important, but the idea is that if the fn is going to diverge eventually anyway then getting the best arity isn't an issue, so we might as well play safe (3) Do NOT move a lambda outside a case unless (a) The scrutinee is ok-for-speculation, or (b) more liberally: the scrutinee is cheap (e.g. a variable), and -fpedantic-bottoms is not enforced (see #2915 for an example) Of course both (1) and (2) are readily defeated by disguising the bottoms. 4. Note [Newtype arity] ~~~~~~~~~~~~~~~~~~~~~~~~ Non-recursive newtypes are transparent, and should not get in the way. We do (currently) eta-expand recursive newtypes too. So if we have, say newtype T = MkT ([T] -> Int) Suppose we have e = coerce T f where f has arity 1. Then: etaExpandArity e = 1; that is, etaExpandArity looks through the coerce. When we eta-expand e to arity 1: eta_expand 1 e T we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x) HOWEVER, note that if you use coerce bogusly you can ge coerce Int negate And since negate has arity 2, you might try to eta expand. But you can't decopose Int to a function type. Hence the final case in eta_expand. Note [The state-transformer hack] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have f = e where e has arity n. Then, if we know from the context that f has a usage type like t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ... then we can expand the arity to m. This usage type says that any application (x e1 .. en) will be applied to uniquely to (m-n) more args Consider f = \x. let y = in case x of True -> foo False -> \(s:RealWorld) -> e where foo has arity 1. Then we want the state hack to apply to foo too, so we can eta expand the case. Then we expect that if f is applied to one arg, it'll be applied to two (that's the hack -- we don't really know, and sometimes it's false) See also Id.isOneShotBndr. Note [State hack and bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's a terrible idea to use the state hack on a bottoming function. Here's what happens (#2861): f :: String -> IO T f = \p. error "..." Eta-expand, using the state hack: f = \p. (\s. ((error "...") |> g1) s) |> g2 g1 :: IO T ~ (S -> (S,T)) g2 :: (S -> (S,T)) ~ IO T Extrude the g2 f' = \p. \s. ((error "...") |> g1) s f = f' |> (String -> g2) Discard args for bottomming function f' = \p. \s. ((error "...") |> g1 |> g3 g3 :: (S -> (S,T)) ~ (S,T) Extrude g1.g3 f'' = \p. \s. (error "...") f' = f'' |> (String -> S -> g1.g3) And now we can repeat the whole loop. Aargh! The bug is in applying the state hack to a function which then swallows the argument. This arose in another guise in #3959. Here we had catch# (throw exn >> return ()) Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()]. After inlining (>>) we get catch# (\_. throw {IO ()} exn) We must *not* eta-expand to catch# (\_ _. throw {...} exn) because 'catch#' expects to get a (# _,_ #) after applying its argument to a State#, not another function! In short, we use the state hack to allow us to push let inside a lambda, but not to introduce a new lambda. Note [ArityType] ~~~~~~~~~~~~~~~~ ArityType is the result of a compositional analysis on expressions, from which we can decide the real arity of the expression (extracted with function exprEtaExpandArity). Here is what the fields mean. If an arbitrary expression 'f' has ArityType 'at', then * If at = ABot n, then (f x1..xn) definitely diverges. Partial applications to fewer than n args may *or may not* diverge. We allow ourselves to eta-expand bottoming functions, even if doing so may lose some `seq` sharing, let x = in \y. error (g x y) ==> \y. let x = in error (g x y) * If at = ATop as, and n=length as, then expanding 'f' to (\x1..xn. f x1 .. xn) loses no sharing, assuming the calls of f respect the one-shot-ness of its definition. NB 'f' is an arbitrary expression, eg (f = g e1 e2). This 'f' can have ArityType as ATop, with length as > 0, only if e1 e2 are themselves. * In both cases, f, (f x1), ... (f x1 ... f(n-1)) are definitely really functions, or bottom, but *not* casts from a data type, in at least one case branch. (If it's a function in one case branch but an unsafe cast from a data type in another, the program is bogus.) So eta expansion is dynamically ok; see Note [State hack and bottoming functions], the part about catch# Example: f = \x\y. let v = in \s(one-shot) \t(one-shot). blah 'f' has ArityType [ManyShot,ManyShot,OneShot,OneShot] The one-shot-ness means we can, in effect, push that 'let' inside the \st. Suppose f = \xy. x+y Then f :: AT [False,False] ATop f v :: AT [False] ATop f :: AT [] ATop -------------------- Main arity code ---------------------------- -} -- See Note [ArityType] data ArityType = ATop [OneShotInfo] | ABot Arity -- There is always an explicit lambda -- to justify the [OneShot], or the Arity instance Outputable ArityType where ppr (ATop os) = text "ATop" <> parens (ppr (length os)) ppr (ABot n) = text "ABot" <> parens (ppr n) vanillaArityType :: ArityType vanillaArityType = ATop [] -- Totally uninformative -- ^ The Arity returned is the number of value args the -- expression can be applied to without doing much work exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity -- exprEtaExpandArity is used when eta expanding -- e ==> \xy -> e x y exprEtaExpandArity dflags e = case (arityType env e) of ATop oss -> length oss ABot n -> n where env = AE { ae_cheap_fn = mk_cheap_fn dflags isCheapApp , ae_ped_bot = gopt Opt_PedanticBottoms dflags } getBotArity :: ArityType -> Maybe Arity -- Arity of a divergent function getBotArity (ABot n) = Just n getBotArity _ = Nothing mk_cheap_fn :: DynFlags -> CheapAppFun -> CheapFun mk_cheap_fn dflags cheap_app | not (gopt Opt_DictsCheap dflags) = \e _ -> exprIsCheapX cheap_app e | otherwise = \e mb_ty -> exprIsCheapX cheap_app e || case mb_ty of Nothing -> False Just ty -> isDictTy ty ---------------------- findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> (Arity, Bool) -- This implements the fixpoint loop for arity analysis -- See Note [Arity analysis] -- If findRhsArity e = (n, is_bot) then -- (a) any application of e to (\x1..xn. e x1 .. xn) -- (b) if is_bot=True, then e applied to n args is guaranteed bottom findRhsArity dflags bndr rhs old_arity = go (get_arity init_cheap_app) -- We always call exprEtaExpandArity once, but usually -- that produces a result equal to old_arity, and then -- we stop right away (since arities should not decrease) -- Result: the common case is that there is just one iteration where is_lam = has_lam rhs has_lam (Tick _ e) = has_lam e has_lam (Lam b e) = isId b || has_lam e has_lam _ = False init_cheap_app :: CheapAppFun init_cheap_app fn n_val_args | fn == bndr = True -- On the first pass, this binder gets infinite arity | otherwise = isCheapApp fn n_val_args go :: (Arity, Bool) -> (Arity, Bool) go cur_info@(cur_arity, _) | cur_arity <= old_arity = cur_info | new_arity == cur_arity = cur_info | otherwise = ASSERT( new_arity < cur_arity ) #if defined(DEBUG) pprTrace "Exciting arity" (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity , ppr rhs]) #endif go new_info where new_info@(new_arity, _) = get_arity cheap_app cheap_app :: CheapAppFun cheap_app fn n_val_args | fn == bndr = n_val_args < cur_arity | otherwise = isCheapApp fn n_val_args get_arity :: CheapAppFun -> (Arity, Bool) get_arity cheap_app = case (arityType env rhs) of ABot n -> (n, True) ATop (os:oss) | isOneShotInfo os || is_lam -> (1 + length oss, False) -- Don't expand PAPs/thunks ATop _ -> (0, False) -- Note [Eta expanding thunks] where env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app , ae_ped_bot = gopt Opt_PedanticBottoms dflags } {- Note [Arity analysis] ~~~~~~~~~~~~~~~~~~~~~ The motivating example for arity analysis is this: f = \x. let g = f (x+1) in \y. ...g... What arity does f have? Really it should have arity 2, but a naive look at the RHS won't see that. You need a fixpoint analysis which says it has arity "infinity" the first time round. This example happens a lot; it first showed up in Andy Gill's thesis, fifteen years ago! It also shows up in the code for 'rnf' on lists in #4138. The analysis is easy to achieve because exprEtaExpandArity takes an argument type CheapFun = CoreExpr -> Maybe Type -> Bool used to decide if an expression is cheap enough to push inside a lambda. And exprIsCheapX in turn takes an argument type CheapAppFun = Id -> Int -> Bool which tells when an application is cheap. This makes it easy to write the analysis loop. The analysis is cheap-and-cheerful because it doesn't deal with mutual recursion. But the self-recursive case is the important one. Note [Eta expanding through dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the experimental -fdicts-cheap flag is on, we eta-expand through dictionary bindings. This improves arities. Thereby, it also means that full laziness is less prone to floating out the application of a function to its dictionary arguments, which can thereby lose opportunities for fusion. Example: foo :: Ord a => a -> ... foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). .... -- So foo has arity 1 f = \x. foo dInt $ bar x The (foo DInt) is floated out, and makes ineffective a RULE foo (bar x) = ... One could go further and make exprIsCheap reply True to any dictionary-typed expression, but that's more work. Note [Eta expanding thunks] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ We don't eta-expand * Trivial RHSs x = y * PAPs x = map g * Thunks f = case y of p -> \x -> blah When we see f = case y of p -> \x -> blah should we eta-expand it? Well, if 'x' is a one-shot state token then 'yes' because 'f' will only be applied once. But otherwise we (conservatively) say no. My main reason is to avoid expanding PAPSs f = g d ==> f = \x. g d x because that might in turn make g inline (if it has an inline pragma), which we might not want. After all, INLINE pragmas say "inline only when saturated" so we don't want to be too gung-ho about saturating! -} arityLam :: Id -> ArityType -> ArityType arityLam id (ATop as) = ATop (idStateHackOneShotInfo id : as) arityLam _ (ABot n) = ABot (n+1) floatIn :: Bool -> ArityType -> ArityType -- We have something like (let x = E in b), -- where b has the given arity type. floatIn _ (ABot n) = ABot n floatIn True (ATop as) = ATop as floatIn False (ATop as) = ATop (takeWhile isOneShotInfo as) -- If E is not cheap, keep arity only for one-shots arityApp :: ArityType -> Bool -> ArityType -- Processing (fun arg) where at is the ArityType of fun, -- Knock off an argument and behave like 'let' arityApp (ABot 0) _ = ABot 0 arityApp (ABot n) _ = ABot (n-1) arityApp (ATop []) _ = ATop [] arityApp (ATop (_:as)) cheap = floatIn cheap (ATop as) andArityType :: ArityType -> ArityType -> ArityType -- Used for branches of a 'case' andArityType (ABot n1) (ABot n2) = ABot (n1 `max` n2) -- Note [ABot branches: use max] andArityType (ATop as) (ABot _) = ATop as andArityType (ABot _) (ATop bs) = ATop bs andArityType (ATop as) (ATop bs) = ATop (as `combine` bs) where -- See Note [Combining case branches] combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs combine [] bs = takeWhile isOneShotInfo bs combine as [] = takeWhile isOneShotInfo as {- Note [ABot branches: use max] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider case x of True -> \x. error "urk" False -> \xy. error "urk2" Remember: ABot n means "if you apply to n args, it'll definitely diverge". So we need (ABot 2) for the whole thing, the /max/ of the ABot arities. Note [Combining case branches] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider go = \x. let z = go e0 go2 = \x. case x of True -> z False -> \s(one-shot). e1 in go2 x We *really* want to eta-expand go and go2. When combining the branches of the case we have ATop [] `andAT` ATop [OneShotLam] and we want to get ATop [OneShotLam]. But if the inner lambda wasn't one-shot we don't want to do this. (We need a proper arity analysis to justify that.) So we combine the best of the two branches, on the (slightly dodgy) basis that if we know one branch is one-shot, then they all must be. Note [Arity trimming] ~~~~~~~~~~~~~~~~~~~~~ Consider ((\x y. blah) |> co), where co :: (Int->Int->Int) ~ (Int -> F a) , and F is some type family. Because of Note [exprArity invariant], item (2), we must return with arity at most 1, because typeArity (Int -> F a) = 1. So we have to trim the result of calling arityType on (\x y. blah). Failing to do so, and hence breaking the exprArity invariant, led to #5441. How to trim? For ATop, it's easy. But we must take great care with ABot. Suppose the expression was (\x y. error "urk"), we'll get (ABot 2). We absolutely must not trim that to (ABot 1), because that claims that ((\x y. error "urk") |> co) diverges when given one argument, which it absolutely does not. And Bad Things happen if we think something returns bottom when it doesn't (#16066). So, do not reduce the 'n' in (ABot n); rather, switch (conservatively) to ATop. Historical note: long ago, we unconditionally switched to ATop when we encountered a cast, but that is far too conservative: see #5475 -} --------------------------- type CheapFun = CoreExpr -> Maybe Type -> Bool -- How to decide if an expression is cheap -- If the Maybe is Just, the type is the type -- of the expression; Nothing means "don't know" data ArityEnv = AE { ae_cheap_fn :: CheapFun , ae_ped_bot :: Bool -- True <=> be pedantic about bottoms } arityType :: ArityEnv -> CoreExpr -> ArityType arityType env (Cast e co) = case arityType env e of ATop os -> ATop (take co_arity os) -- See Note [Arity trimming] ABot n | co_arity < n -> ATop (replicate co_arity noOneShotInfo) | otherwise -> ABot n where co_arity = length (typeArity (pSnd (coercionKind co))) -- See Note [exprArity invariant] (2); must be true of -- arityType too, since that is how we compute the arity -- of variables, and they in turn affect result of exprArity -- #5441 is a nice demo -- However, do make sure that ATop -> ATop and ABot -> ABot! -- Casts don't affect that part. Getting this wrong provoked #5475 arityType _ (Var v) | strict_sig <- idStrictness v , not $ isTopSig strict_sig , (ds, res) <- splitStrictSig strict_sig , let arity = length ds = if isBotRes res then ABot arity else ATop (take arity one_shots) | otherwise = ATop (take (idArity v) one_shots) where one_shots :: [OneShotInfo] -- One-shot-ness derived from the type one_shots = typeArity (idType v) -- Lambdas; increase arity arityType env (Lam x e) | isId x = arityLam x (arityType env e) | otherwise = arityType env e -- Applications; decrease arity, except for types arityType env (App fun (Type _)) = arityType env fun arityType env (App fun arg ) = arityApp (arityType env fun) (ae_cheap_fn env arg Nothing) -- Case/Let; keep arity if either the expression is cheap -- or it's a 1-shot lambda -- The former is not really right for Haskell -- f x = case x of { (a,b) -> \y. e } -- ===> -- f x y = case x of { (a,b) -> e } -- The difference is observable using 'seq' -- arityType env (Case scrut _ _ alts) | exprIsBottom scrut || null alts = ABot 0 -- Do not eta expand -- See Note [Dealing with bottom (1)] | otherwise = case alts_type of ABot n | n>0 -> ATop [] -- Don't eta expand | otherwise -> ABot 0 -- if RHS is bottomming -- See Note [Dealing with bottom (2)] ATop as | not (ae_ped_bot env) -- See Note [Dealing with bottom (3)] , ae_cheap_fn env scrut Nothing -> ATop as | exprOkForSpeculation scrut -> ATop as | otherwise -> ATop (takeWhile isOneShotInfo as) where alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts] arityType env (Let b e) = floatIn (cheap_bind b) (arityType env e) where cheap_bind (NonRec b e) = is_cheap (b,e) cheap_bind (Rec prs) = all is_cheap prs is_cheap (b,e) = ae_cheap_fn env e (Just (idType b)) arityType env (Tick t e) | not (tickishIsCode t) = arityType env e arityType _ _ = vanillaArityType {- %************************************************************************ %* * The main eta-expander %* * %************************************************************************ We go for: f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym (n >= 0) where (in both cases) * The xi can include type variables * The yi are all value variables * N is a NORMAL FORM (i.e. no redexes anywhere) wanting a suitable number of extra args. The biggest reason for doing this is for cases like f = \x -> case x of True -> \y -> e1 False -> \y -> e2 Here we want to get the lambdas together. A good example is the nofib program fibheaps, which gets 25% more allocation if you don't do this eta-expansion. We may have to sandwich some coerces between the lambdas to make the types work. exprEtaExpandArity looks through coerces when computing arity; and etaExpand adds the coerces as necessary when actually computing the expansion. Note [No crap in eta-expanded code] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The eta expander is careful not to introduce "crap". In particular, given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it returns a CoreExpr satisfying the same invariant. See Note [Eta expansion and the CorePrep invariants] in CorePrep. This means the eta-expander has to do a bit of on-the-fly simplification but it's not too hard. The alernative, of relying on a subsequent clean-up phase of the Simplifier to de-crapify the result, means you can't really use it in CorePrep, which is painful. Note [Eta expansion for join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The no-crap rule is very tiresome to guarantee when we have join points. Consider eta-expanding let j :: Int -> Int -> Bool j x = e in b The simple way is \(y::Int). (let j x = e in b) y The no-crap way is \(y::Int). let j' :: Int -> Bool j' x = e y in b[j'/j] y where I have written to stress that j's type has changed. Note that (of course!) we have to push the application inside the RHS of the join as well as into the body. AND if j has an unfolding we have to push it into there too. AND j might be recursive... So for now I'm abandoning the no-crap rule in this case. I think that for the use in CorePrep it really doesn't matter; and if it does, then CoreToStg.myCollectArgs will fall over. (Moreover, I think that casts can make the no-crap rule fail too.) Note [Eta expansion and SCCs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that SCCs are not treated specially by etaExpand. If we have etaExpand 2 (\x -> scc "foo" e) = (\xy -> (scc "foo" e) y) So the costs of evaluating 'e' (not 'e y') are attributed to "foo" Note [Eta expansion and source notes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ CorePrep puts floatable ticks outside of value applications, but not type applications. As a result we might be trying to eta-expand an expression like (src<...> v) @a which we want to lead to code like \x -> src<...> v @a x This means that we need to look through type applications and be ready to re-add floats on the top. -} -- | @etaExpand n e@ returns an expression with -- the same meaning as @e@, but with arity @n@. -- -- Given: -- -- > e' = etaExpand n e -- -- We should have that: -- -- > ty = exprType e = exprType e' etaExpand :: Arity -- ^ Result should have this number of value args -> CoreExpr -- ^ Expression to expand -> CoreExpr -- etaExpand arity e = res -- Then 'res' has at least 'arity' lambdas at the top -- -- etaExpand deals with for-alls. For example: -- etaExpand 1 E -- where E :: forall a. a -> a -- would return -- (/\b. \y::a -> E b y) -- -- It deals with coerces too, though they are now rare -- so perhaps the extra code isn't worth it etaExpand n orig_expr = go n orig_expr where -- Strip off existing lambdas and casts -- Note [Eta expansion and SCCs] go 0 expr = expr go n (Lam v body) | isTyVar v = Lam v (go n body) | otherwise = Lam v (go (n-1) body) go n (Cast expr co) = Cast (go n expr) co go n expr = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $ retick $ etaInfoAbs etas (etaInfoApp subst' sexpr etas) where in_scope = mkInScopeSet (exprFreeVars expr) (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr) subst' = mkEmptySubst in_scope' -- Find ticks behind type apps. -- See Note [Eta expansion and source notes] (expr', args) = collectArgs expr (ticks, expr'') = stripTicksTop tickishFloatable expr' sexpr = foldl' App expr'' args retick expr = foldr mkTick expr ticks -- Abstraction Application -------------- data EtaInfo = EtaVar Var -- /\a. [] [] a -- \x. [] [] x | EtaCo Coercion -- [] |> sym co [] |> co instance Outputable EtaInfo where ppr (EtaVar v) = text "EtaVar" <+> ppr v ppr (EtaCo co) = text "EtaCo" <+> ppr co pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo] pushCoercion co1 (EtaCo co2 : eis) | isReflCo co = eis | otherwise = EtaCo co : eis where co = co1 `mkTransCo` co2 pushCoercion co eis = EtaCo co : eis -------------- etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr etaInfoAbs [] expr = expr etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr) etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co) -------------- etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr -- (etaInfoApp s e eis) returns something equivalent to -- ((substExpr s e) `appliedto` eis) etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis) = etaInfoApp (CoreSubst.extendSubstWithVar subst v1 v2) e eis etaInfoApp subst (Cast e co1) eis = etaInfoApp subst e (pushCoercion co' eis) where co' = CoreSubst.substCo subst co1 etaInfoApp subst (Case e b ty alts) eis = Case (subst_expr subst e) b1 ty' alts' where (subst1, b1) = substBndr subst b alts' = map subst_alt alts ty' = etaInfoAppTy (CoreSubst.substTy subst ty) eis subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis) where (subst2,bs') = substBndrs subst1 bs etaInfoApp subst (Let b e) eis | not (isJoinBind b) -- See Note [Eta expansion for join points] = Let b' (etaInfoApp subst' e eis) where (subst', b') = substBindSC subst b etaInfoApp subst (Tick t e) eis = Tick (substTickish subst t) (etaInfoApp subst e eis) etaInfoApp subst expr _ | (Var fun, _) <- collectArgs expr , Var fun' <- lookupIdSubst (text "etaInfoApp" <+> ppr fun) subst fun , isJoinId fun' = subst_expr subst expr etaInfoApp subst e eis = go (subst_expr subst e) eis where go e [] = e go e (EtaVar v : eis) = go (App e (varToCoreExpr v)) eis go e (EtaCo co : eis) = go (Cast e co) eis -------------- etaInfoAppTy :: Type -> [EtaInfo] -> Type -- If e :: ty -- then etaInfoApp e eis :: etaInfoApp ty eis etaInfoAppTy ty [] = ty etaInfoAppTy ty (EtaVar v : eis) = etaInfoAppTy (applyTypeToArg ty (varToCoreExpr v)) eis etaInfoAppTy _ (EtaCo co : eis) = etaInfoAppTy (pSnd (coercionKind co)) eis -------------- mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type -> (InScopeSet, [EtaInfo]) -- EtaInfo contains fresh variables, -- not free in the incoming CoreExpr -- Outgoing InScopeSet includes the EtaInfo vars -- and the original free vars mkEtaWW orig_n orig_expr in_scope orig_ty = go orig_n empty_subst orig_ty [] where empty_subst = mkEmptyTCvSubst in_scope go :: Arity -- Number of value args to expand to -> TCvSubst -> Type -- We are really looking at subst(ty) -> [EtaInfo] -- Accumulating parameter -> (InScopeSet, [EtaInfo]) go n subst ty eis -- See Note [exprArity invariant] ----------- Done! No more expansion needed | n == 0 = (getTCvInScope subst, reverse eis) ----------- Forall types (forall a. ty) | Just (tcv,ty') <- splitForAllTy_maybe ty , let (subst', tcv') = Type.substVarBndr subst tcv = let ((n_subst, n_tcv), n_n) -- We want to have at least 'n' lambdas at the top. -- If tcv is a tyvar, it corresponds to one Lambda (/\). -- And we won't reduce n. -- If tcv is a covar, we could eta-expand the expr with one -- lambda \co:ty. e co. In this case we generate a new variable -- of the coercion type, update the scope, and reduce n by 1. | isTyVar tcv = ((subst', tcv'), n) | otherwise = (freshEtaId n subst' (varType tcv'), n-1) -- Avoid free vars of the original expression in go n_n n_subst ty' (EtaVar n_tcv : eis) ----------- Function types (t1 -> t2) | Just (arg_ty, res_ty) <- splitFunTy_maybe ty , not (isTypeLevPoly arg_ty) -- See Note [Levity polymorphism invariants] in CoreSyn -- See also test case typecheck/should_run/EtaExpandLevPoly , let (subst', eta_id') = freshEtaId n subst arg_ty -- Avoid free vars of the original expression = go (n-1) subst' res_ty (EtaVar eta_id' : eis) ----------- Newtypes -- Given this: -- newtype T = MkT ([T] -> Int) -- Consider eta-expanding this -- eta_expand 1 e T -- We want to get -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) | Just (co, ty') <- topNormaliseNewType_maybe ty , let co' = Coercion.substCo subst co -- Remember to apply the substitution to co (#16979) -- (or we could have applied to ty, but then -- we'd have had to zap it for the recursive call) = go n subst ty' (pushCoercion co' eis) | otherwise -- We have an expression of arity > 0, -- but its type isn't a function, or a binder -- is levity-polymorphic = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr ) (getTCvInScope subst, reverse eis) -- This *can* legitmately happen: -- e.g. coerce Int (\x. x) Essentially the programmer is -- playing fast and loose with types (Happy does this a lot). -- So we simply decline to eta-expand. Otherwise we'd end up -- with an explicit lambda having a non-function type -------------- -- Don't use short-cutting substitution - we may be changing the types of join -- points, so applying the in-scope set is necessary -- TODO Check if we actually *are* changing any join points' types subst_expr :: Subst -> CoreExpr -> CoreExpr subst_expr = substExpr (text "CoreArity:substExpr") -------------- -- | Split an expression into the given number of binders and a body, -- eta-expanding if necessary. Counts value *and* type binders. etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr) etaExpandToJoinPoint join_arity expr = go join_arity [] expr where go 0 rev_bs e = (reverse rev_bs, e) go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e go n rev_bs e = case etaBodyForJoinPoint n e of (bs, e') -> (reverse rev_bs ++ bs, e') etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule etaExpandToJoinPointRule _ rule@(BuiltinRule {}) = WARN(True, (sep [text "Can't eta-expand built-in rule:", ppr rule])) -- How did a local binding get a built-in rule anyway? Probably a plugin. rule etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs , ru_args = args }) | need_args == 0 = rule | need_args < 0 = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule) | otherwise = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args , ru_rhs = new_rhs } where need_args = join_arity - length args (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs new_args = varsToCoreExprs new_bndrs -- Adds as many binders as asked for; assumes expr is not a lambda etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr) etaBodyForJoinPoint need_args body = go need_args (exprType body) (init_subst body) [] body where go 0 _ _ rev_bs e = (reverse rev_bs, e) go n ty subst rev_bs e | Just (tv, res_ty) <- splitForAllTy_maybe ty , let (subst', tv') = Type.substVarBndr subst tv = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv') | Just (arg_ty, res_ty) <- splitFunTy_maybe ty , let (subst', b) = freshEtaId n subst arg_ty = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b) | otherwise = pprPanic "etaBodyForJoinPoint" $ int need_args $$ ppr body $$ ppr (exprType body) init_subst e = mkEmptyTCvSubst (mkInScopeSet (exprFreeVars e)) -------------- freshEtaId :: Int -> TCvSubst -> Type -> (TCvSubst, Id) -- Make a fresh Id, with specified type (after applying substitution) -- It should be "fresh" in the sense that it's not in the in-scope set -- of the TvSubstEnv; and it should itself then be added to the in-scope -- set of the TvSubstEnv -- -- The Int is just a reasonable starting point for generating a unique; -- it does not necessarily have to be unique itself. freshEtaId n subst ty = (subst', eta_id') where ty' = Type.substTyUnchecked subst ty eta_id' = uniqAway (getTCvInScope subst) $ mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) ty' subst' = extendTCvInScope subst eta_id' ghc-lib-parser-8.10.2.20200808/compiler/coreSyn/CoreFVs.hs0000644000000000000000000007346713713635744020626 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 Taken quite directly from the Peyton Jones/Lester paper. -} {-# LANGUAGE CPP #-} -- | A module concerned with finding the free variables of an expression. module CoreFVs ( -- * Free variables of expressions and binding groups exprFreeVars, exprFreeVarsDSet, exprFreeVarsList, exprFreeIds, exprFreeIdsDSet, exprFreeIdsList, exprsFreeIdsDSet, exprsFreeIdsList, exprsFreeVars, exprsFreeVarsList, bindFreeVars, -- * Selective free variables of expressions InterestingVarFun, exprSomeFreeVars, exprsSomeFreeVars, exprSomeFreeVarsList, exprsSomeFreeVarsList, -- * Free variables of Rules, Vars and Ids varTypeTyCoVars, varTypeTyCoFVs, idUnfoldingVars, idFreeVars, dIdFreeVars, bndrRuleAndUnfoldingVarsDSet, idFVs, idRuleVars, idRuleRhsVars, stableUnfoldingVars, ruleRhsFreeVars, ruleFreeVars, rulesFreeVars, rulesFreeVarsDSet, ruleLhsFreeIds, ruleLhsFreeIdsList, expr_fvs, -- * Orphan names orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom, orphNamesOfTypes, orphNamesOfCoCon, exprsOrphNames, orphNamesOfFamInst, -- * Core syntax tree annotation with free variables FVAnn, -- annotation, abstract CoreExprWithFVs, -- = AnnExpr Id FVAnn CoreExprWithFVs', -- = AnnExpr' Id FVAnn CoreBindWithFVs, -- = AnnBind Id FVAnn CoreAltWithFVs, -- = AnnAlt Id FVAnn freeVars, -- CoreExpr -> CoreExprWithFVs freeVarsBind, -- CoreBind -> DVarSet -> (DVarSet, CoreBindWithFVs) freeVarsOf, -- CoreExprWithFVs -> DIdSet freeVarsOfAnn ) where #include "GhclibHsVersions.h" import GhcPrelude import CoreSyn import Id import IdInfo import NameSet import UniqSet import Unique (Uniquable (..)) import Name import VarSet import Var import Type import TyCoRep import TyCoFVs import TyCon import CoAxiom import FamInstEnv import TysPrim( funTyConName ) import Maybes( orElse ) import Util import BasicTypes( Activation ) import Outputable import FV {- ************************************************************************ * * \section{Finding the free variables of an expression} * * ************************************************************************ This function simply finds the free variables of an expression. So far as type variables are concerned, it only finds tyvars that are * free in type arguments, * free in the type of a binder, but not those that are free in the type of variable occurrence. -} -- | Find all locally-defined free Ids or type variables in an expression -- returning a non-deterministic set. exprFreeVars :: CoreExpr -> VarSet exprFreeVars = fvVarSet . exprFVs -- | Find all locally-defined free Ids or type variables in an expression -- returning a composable FV computation. See Note [FV naming conventions] in FV -- for why export it. exprFVs :: CoreExpr -> FV exprFVs = filterFV isLocalVar . expr_fvs -- | Find all locally-defined free Ids or type variables in an expression -- returning a deterministic set. exprFreeVarsDSet :: CoreExpr -> DVarSet exprFreeVarsDSet = fvDVarSet . exprFVs -- | Find all locally-defined free Ids or type variables in an expression -- returning a deterministically ordered list. exprFreeVarsList :: CoreExpr -> [Var] exprFreeVarsList = fvVarList . exprFVs -- | Find all locally-defined free Ids in an expression exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids exprFreeIds = exprSomeFreeVars isLocalId -- | Find all locally-defined free Ids in an expression -- returning a deterministic set. exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids exprFreeIdsDSet = exprSomeFreeVarsDSet isLocalId -- | Find all locally-defined free Ids in an expression -- returning a deterministically ordered list. exprFreeIdsList :: CoreExpr -> [Id] -- Find all locally-defined free Ids exprFreeIdsList = exprSomeFreeVarsList isLocalId -- | Find all locally-defined free Ids in several expressions -- returning a deterministic set. exprsFreeIdsDSet :: [CoreExpr] -> DIdSet -- Find all locally-defined free Ids exprsFreeIdsDSet = exprsSomeFreeVarsDSet isLocalId -- | Find all locally-defined free Ids in several expressions -- returning a deterministically ordered list. exprsFreeIdsList :: [CoreExpr] -> [Id] -- Find all locally-defined free Ids exprsFreeIdsList = exprsSomeFreeVarsList isLocalId -- | Find all locally-defined free Ids or type variables in several expressions -- returning a non-deterministic set. exprsFreeVars :: [CoreExpr] -> VarSet exprsFreeVars = fvVarSet . exprsFVs -- | Find all locally-defined free Ids or type variables in several expressions -- returning a composable FV computation. See Note [FV naming conventions] in FV -- for why export it. exprsFVs :: [CoreExpr] -> FV exprsFVs exprs = mapUnionFV exprFVs exprs -- | Find all locally-defined free Ids or type variables in several expressions -- returning a deterministically ordered list. exprsFreeVarsList :: [CoreExpr] -> [Var] exprsFreeVarsList = fvVarList . exprsFVs -- | Find all locally defined free Ids in a binding group bindFreeVars :: CoreBind -> VarSet bindFreeVars (NonRec b r) = fvVarSet $ filterFV isLocalVar $ rhs_fvs (b,r) bindFreeVars (Rec prs) = fvVarSet $ filterFV isLocalVar $ addBndrs (map fst prs) (mapUnionFV rhs_fvs prs) -- | Finds free variables in an expression selected by a predicate exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting -> CoreExpr -> VarSet exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ expr_fvs e -- | Finds free variables in an expression selected by a predicate -- returning a deterministically ordered list. exprSomeFreeVarsList :: InterestingVarFun -- ^ Says which 'Var's are interesting -> CoreExpr -> [Var] exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ expr_fvs e -- | Finds free variables in an expression selected by a predicate -- returning a deterministic set. exprSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting -> CoreExpr -> DVarSet exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ expr_fvs e -- | Finds free variables in several expressions selected by a predicate exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting -> [CoreExpr] -> VarSet exprsSomeFreeVars fv_cand es = fvVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs es -- | Finds free variables in several expressions selected by a predicate -- returning a deterministically ordered list. exprsSomeFreeVarsList :: InterestingVarFun -- Says which 'Var's are interesting -> [CoreExpr] -> [Var] exprsSomeFreeVarsList fv_cand es = fvVarList $ filterFV fv_cand $ mapUnionFV expr_fvs es -- | Finds free variables in several expressions selected by a predicate -- returning a deterministic set. exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting -> [CoreExpr] -> DVarSet exprsSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e -- Comment about obselete code -- We used to gather the free variables the RULES at a variable occurrence -- with the following cryptic comment: -- "At a variable occurrence, add in any free variables of its rule rhss -- Curiously, we gather the Id's free *type* variables from its binding -- site, but its free *rule-rhs* variables from its usage sites. This -- is a little weird. The reason is that the former is more efficient, -- but the latter is more fine grained, and a makes a difference when -- a variable mentions itself one of its own rule RHSs" -- Not only is this "weird", but it's also pretty bad because it can make -- a function seem more recursive than it is. Suppose -- f = ...g... -- g = ... -- RULE g x = ...f... -- Then f is not mentioned in its own RHS, and needn't be a loop breaker -- (though g may be). But if we collect the rule fvs from g's occurrence, -- it looks as if f mentions itself. (This bites in the eftInt/eftIntFB -- code in GHC.Enum.) -- -- Anyway, it seems plain wrong. The RULE is like an extra RHS for the -- function, so its free variables belong at the definition site. -- -- Deleted code looked like -- foldVarSet add_rule_var var_itself_set (idRuleVars var) -- add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var -- | otherwise = set -- SLPJ Feb06 addBndr :: CoreBndr -> FV -> FV addBndr bndr fv fv_cand in_scope acc = (varTypeTyCoFVs bndr `unionFV` -- Include type variables in the binder's type -- (not just Ids; coercion variables too!) FV.delFV bndr fv) fv_cand in_scope acc addBndrs :: [CoreBndr] -> FV -> FV addBndrs bndrs fv = foldr addBndr fv bndrs expr_fvs :: CoreExpr -> FV expr_fvs (Type ty) fv_cand in_scope acc = tyCoFVsOfType ty fv_cand in_scope acc expr_fvs (Coercion co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc expr_fvs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc expr_fvs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc expr_fvs (Tick t expr) fv_cand in_scope acc = (tickish_fvs t `unionFV` expr_fvs expr) fv_cand in_scope acc expr_fvs (App fun arg) fv_cand in_scope acc = (expr_fvs fun `unionFV` expr_fvs arg) fv_cand in_scope acc expr_fvs (Lam bndr body) fv_cand in_scope acc = addBndr bndr (expr_fvs body) fv_cand in_scope acc expr_fvs (Cast expr co) fv_cand in_scope acc = (expr_fvs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr (mapUnionFV alt_fvs alts)) fv_cand in_scope acc where alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body)) fv_cand in_scope acc expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc = addBndrs (map fst pairs) (mapUnionFV rhs_fvs pairs `unionFV` expr_fvs body) fv_cand in_scope acc --------- rhs_fvs :: (Id, CoreExpr) -> FV rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV` bndrRuleAndUnfoldingFVs bndr -- Treat any RULES as extra RHSs of the binding --------- exprs_fvs :: [CoreExpr] -> FV exprs_fvs exprs = mapUnionFV expr_fvs exprs tickish_fvs :: Tickish Id -> FV tickish_fvs (Breakpoint _ ids) = FV.mkFVs ids tickish_fvs _ = emptyFV {- ************************************************************************ * * \section{Free names} * * ************************************************************************ -} -- | Finds the free /external/ names of an expression, notably -- including the names of type constructors (which of course do not show -- up in 'exprFreeVars'). exprOrphNames :: CoreExpr -> NameSet -- There's no need to delete local binders, because they will all -- be /internal/ names. exprOrphNames e = go e where go (Var v) | isExternalName n = unitNameSet n | otherwise = emptyNameSet where n = idName v go (Lit _) = emptyNameSet go (Type ty) = orphNamesOfType ty -- Don't need free tyvars go (Coercion co) = orphNamesOfCo co go (App e1 e2) = go e1 `unionNameSet` go e2 go (Lam v e) = go e `delFromNameSet` idName v go (Tick _ e) = go e go (Cast e co) = go e `unionNameSet` orphNamesOfCo co go (Let (NonRec _ r) e) = go e `unionNameSet` go r go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSet` go e go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty `unionNameSet` unionNameSets (map go_alt as) go_alt (_,_,r) = go r -- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details exprsOrphNames :: [CoreExpr] -> NameSet exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es {- ********************************************************************** %* * orphNamesXXX %* * %********************************************************************* -} orphNamesOfTyCon :: TyCon -> NameSet orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of Nothing -> emptyNameSet Just cls -> unitNameSet (getName cls) orphNamesOfType :: Type -> NameSet orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty' -- Look through type synonyms (#4912) orphNamesOfType (TyVarTy _) = emptyNameSet orphNamesOfType (LitTy {}) = emptyNameSet orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon `unionNameSet` orphNamesOfTypes tys orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) `unionNameSet` orphNamesOfType res orphNamesOfType (FunTy _ arg res) = unitNameSet funTyConName -- NB! See #8535 `unionNameSet` orphNamesOfType arg `unionNameSet` orphNamesOfType res orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co orphNamesOfType (CoercionTy co) = orphNamesOfCo co orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet orphNamesOfTypes :: [Type] -> NameSet orphNamesOfTypes = orphNamesOfThings orphNamesOfType orphNamesOfMCo :: MCoercion -> NameSet orphNamesOfMCo MRefl = emptyNameSet orphNamesOfMCo (MCo co) = orphNamesOfCo co orphNamesOfCo :: Coercion -> NameSet orphNamesOfCo (Refl ty) = orphNamesOfType ty orphNamesOfCo (GRefl _ ty mco) = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 orphNamesOfCo (ForAllCo _ kind_co co) = orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co orphNamesOfCo (FunCo _ co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 orphNamesOfCo (CoVarCo _) = emptyNameSet orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2 orphNamesOfCo (SymCo co) = orphNamesOfCo co orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 orphNamesOfCo (NthCo _ _ co) = orphNamesOfCo co orphNamesOfCo (LRCo _ co) = orphNamesOfCo co orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg orphNamesOfCo (KindCo co) = orphNamesOfCo co orphNamesOfCo (SubCo co) = orphNamesOfCo co orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs orphNamesOfCo (HoleCo _) = emptyNameSet orphNamesOfProv :: UnivCoProvenance -> NameSet orphNamesOfProv UnsafeCoerceProv = emptyNameSet orphNamesOfProv (PhantomProv co) = orphNamesOfCo co orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co orphNamesOfProv (PluginProv _) = emptyNameSet orphNamesOfCos :: [Coercion] -> NameSet orphNamesOfCos = orphNamesOfThings orphNamesOfCo orphNamesOfCoCon :: CoAxiom br -> NameSet orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches orphNamesOfAxiom :: CoAxiom br -> NameSet orphNamesOfAxiom axiom = orphNamesOfTypes (concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom) `extendNameSet` getName (coAxiomTyCon axiom) orphNamesOfCoAxBranches :: Branches br -> NameSet orphNamesOfCoAxBranches = foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches orphNamesOfCoAxBranch :: CoAxBranch -> NameSet orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }) = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs -- | orphNamesOfAxiom collects the names of the concrete types and -- type constructors that make up the LHS of a type family instance, -- including the family name itself. -- -- For instance, given `type family Foo a b`: -- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H] -- -- Used in the implementation of ":info" in GHCi. orphNamesOfFamInst :: FamInst -> NameSet orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst) {- ************************************************************************ * * \section[freevars-everywhere]{Attaching free variables to every sub-expression} * * ************************************************************************ -} -- | Those variables free in the right hand side of a rule returned as a -- non-deterministic set ruleRhsFreeVars :: CoreRule -> VarSet ruleRhsFreeVars (BuiltinRule {}) = noFVs ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs }) = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs) -- See Note [Rule free var hack] -- | Those variables free in the both the left right hand sides of a rule -- returned as a non-deterministic set ruleFreeVars :: CoreRule -> VarSet ruleFreeVars = fvVarSet . ruleFVs -- | Those variables free in the both the left right hand sides of a rule -- returned as FV computation ruleFVs :: CoreRule -> FV ruleFVs (BuiltinRule {}) = emptyFV ruleFVs (Rule { ru_fn = _do_not_include -- See Note [Rule free var hack] , ru_bndrs = bndrs , ru_rhs = rhs, ru_args = args }) = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args)) -- | Those variables free in the both the left right hand sides of rules -- returned as FV computation rulesFVs :: [CoreRule] -> FV rulesFVs = mapUnionFV ruleFVs -- | Those variables free in the both the left right hand sides of rules -- returned as a deterministic set rulesFreeVarsDSet :: [CoreRule] -> DVarSet rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet -- Just the variables free on the *rhs* of a rule idRuleRhsVars is_active id = mapUnionVarSet get_fvs (idCoreRules id) where get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs , ru_rhs = rhs, ru_act = act }) | is_active act -- See Note [Finding rule RHS free vars] in OccAnal.hs = delOneFromUniqSet_Directly fvs (getUnique fn) -- Note [Rule free var hack] where fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs) get_fvs _ = noFVs -- | Those variables free in the right hand side of several rules rulesFreeVars :: [CoreRule] -> VarSet rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules ruleLhsFreeIds :: CoreRule -> VarSet -- ^ This finds all locally-defined free Ids on the left hand side of a rule -- and returns them as a non-deterministic set ruleLhsFreeIds = fvVarSet . ruleLhsFVIds ruleLhsFreeIdsList :: CoreRule -> [Var] -- ^ This finds all locally-defined free Ids on the left hand side of a rule -- and returns them as a determinisitcally ordered list ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds ruleLhsFVIds :: CoreRule -> FV -- ^ This finds all locally-defined free Ids on the left hand side of a rule -- and returns an FV computation ruleLhsFVIds (BuiltinRule {}) = emptyFV ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args }) = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args) {- Note [Rule free var hack] (Not a hack any more) ~~~~~~~~~~~~~~~~~~~~~~~~~ We used not to include the Id in its own rhs free-var set. Otherwise the occurrence analyser makes bindings recursive: f x y = x+y RULE: f (f x y) z ==> f x (f y z) However, the occurrence analyser distinguishes "non-rule loop breakers" from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will put this 'f' in a Rec block, but will mark the binding as a non-rule loop breaker, which is perfectly inlinable. -} {- ************************************************************************ * * \section[freevars-everywhere]{Attaching free variables to every sub-expression} * * ************************************************************************ The free variable pass annotates every node in the expression with its NON-GLOBAL free variables and type variables. -} type FVAnn = DVarSet -- See Note [The FVAnn invariant] {- Note [The FVAnn invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Invariant: a FVAnn, say S, is closed: That is: if v is in S, then freevars( v's type/kind ) is also in S -} -- | Every node in a binding group annotated with its -- (non-global) free variables, both Ids and TyVars, and type. type CoreBindWithFVs = AnnBind Id FVAnn -- | Every node in an expression annotated with its -- (non-global) free variables, both Ids and TyVars, and type. -- NB: see Note [The FVAnn invariant] type CoreExprWithFVs = AnnExpr Id FVAnn type CoreExprWithFVs' = AnnExpr' Id FVAnn -- | Every node in an expression annotated with its -- (non-global) free variables, both Ids and TyVars, and type. type CoreAltWithFVs = AnnAlt Id FVAnn freeVarsOf :: CoreExprWithFVs -> DIdSet -- ^ Inverse function to 'freeVars' freeVarsOf (fvs, _) = fvs -- | Extract the vars reported in a FVAnn freeVarsOfAnn :: FVAnn -> DIdSet freeVarsOfAnn fvs = fvs noFVs :: VarSet noFVs = emptyVarSet aFreeVar :: Var -> DVarSet aFreeVar = unitDVarSet unionFVs :: DVarSet -> DVarSet -> DVarSet unionFVs = unionDVarSet unionFVss :: [DVarSet] -> DVarSet unionFVss = unionDVarSets delBindersFV :: [Var] -> DVarSet -> DVarSet delBindersFV bs fvs = foldr delBinderFV fvs bs delBinderFV :: Var -> DVarSet -> DVarSet -- This way round, so we can do it multiple times using foldr -- (b `delBinderFV` s) -- * removes the binder b from the free variable set s, -- * AND *adds* to s the free variables of b's type -- -- This is really important for some lambdas: -- In (\x::a -> x) the only mention of "a" is in the binder. -- -- Also in -- let x::a = b in ... -- we should really note that "a" is free in this expression. -- It'll be pinned inside the /\a by the binding for b, but -- it seems cleaner to make sure that a is in the free-var set -- when it is mentioned. -- -- This also shows up in recursive bindings. Consider: -- /\a -> letrec x::a = x in E -- Now, there are no explicit free type variables in the RHS of x, -- but nevertheless "a" is free in its definition. So we add in -- the free tyvars of the types of the binders, and include these in the -- free vars of the group, attached to the top level of each RHS. -- -- This actually happened in the defn of errorIO in IOBase.hs: -- errorIO (ST io) = case (errorIO# io) of -- _ -> bottom -- where -- bottom = bottom -- Never evaluated delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyCoVars b -- Include coercion variables too! varTypeTyCoVars :: Var -> TyCoVarSet -- Find the type/kind variables free in the type of the id/tyvar varTypeTyCoVars var = fvVarSet $ varTypeTyCoFVs var dVarTypeTyCoVars :: Var -> DTyCoVarSet -- Find the type/kind/coercion variables free in the type of the id/tyvar dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var varTypeTyCoFVs :: Var -> FV varTypeTyCoFVs var = tyCoFVsOfType (varType var) idFreeVars :: Id -> VarSet idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id dIdFreeVars :: Id -> DVarSet dIdFreeVars id = fvDVarSet $ idFVs id idFVs :: Id -> FV -- Type variables, rule variables, and inline variables idFVs id = ASSERT( isId id) varTypeTyCoFVs id `unionFV` bndrRuleAndUnfoldingFVs id bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id bndrRuleAndUnfoldingFVs :: Id -> FV bndrRuleAndUnfoldingFVs id | isId id = idRuleFVs id `unionFV` idUnfoldingFVs id | otherwise = emptyFV idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars idRuleVars id = fvVarSet $ idRuleFVs id idRuleFVs :: Id -> FV idRuleFVs id = ASSERT( isId id) FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id)) idUnfoldingVars :: Id -> VarSet -- Produce free vars for an unfolding, but NOT for an ordinary -- (non-inline) unfolding, since it is a dup of the rhs -- and we'll get exponential behaviour if we look at both unf and rhs! -- But do look at the *real* unfolding, even for loop breakers, else -- we might get out-of-scope variables idUnfoldingVars id = fvVarSet $ idUnfoldingFVs id idUnfoldingFVs :: Id -> FV idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV stableUnfoldingVars :: Unfolding -> Maybe VarSet stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf stableUnfoldingFVs :: Unfolding -> Maybe FV stableUnfoldingFVs unf = case unf of CoreUnfolding { uf_tmpl = rhs, uf_src = src } | isStableSource src -> Just (filterFV isLocalVar $ expr_fvs rhs) DFunUnfolding { df_bndrs = bndrs, df_args = args } -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args) -- DFuns are top level, so no fvs from types of bndrs _other -> Nothing {- ************************************************************************ * * \subsection{Free variables (and types)} * * ************************************************************************ -} freeVarsBind :: CoreBind -> DVarSet -- Free vars of scope of binding -> (CoreBindWithFVs, DVarSet) -- Return free vars of binding + scope freeVarsBind (NonRec binder rhs) body_fvs = ( AnnNonRec binder rhs2 , freeVarsOf rhs2 `unionFVs` body_fvs2 `unionFVs` bndrRuleAndUnfoldingVarsDSet binder ) where rhs2 = freeVars rhs body_fvs2 = binder `delBinderFV` body_fvs freeVarsBind (Rec binds) body_fvs = ( AnnRec (binders `zip` rhss2) , delBindersFV binders all_fvs ) where (binders, rhss) = unzip binds rhss2 = map freeVars rhss rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 binders_fvs = fvDVarSet $ mapUnionFV bndrRuleAndUnfoldingFVs binders -- See Note [The FVAnn invariant] all_fvs = rhs_body_fvs `unionFVs` binders_fvs -- The "delBinderFV" happens after adding the idSpecVars, -- since the latter may add some of the binders as fvs freeVars :: CoreExpr -> CoreExprWithFVs -- ^ Annotate a 'CoreExpr' with its (non-global) free type -- and value variables at every tree node. freeVars = go where go :: CoreExpr -> CoreExprWithFVs go (Var v) | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs, AnnVar v) | otherwise = (emptyDVarSet, AnnVar v) where ty_fvs = dVarTypeTyCoVars v -- See Note [The FVAnn invariant] go (Lit lit) = (emptyDVarSet, AnnLit lit) go (Lam b body) = ( b_fvs `unionFVs` (b `delBinderFV` body_fvs) , AnnLam b body' ) where body'@(body_fvs, _) = go body b_ty = idType b b_fvs = tyCoVarsOfTypeDSet b_ty -- See Note [The FVAnn invariant] go (App fun arg) = ( freeVarsOf fun' `unionFVs` freeVarsOf arg' , AnnApp fun' arg' ) where fun' = go fun arg' = go arg go (Case scrut bndr ty alts) = ( (bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyCoVarsOfTypeDSet ty -- Don't need to look at (idType bndr) -- because that's redundant with scrut , AnnCase scrut2 bndr ty alts2 ) where scrut2 = go scrut (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts alts_fvs = unionFVss alts_fvs_s fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2), (con, args, rhs2)) where rhs2 = go rhs go (Let bind body) = (bind_fvs, AnnLet bind2 body2) where (bind2, bind_fvs) = freeVarsBind bind (freeVarsOf body2) body2 = go body go (Cast expr co) = ( freeVarsOf expr2 `unionFVs` cfvs , AnnCast expr2 (cfvs, co) ) where expr2 = go expr cfvs = tyCoVarsOfCoDSet co go (Tick tickish expr) = ( tickishFVs tickish `unionFVs` freeVarsOf expr2 , AnnTick tickish expr2 ) where expr2 = go expr tickishFVs (Breakpoint _ ids) = mkDVarSet ids tickishFVs _ = emptyDVarSet go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) ghc-lib-parser-8.10.2.20200808/compiler/coreSyn/CoreMap.hs0000644000000000000000000007554613713635744020645 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} module CoreMap( -- * Maps over Core expressions CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, -- * Maps over 'Type's TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, LooseTypeMap, -- ** With explicit scoping CmEnv, lookupCME, extendTypeMapWithScope, lookupTypeMapWithScope, mkDeBruijnContext, -- * Maps over 'Maybe' values MaybeMap, -- * Maps over 'List' values ListMap, -- * Maps over 'Literal's LiteralMap, -- * Map for compressing leaves. See Note [Compressed TrieMap] GenMap, -- * 'TrieMap' class TrieMap(..), insertTM, deleteTM, lkDFreeVar, xtDFreeVar, lkDNamed, xtDNamed, (>.>), (|>), (|>>), ) where #include "GhclibHsVersions.h" import GhcPrelude import TrieMap import CoreSyn import Coercion import Name import Type import TyCoRep import Var import FastString(FastString) import Util import qualified Data.Map as Map import qualified Data.IntMap as IntMap import VarEnv import NameEnv import Outputable import Control.Monad( (>=>) ) {- This module implements TrieMaps over Core related data structures like CoreExpr or Type. It is built on the Tries from the TrieMap module. The code is very regular and boilerplate-like, but there is some neat handling of *binders*. In effect they are deBruijn numbered on the fly. -} ---------------------- -- Recall that -- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c -- NB: Be careful about RULES and type families (#5821). So we should make sure -- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form) -- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not -- known when defining GenMap so we can only specialize them here. {-# SPECIALIZE lkG :: Key TypeMapX -> TypeMapG a -> Maybe a #-} {-# SPECIALIZE lkG :: Key CoercionMapX -> CoercionMapG a -> Maybe a #-} {-# SPECIALIZE lkG :: Key CoreMapX -> CoreMapG a -> Maybe a #-} {-# SPECIALIZE xtG :: Key TypeMapX -> XT a -> TypeMapG a -> TypeMapG a #-} {-# SPECIALIZE xtG :: Key CoercionMapX -> XT a -> CoercionMapG a -> CoercionMapG a #-} {-# SPECIALIZE xtG :: Key CoreMapX -> XT a -> CoreMapG a -> CoreMapG a #-} {-# SPECIALIZE mapG :: (a -> b) -> TypeMapG a -> TypeMapG b #-} {-# SPECIALIZE mapG :: (a -> b) -> CoercionMapG a -> CoercionMapG b #-} {-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a -> CoreMapG b #-} {-# SPECIALIZE fdG :: (a -> b -> b) -> TypeMapG a -> b -> b #-} {-# SPECIALIZE fdG :: (a -> b -> b) -> CoercionMapG a -> b -> b #-} {-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a -> b -> b #-} {- ************************************************************************ * * CoreMap * * ************************************************************************ -} lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a lkDNamed n env = lookupDNameEnv env (getName n) xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a xtDNamed tc f m = alterDNameEnv f m (getName tc) {- Note [Binders] ~~~~~~~~~~~~~~ * In general we check binders as late as possible because types are less likely to differ than expression structure. That's why cm_lam :: CoreMapG (TypeMapG a) rather than cm_lam :: TypeMapG (CoreMapG a) * We don't need to look at the type of some binders, notably - the case binder in (Case _ b _ _) - the binders in an alternative because they are totally fixed by the context Note [Empty case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * For a key (Case e b ty (alt:alts)) we don't need to look the return type 'ty', because every alternative has that type. * For a key (Case e b ty []) we MUST look at the return type 'ty', because otherwise (Case (error () "urk") _ Int []) would compare equal to (Case (error () "urk") _ Bool []) which is utterly wrong (#6097) We could compare the return type regardless, but the wildly common case is that it's unnecessary, so we have two fields (cm_case and cm_ecase) for the two possibilities. Only cm_ecase looks at the type. See also Note [Empty case alternatives] in CoreSyn. -} -- | @CoreMap a@ is a map from 'CoreExpr' to @a@. If you are a client, this -- is the type you want. newtype CoreMap a = CoreMap (CoreMapG a) instance TrieMap CoreMap where type Key CoreMap = CoreExpr emptyTM = CoreMap emptyTM lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m) foldTM k (CoreMap m) = foldTM k m mapTM f (CoreMap m) = CoreMap (mapTM f m) -- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@. The extended -- key makes it suitable for recursive traversal, since it can track binders, -- but it is strictly internal to this module. If you are including a 'CoreMap' -- inside another 'TrieMap', this is the type you want. type CoreMapG = GenMap CoreMapX -- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without -- the 'GenMap' optimization. data CoreMapX a = CM { cm_var :: VarMap a , cm_lit :: LiteralMap a , cm_co :: CoercionMapG a , cm_type :: TypeMapG a , cm_cast :: CoreMapG (CoercionMapG a) , cm_tick :: CoreMapG (TickishMap a) , cm_app :: CoreMapG (CoreMapG a) , cm_lam :: CoreMapG (BndrMap a) -- Note [Binders] , cm_letn :: CoreMapG (CoreMapG (BndrMap a)) , cm_letr :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a)) , cm_case :: CoreMapG (ListMap AltMap a) , cm_ecase :: CoreMapG (TypeMapG a) -- Note [Empty case alternatives] } instance Eq (DeBruijn CoreExpr) where D env1 e1 == D env2 e2 = go e1 e2 where go (Var v1) (Var v2) = case (lookupCME env1 v1, lookupCME env2 v2) of (Just b1, Just b2) -> b1 == b2 (Nothing, Nothing) -> v1 == v2 _ -> False go (Lit lit1) (Lit lit2) = lit1 == lit2 go (Type t1) (Type t2) = D env1 t1 == D env2 t2 go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2 go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2 go (App f1 a1) (App f2 a2) = go f1 f2 && go a1 a2 -- This seems a bit dodgy, see 'eqTickish' go (Tick n1 e1) (Tick n2 e2) = n1 == n2 && go e1 e2 go (Lam b1 e1) (Lam b2 e2) = D env1 (varType b1) == D env2 (varType b2) && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2 go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) = go r1 r2 && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2 go (Let (Rec ps1) e1) (Let (Rec ps2) e2) = equalLength ps1 ps2 && D env1' rs1 == D env2' rs2 && D env1' e1 == D env2' e2 where (bs1,rs1) = unzip ps1 (bs2,rs2) = unzip ps2 env1' = extendCMEs env1 bs1 env2' = extendCMEs env2 bs2 go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) | null a1 -- See Note [Empty case alternatives] = null a2 && go e1 e2 && D env1 t1 == D env2 t2 | otherwise = go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2 go _ _ = False emptyE :: CoreMapX a emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM , cm_co = emptyTM, cm_type = emptyTM , cm_cast = emptyTM, cm_app = emptyTM , cm_lam = emptyTM, cm_letn = emptyTM , cm_letr = emptyTM, cm_case = emptyTM , cm_ecase = emptyTM, cm_tick = emptyTM } instance TrieMap CoreMapX where type Key CoreMapX = DeBruijn CoreExpr emptyTM = emptyE lookupTM = lkE alterTM = xtE foldTM = fdE mapTM = mapE -------------------------- mapE :: (a->b) -> CoreMapX a -> CoreMapX b mapE f (CM { cm_var = cvar, cm_lit = clit , cm_co = cco, cm_type = ctype , cm_cast = ccast , cm_app = capp , cm_lam = clam, cm_letn = cletn , cm_letr = cletr, cm_case = ccase , cm_ecase = cecase, cm_tick = ctick }) = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit , cm_co = mapTM f cco, cm_type = mapTM f ctype , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick } -------------------------- lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a lookupCoreMap cm e = lookupTM e cm extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a extendCoreMap m e v = alterTM e (\_ -> Just v) m foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b foldCoreMap k z m = foldTM k m z emptyCoreMap :: CoreMap a emptyCoreMap = emptyTM instance Outputable a => Outputable (CoreMap a) where ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m []) ------------------------- fdE :: (a -> b -> b) -> CoreMapX a -> b -> b fdE k m = foldTM k (cm_var m) . foldTM k (cm_lit m) . foldTM k (cm_co m) . foldTM k (cm_type m) . foldTM (foldTM k) (cm_cast m) . foldTM (foldTM k) (cm_tick m) . foldTM (foldTM k) (cm_app m) . foldTM (foldTM k) (cm_lam m) . foldTM (foldTM (foldTM k)) (cm_letn m) . foldTM (foldTM (foldTM k)) (cm_letr m) . foldTM (foldTM k) (cm_case m) . foldTM (foldTM k) (cm_ecase m) -- lkE: lookup in trie for expressions lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a lkE (D env expr) cm = go expr cm where go (Var v) = cm_var >.> lkVar env v go (Lit l) = cm_lit >.> lookupTM l go (Type t) = cm_type >.> lkG (D env t) go (Coercion c) = cm_co >.> lkG (D env c) go (Cast e c) = cm_cast >.> lkG (D env e) >=> lkG (D env c) go (Tick tickish e) = cm_tick >.> lkG (D env e) >=> lkTickish tickish go (App e1 e2) = cm_app >.> lkG (D env e2) >=> lkG (D env e1) go (Lam v e) = cm_lam >.> lkG (D (extendCME env v) e) >=> lkBndr env v go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r) >=> lkG (D (extendCME env b) e) >=> lkBndr env b go (Let (Rec prs) e) = let (bndrs,rhss) = unzip prs env1 = extendCMEs env bndrs in cm_letr >.> lkList (lkG . D env1) rhss >=> lkG (D env1 e) >=> lkList (lkBndr env1) bndrs go (Case e b ty as) -- See Note [Empty case alternatives] | null as = cm_ecase >.> lkG (D env e) >=> lkG (D env ty) | otherwise = cm_case >.> lkG (D env e) >=> lkList (lkA (extendCME env b)) as xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a xtE (D env (Var v)) f m = m { cm_var = cm_var m |> xtVar env v f } xtE (D env (Type t)) f m = m { cm_type = cm_type m |> xtG (D env t) f } xtE (D env (Coercion c)) f m = m { cm_co = cm_co m |> xtG (D env c) f } xtE (D _ (Lit l)) f m = m { cm_lit = cm_lit m |> alterTM l f } xtE (D env (Cast e c)) f m = m { cm_cast = cm_cast m |> xtG (D env e) |>> xtG (D env c) f } xtE (D env (Tick t e)) f m = m { cm_tick = cm_tick m |> xtG (D env e) |>> xtTickish t f } xtE (D env (App e1 e2)) f m = m { cm_app = cm_app m |> xtG (D env e2) |>> xtG (D env e1) f } xtE (D env (Lam v e)) f m = m { cm_lam = cm_lam m |> xtG (D (extendCME env v) e) |>> xtBndr env v f } xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m |> xtG (D (extendCME env b) e) |>> xtG (D env r) |>> xtBndr env b f } xtE (D env (Let (Rec prs) e)) f m = m { cm_letr = let (bndrs,rhss) = unzip prs env1 = extendCMEs env bndrs in cm_letr m |> xtList (xtG . D env1) rhss |>> xtG (D env1 e) |>> xtList (xtBndr env1) bndrs f } xtE (D env (Case e b ty as)) f m | null as = m { cm_ecase = cm_ecase m |> xtG (D env e) |>> xtG (D env ty) f } | otherwise = m { cm_case = cm_case m |> xtG (D env e) |>> let env1 = extendCME env b in xtList (xtA env1) as f } -- TODO: this seems a bit dodgy, see 'eqTickish' type TickishMap a = Map.Map (Tickish Id) a lkTickish :: Tickish Id -> TickishMap a -> Maybe a lkTickish = lookupTM xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a xtTickish = alterTM ------------------------ data AltMap a -- A single alternative = AM { am_deflt :: CoreMapG a , am_data :: DNameEnv (CoreMapG a) , am_lit :: LiteralMap (CoreMapG a) } instance TrieMap AltMap where type Key AltMap = CoreAlt emptyTM = AM { am_deflt = emptyTM , am_data = emptyDNameEnv , am_lit = emptyTM } lookupTM = lkA emptyCME alterTM = xtA emptyCME foldTM = fdA mapTM = mapA instance Eq (DeBruijn CoreAlt) where D env1 a1 == D env2 a2 = go a1 a2 where go (DEFAULT, _, rhs1) (DEFAULT, _, rhs2) = D env1 rhs1 == D env2 rhs2 go (LitAlt lit1, _, rhs1) (LitAlt lit2, _, rhs2) = lit1 == lit2 && D env1 rhs1 == D env2 rhs2 go (DataAlt dc1, bs1, rhs1) (DataAlt dc2, bs2, rhs2) = dc1 == dc2 && D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2 go _ _ = False mapA :: (a->b) -> AltMap a -> AltMap b mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) = AM { am_deflt = mapTM f adeflt , am_data = mapTM (mapTM f) adata , am_lit = mapTM (mapTM f) alit } lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a lkA env (DEFAULT, _, rhs) = am_deflt >.> lkG (D env rhs) lkA env (LitAlt lit, _, rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) lkA env (DataAlt dc, bs, rhs) = am_data >.> lkDNamed dc >=> lkG (D (extendCMEs env bs) rhs) xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a xtA env (DEFAULT, _, rhs) f m = m { am_deflt = am_deflt m |> xtG (D env rhs) f } xtA env (LitAlt l, _, rhs) f m = m { am_lit = am_lit m |> alterTM l |>> xtG (D env rhs) f } xtA env (DataAlt d, bs, rhs) f m = m { am_data = am_data m |> xtDNamed d |>> xtG (D (extendCMEs env bs) rhs) f } fdA :: (a -> b -> b) -> AltMap a -> b -> b fdA k m = foldTM k (am_deflt m) . foldTM (foldTM k) (am_data m) . foldTM (foldTM k) (am_lit m) {- ************************************************************************ * * Coercions * * ************************************************************************ -} -- We should really never care about the contents of a coercion. Instead, -- just look up the coercion's type. newtype CoercionMap a = CoercionMap (CoercionMapG a) instance TrieMap CoercionMap where type Key CoercionMap = Coercion emptyTM = CoercionMap emptyTM lookupTM k (CoercionMap m) = lookupTM (deBruijnize k) m alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m) foldTM k (CoercionMap m) = foldTM k m mapTM f (CoercionMap m) = CoercionMap (mapTM f m) type CoercionMapG = GenMap CoercionMapX newtype CoercionMapX a = CoercionMapX (TypeMapX a) instance TrieMap CoercionMapX where type Key CoercionMapX = DeBruijn Coercion emptyTM = CoercionMapX emptyTM lookupTM = lkC alterTM = xtC foldTM f (CoercionMapX core_tm) = foldTM f core_tm mapTM f (CoercionMapX core_tm) = CoercionMapX (mapTM f core_tm) instance Eq (DeBruijn Coercion) where D env1 co1 == D env2 co2 = D env1 (coercionType co1) == D env2 (coercionType co2) lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a lkC (D env co) (CoercionMapX core_tm) = lkT (D env $ coercionType co) core_tm xtC :: DeBruijn Coercion -> XT a -> CoercionMapX a -> CoercionMapX a xtC (D env co) f (CoercionMapX m) = CoercionMapX (xtT (D env $ coercionType co) f m) {- ************************************************************************ * * Types * * ************************************************************************ -} -- | @TypeMapG a@ is a map from @DeBruijn Type@ to @a@. The extended -- key makes it suitable for recursive traversal, since it can track binders, -- but it is strictly internal to this module. If you are including a 'TypeMap' -- inside another 'TrieMap', this is the type you want. Note that this -- lookup does not do a kind-check. Thus, all keys in this map must have -- the same kind. Also note that this map respects the distinction between -- @Type@ and @Constraint@, despite the fact that they are equivalent type -- synonyms in Core. type TypeMapG = GenMap TypeMapX -- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the -- 'GenMap' optimization. data TypeMapX a = TM { tm_var :: VarMap a , tm_app :: TypeMapG (TypeMapG a) , tm_tycon :: DNameEnv a , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] , tm_tylit :: TyLitMap a , tm_coerce :: Maybe a } -- Note that there is no tyconapp case; see Note [Equality on AppTys] in Type -- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the -- last one? See Note [Equality on AppTys] in Type -- -- Note, however, that we keep Constraint and Type apart here, despite the fact -- that they are both synonyms of TYPE 'LiftedRep (see #11715). trieMapView :: Type -> Maybe Type trieMapView ty -- First check for TyConApps that need to be expanded to -- AppTy chains. | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty = Just $ foldl' AppTy (TyConApp tc []) tys -- Then resolve any remaining nullary synonyms. | Just ty' <- tcView ty = Just ty' trieMapView _ = Nothing instance TrieMap TypeMapX where type Key TypeMapX = DeBruijn Type emptyTM = emptyT lookupTM = lkT alterTM = xtT foldTM = fdT mapTM = mapT instance Eq (DeBruijn Type) where env_t@(D env t) == env_t'@(D env' t') | Just new_t <- tcView t = D env new_t == env_t' | Just new_t' <- tcView t' = env_t == D env' new_t' | otherwise = case (t, t') of (CastTy t1 _, _) -> D env t1 == D env t' (_, CastTy t1' _) -> D env t == D env t1' (TyVarTy v, TyVarTy v') -> case (lookupCME env v, lookupCME env' v') of (Just bv, Just bv') -> bv == bv' (Nothing, Nothing) -> v == v' _ -> False -- See Note [Equality on AppTys] in Type (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s -> D env t1 == D env' t1' && D env t2 == D env' t2' (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s -> D env t1 == D env' t1' && D env t2 == D env' t2' (FunTy _ t1 t2, FunTy _ t1' t2') -> D env t1 == D env' t1' && D env t2 == D env' t2' (TyConApp tc tys, TyConApp tc' tys') -> tc == tc' && D env tys == D env' tys' (LitTy l, LitTy l') -> l == l' (ForAllTy (Bndr tv _) ty, ForAllTy (Bndr tv' _) ty') -> D env (varType tv) == D env' (varType tv') && D (extendCME env tv) ty == D (extendCME env' tv') ty' (CoercionTy {}, CoercionTy {}) -> True _ -> False instance {-# OVERLAPPING #-} Outputable a => Outputable (TypeMapG a) where ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m []) emptyT :: TypeMapX a emptyT = TM { tm_var = emptyTM , tm_app = emptyTM , tm_tycon = emptyDNameEnv , tm_forall = emptyTM , tm_tylit = emptyTyLitMap , tm_coerce = Nothing } mapT :: (a->b) -> TypeMapX a -> TypeMapX b mapT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon , tm_forall = tforall, tm_tylit = tlit , tm_coerce = tcoerce }) = TM { tm_var = mapTM f tvar , tm_app = mapTM (mapTM f) tapp , tm_tycon = mapTM f ttycon , tm_forall = mapTM (mapTM f) tforall , tm_tylit = mapTM f tlit , tm_coerce = fmap f tcoerce } ----------------- lkT :: DeBruijn Type -> TypeMapX a -> Maybe a lkT (D env ty) m = go ty m where go ty | Just ty' <- trieMapView ty = go ty' go (TyVarTy v) = tm_var >.> lkVar env v go (AppTy t1 t2) = tm_app >.> lkG (D env t1) >=> lkG (D env t2) go (TyConApp tc []) = tm_tycon >.> lkDNamed tc go ty@(TyConApp _ (_:_)) = pprPanic "lkT TyConApp" (ppr ty) go (LitTy l) = tm_tylit >.> lkTyLit l go (ForAllTy (Bndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty) >=> lkBndr env tv go ty@(FunTy {}) = pprPanic "lkT FunTy" (ppr ty) go (CastTy t _) = go t go (CoercionTy {}) = tm_coerce ----------------- xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m xtT (D env (TyVarTy v)) f m = m { tm_var = tm_var m |> xtVar env v f } xtT (D env (AppTy t1 t2)) f m = m { tm_app = tm_app m |> xtG (D env t1) |>> xtG (D env t2) f } xtT (D _ (TyConApp tc [])) f m = m { tm_tycon = tm_tycon m |> xtDNamed tc f } xtT (D _ (LitTy l)) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } xtT (D env (CastTy t _)) f m = xtT (D env t) f m xtT (D _ (CoercionTy {})) f m = m { tm_coerce = tm_coerce m |> f } xtT (D env (ForAllTy (Bndr tv _) ty)) f m = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty) |>> xtBndr env tv f } xtT (D _ ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty) xtT (D _ ty@(FunTy {})) _ _ = pprPanic "xtT FunTy" (ppr ty) fdT :: (a -> b -> b) -> TypeMapX a -> b -> b fdT k m = foldTM k (tm_var m) . foldTM (foldTM k) (tm_app m) . foldTM k (tm_tycon m) . foldTM (foldTM k) (tm_forall m) . foldTyLit k (tm_tylit m) . foldMaybe k (tm_coerce m) ------------------------ data TyLitMap a = TLM { tlm_number :: Map.Map Integer a , tlm_string :: Map.Map FastString a } instance TrieMap TyLitMap where type Key TyLitMap = TyLit emptyTM = emptyTyLitMap lookupTM = lkTyLit alterTM = xtTyLit foldTM = foldTyLit mapTM = mapTyLit emptyTyLitMap :: TyLitMap a emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = Map.empty } mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b mapTyLit f (TLM { tlm_number = tn, tlm_string = ts }) = TLM { tlm_number = Map.map f tn, tlm_string = Map.map f ts } lkTyLit :: TyLit -> TyLitMap a -> Maybe a lkTyLit l = case l of NumTyLit n -> tlm_number >.> Map.lookup n StrTyLit n -> tlm_string >.> Map.lookup n xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a xtTyLit l f m = case l of NumTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n } StrTyLit n -> m { tlm_string = tlm_string m |> Map.alter f n } foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b foldTyLit l m = flip (Map.foldr l) (tlm_string m) . flip (Map.foldr l) (tlm_number m) ------------------------------------------------- -- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this -- is the type you want. The keys in this map may have different kinds. newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a)) lkTT :: DeBruijn Type -> TypeMap a -> Maybe a lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m >>= lkG (D env ty) xtTT :: DeBruijn Type -> XT a -> TypeMap a -> TypeMap a xtTT (D env ty) f (TypeMap m) = TypeMap (m |> xtG (D env $ typeKind ty) |>> xtG (D env ty) f) -- Below are some client-oriented functions which operate on 'TypeMap'. instance TrieMap TypeMap where type Key TypeMap = Type emptyTM = TypeMap emptyTM lookupTM k m = lkTT (deBruijnize k) m alterTM k f m = xtTT (deBruijnize k) f m foldTM k (TypeMap m) = foldTM (foldTM k) m mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m) foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b foldTypeMap k z m = foldTM k m z emptyTypeMap :: TypeMap a emptyTypeMap = emptyTM lookupTypeMap :: TypeMap a -> Type -> Maybe a lookupTypeMap cm t = lookupTM t cm extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a extendTypeMap m t v = alterTM t (const (Just v)) m lookupTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> Maybe a lookupTypeMapWithScope m cm t = lkTT (D cm t) m -- | Extend a 'TypeMap' with a type in the given context. -- @extendTypeMapWithScope m (mkDeBruijnContext [a,b,c]) t v@ is equivalent to -- @extendTypeMap m (forall a b c. t) v@, but allows reuse of the context over -- multiple insertions. extendTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> a -> TypeMap a extendTypeMapWithScope m cm t v = xtTT (D cm t) (const (Just v)) m -- | Construct a deBruijn environment with the given variables in scope. -- e.g. @mkDeBruijnEnv [a,b,c]@ constructs a context @forall a b c.@ mkDeBruijnContext :: [Var] -> CmEnv mkDeBruijnContext = extendCMEs emptyCME -- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g), -- you'll find entries inserted under (t), even if (g) is non-reflexive. newtype LooseTypeMap a = LooseTypeMap (TypeMapG a) instance TrieMap LooseTypeMap where type Key LooseTypeMap = Type emptyTM = LooseTypeMap emptyTM lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m) foldTM f (LooseTypeMap m) = foldTM f m mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m) {- ************************************************************************ * * Variables * * ************************************************************************ -} type BoundVar = Int -- Bound variables are deBruijn numbered type BoundVarMap a = IntMap.IntMap a data CmEnv = CME { cme_next :: !BoundVar , cme_env :: VarEnv BoundVar } emptyCME :: CmEnv emptyCME = CME { cme_next = 0, cme_env = emptyVarEnv } extendCME :: CmEnv -> Var -> CmEnv extendCME (CME { cme_next = bv, cme_env = env }) v = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv } extendCMEs :: CmEnv -> [Var] -> CmEnv extendCMEs env vs = foldl' extendCME env vs lookupCME :: CmEnv -> Var -> Maybe BoundVar lookupCME (CME { cme_env = env }) v = lookupVarEnv env v -- | @DeBruijn a@ represents @a@ modulo alpha-renaming. This is achieved -- by equipping the value with a 'CmEnv', which tracks an on-the-fly deBruijn -- numbering. This allows us to define an 'Eq' instance for @DeBruijn a@, even -- if this was not (easily) possible for @a@. Note: we purposely don't -- export the constructor. Make a helper function if you find yourself -- needing it. data DeBruijn a = D CmEnv a -- | Synthesizes a @DeBruijn a@ from an @a@, by assuming that there are no -- bound binders (an empty 'CmEnv'). This is usually what you want if there -- isn't already a 'CmEnv' in scope. deBruijnize :: a -> DeBruijn a deBruijnize = D emptyCME instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where D _ [] == D _ [] = True D env (x:xs) == D env' (x':xs') = D env x == D env' x' && D env xs == D env' xs' _ == _ = False --------- Variable binders ------------- -- | A 'BndrMap' is a 'TypeMapG' which allows us to distinguish between -- binding forms whose binders have different types. For example, -- if we are doing a 'TrieMap' lookup on @\(x :: Int) -> ()@, we should -- not pick up an entry in the 'TrieMap' for @\(x :: Bool) -> ()@: -- we can disambiguate this by matching on the type (or kind, if this -- a binder in a type) of the binder. type BndrMap = TypeMapG -- Note [Binders] -- ~~~~~~~~~~~~~~ -- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all -- of these data types have binding forms. lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a lkBndr env v m = lkG (D env (varType v)) m xtBndr :: CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a xtBndr env v f = xtG (D env (varType v)) f --------- Variable occurrence ------------- data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable , vm_fvar :: DVarEnv a } -- Free variable instance TrieMap VarMap where type Key VarMap = Var emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv } lookupTM = lkVar emptyCME alterTM = xtVar emptyCME foldTM = fdVar mapTM = mapVar mapVar :: (a->b) -> VarMap a -> VarMap b mapVar f (VM { vm_bvar = bv, vm_fvar = fv }) = VM { vm_bvar = mapTM f bv, vm_fvar = mapTM f fv } lkVar :: CmEnv -> Var -> VarMap a -> Maybe a lkVar env v | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv | otherwise = vm_fvar >.> lkDFreeVar v xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a xtVar env v f m | Just bv <- lookupCME env v = m { vm_bvar = vm_bvar m |> alterTM bv f } | otherwise = m { vm_fvar = vm_fvar m |> xtDFreeVar v f } fdVar :: (a -> b -> b) -> VarMap a -> b -> b fdVar k m = foldTM k (vm_bvar m) . foldTM k (vm_fvar m) lkDFreeVar :: Var -> DVarEnv a -> Maybe a lkDFreeVar var env = lookupDVarEnv env var xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a xtDFreeVar v f m = alterDVarEnv f m v ghc-lib-parser-8.10.2.20200808/compiler/simplCore/CoreMonad.hs0000644000000000000000000007533513713635745021476 0ustar0000000000000000{- (c) The AQUA Project, Glasgow University, 1993-1998 \section[CoreMonad]{The core pipeline monad} -} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} module CoreMonad ( -- * Configuration of the core-to-core passes CoreToDo(..), runWhen, runMaybe, SimplMode(..), FloatOutSwitches(..), pprPassDetails, -- * Plugins CorePluginPass, bindsOnlyPass, -- * Counting SimplCount, doSimplTick, doFreeSimplTick, simplCountN, pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, hasDetailedCounts, Tick(..), -- * The monad CoreM, runCoreM, -- ** Reading from the monad getHscEnv, getRuleBase, getModule, getDynFlags, getOrigNameCache, getPackageFamInstEnv, getVisibleOrphanMods, getUniqMask, getPrintUnqualified, getSrcSpanM, -- ** Writing to the monad addSimplCount, -- ** Lifting into the monad liftIO, liftIOWithCount, -- ** Dealing with annotations getAnnotations, getFirstAnnotations, -- ** Screen output putMsg, putMsgS, errorMsg, errorMsgS, warnMsg, fatalErrorMsg, fatalErrorMsgS, debugTraceMsg, debugTraceMsgS, dumpIfSet_dyn ) where import GhcPrelude hiding ( read ) import CoreSyn import HscTypes import Module import DynFlags import BasicTypes ( CompilerPhase(..) ) import Annotations import IOEnv hiding ( liftIO, failM, failWithM ) import qualified IOEnv ( liftIO ) import Var import Outputable import FastString import qualified ErrUtils as Err import ErrUtils( Severity(..) ) import UniqSupply import UniqFM ( UniqFM, mapUFM, filterUFM ) import MonadUtils import NameCache import SrcLoc import Data.List (intersperse, groupBy, sortBy) import Data.Ord import Data.Dynamic import Data.IORef import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Map.Strict as MapStrict import Data.Word import Control.Monad import Control.Applicative ( Alternative(..) ) import Panic (throwGhcException, GhcException(..)) {- ************************************************************************ * * The CoreToDo type and related types Abstraction of core-to-core passes to run. * * ************************************************************************ -} data CoreToDo -- These are diff core-to-core passes, -- which may be invoked in any order, -- as many times as you like. = CoreDoSimplify -- The core-to-core simplifier. Int -- Max iterations SimplMode | CoreDoPluginPass String CorePluginPass | CoreDoFloatInwards | CoreDoFloatOutwards FloatOutSwitches | CoreLiberateCase | CoreDoPrintCore | CoreDoStaticArgs | CoreDoCallArity | CoreDoExitify | CoreDoStrictness | CoreDoWorkerWrapper | CoreDoSpecialising | CoreDoSpecConstr | CoreCSE | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules -- matching this string | CoreDoNothing -- Useful when building up | CoreDoPasses [CoreToDo] -- lists of these things | CoreDesugar -- Right after desugaring, no simple optimisation yet! | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces -- Core output, and hence useful to pass to endPass | CoreTidy | CorePrep | CoreOccurAnal instance Outputable CoreToDo where ppr (CoreDoSimplify _ _) = text "Simplifier" ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s ppr CoreDoFloatInwards = text "Float inwards" ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) ppr CoreLiberateCase = text "Liberate case" ppr CoreDoStaticArgs = text "Static argument" ppr CoreDoCallArity = text "Called arity analysis" ppr CoreDoExitify = text "Exitification transformation" ppr CoreDoStrictness = text "Demand analysis" ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" ppr CoreDoSpecialising = text "Specialise" ppr CoreDoSpecConstr = text "SpecConstr" ppr CoreCSE = text "Common sub-expression" ppr CoreDesugar = text "Desugar (before optimization)" ppr CoreDesugarOpt = text "Desugar (after optimization)" ppr CoreTidy = text "Tidy Core" ppr CorePrep = text "CorePrep" ppr CoreOccurAnal = text "Occurrence analysis" ppr CoreDoPrintCore = text "Print core" ppr (CoreDoRuleCheck {}) = text "Rule check" ppr CoreDoNothing = text "CoreDoNothing" ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes pprPassDetails :: CoreToDo -> SDoc pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n , ppr md ] pprPassDetails _ = Outputable.empty data SimplMode -- See comments in SimplMonad = SimplMode { sm_names :: [String] -- Name(s) of the phase , sm_phase :: CompilerPhase , sm_dflags :: DynFlags -- Just for convenient non-monadic -- access; we don't override these , sm_rules :: Bool -- Whether RULES are enabled , sm_inline :: Bool -- Whether inlining is enabled , sm_case_case :: Bool -- Whether case-of-case is enabled , sm_eta_expand :: Bool -- Whether eta-expansion is enabled } instance Outputable SimplMode where ppr (SimplMode { sm_phase = p, sm_names = ss , sm_rules = r, sm_inline = i , sm_eta_expand = eta, sm_case_case = cc }) = text "SimplMode" <+> braces ( sep [ text "Phase =" <+> ppr p <+> brackets (text (concat $ intersperse "," ss)) <> comma , pp_flag i (sLit "inline") <> comma , pp_flag r (sLit "rules") <> comma , pp_flag eta (sLit "eta-expand") <> comma , pp_flag cc (sLit "case-of-case") ]) where pp_flag f s = ppUnless f (text "no") <+> ptext s data FloatOutSwitches = FloatOutSwitches { floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if -- doing so will abstract over n or fewer -- value variables -- Nothing <=> float all lambdas to top level, -- regardless of how many free variables -- Just 0 is the vanilla case: float a lambda -- iff it has no free vars floatOutConstants :: Bool, -- ^ True <=> float constants to top level, -- even if they do not escape a lambda floatOutOverSatApps :: Bool, -- ^ True <=> float out over-saturated applications -- based on arity information. -- See Note [Floating over-saturated applications] -- in SetLevels floatToTopLevelOnly :: Bool -- ^ Allow floating to the top level only. } instance Outputable FloatOutSwitches where ppr = pprFloatOutSwitches pprFloatOutSwitches :: FloatOutSwitches -> SDoc pprFloatOutSwitches sw = text "FOS" <+> (braces $ sep $ punctuate comma $ [ text "Lam =" <+> ppr (floatOutLambdas sw) , text "Consts =" <+> ppr (floatOutConstants sw) , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) -- The core-to-core pass ordering is derived from the DynFlags: runWhen :: Bool -> CoreToDo -> CoreToDo runWhen True do_this = do_this runWhen False _ = CoreDoNothing runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo runMaybe (Just x) f = f x runMaybe Nothing _ = CoreDoNothing {- ************************************************************************ * * Types for Plugins * * ************************************************************************ -} -- | A description of the plugin pass itself type CorePluginPass = ModGuts -> CoreM ModGuts bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts bindsOnlyPass pass guts = do { binds' <- pass (mg_binds guts) ; return (guts { mg_binds = binds' }) } {- ************************************************************************ * * Counting and logging * * ************************************************************************ -} getVerboseSimplStats :: (Bool -> SDoc) -> SDoc getVerboseSimplStats = getPprDebug -- For now, anyway zeroSimplCount :: DynFlags -> SimplCount isZeroSimplCount :: SimplCount -> Bool hasDetailedCounts :: SimplCount -> Bool pprSimplCount :: SimplCount -> SDoc doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount doFreeSimplTick :: Tick -> SimplCount -> SimplCount plusSimplCount :: SimplCount -> SimplCount -> SimplCount data SimplCount = VerySimplCount !Int -- Used when don't want detailed stats | SimplCount { ticks :: !Int, -- Total ticks details :: !TickCounts, -- How many of each type n_log :: !Int, -- N log1 :: [Tick], -- Last N events; <= opt_HistorySize, -- most recent first log2 :: [Tick] -- Last opt_HistorySize events before that -- Having log1, log2 lets us accumulate the -- recent history reasonably efficiently } type TickCounts = Map Tick Int simplCountN :: SimplCount -> Int simplCountN (VerySimplCount n) = n simplCountN (SimplCount { ticks = n }) = n zeroSimplCount dflags -- This is where we decide whether to do -- the VerySimpl version or the full-stats version | dopt Opt_D_dump_simpl_stats dflags = SimplCount {ticks = 0, details = Map.empty, n_log = 0, log1 = [], log2 = []} | otherwise = VerySimplCount 0 isZeroSimplCount (VerySimplCount n) = n==0 isZeroSimplCount (SimplCount { ticks = n }) = n==0 hasDetailedCounts (VerySimplCount {}) = False hasDetailedCounts (SimplCount {}) = True doFreeSimplTick tick sc@SimplCount { details = dts } = sc { details = dts `addTick` tick } doFreeSimplTick _ sc = sc doSimplTick dflags tick sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 } | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } where sc1 = sc { ticks = tks+1, details = dts `addTick` tick } doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) addTick :: TickCounts -> Tick -> TickCounts addTick fm tick = MapStrict.insertWith (+) tick 1 fm plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) sc2@(SimplCount { ticks = tks2, details = dts2 }) = log_base { ticks = tks1 + tks2 , details = MapStrict.unionWith (+) dts1 dts2 } where -- A hackish way of getting recent log info log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 | null (log2 sc2) = sc2 { log2 = log1 sc1 } | otherwise = sc2 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) plusSimplCount lhs rhs = throwGhcException . PprProgramError "plusSimplCount" $ vcat [ text "lhs" , pprSimplCount lhs , text "rhs" , pprSimplCount rhs ] -- We use one or the other consistently pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) = vcat [text "Total ticks: " <+> int tks, blankLine, pprTickCounts dts, getVerboseSimplStats $ \dbg -> if dbg then vcat [blankLine, text "Log (most recent first)", nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] else Outputable.empty ] {- Note [Which transformations are innocuous] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ At one point (Jun 18) I wondered if some transformations (ticks) might be "innocuous", in the sense that they do not unlock a later transformation that does not occur in the same pass. If so, we could refrain from bumping the overall tick-count for such innocuous transformations, and perhaps terminate the simplifier one pass earlier. BUt alas I found that virtually nothing was innocuous! This Note just records what I learned, in case anyone wants to try again. These transformations are not innocuous: *** NB: I think these ones could be made innocuous EtaExpansion LetFloatFromLet LetFloatFromLet x = K (let z = e2 in Just z) prepareRhs transforms to x2 = let z=e2 in Just z x = K xs And now more let-floating can happen in the next pass, on x2 PreInlineUnconditionally Example in spectral/cichelli/Auxil hinsert = ...let lo = e in let j = ...lo... in case x of False -> () True -> case lo of I# lo' -> ...j... When we PreInlineUnconditionally j, lo's occ-info changes to once, so it can be PreInlineUnconditionally in the next pass, and a cascade of further things can happen. PostInlineUnconditionally let x = e in let y = ...x.. in case .. of { A -> ...x...y... B -> ...x...y... } Current postinlineUnconditinaly will inline y, and then x; sigh. But PostInlineUnconditionally might also unlock subsequent transformations for the same reason as PreInlineUnconditionally, so it's probably not innocuous anyway. KnownBranch, BetaReduction: May drop chunks of code, and thereby enable PreInlineUnconditionally for some let-binding which now occurs once EtaExpansion: Example in imaginary/digits-of-e1 fail = \void. e where e :: IO () --> etaExpandRhs fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,()) --> Next iteration of simplify fail1 = \void. \s. (e |> g) s fail = fail1 |> Void#->sym g And now inline 'fail' CaseMerge: case x of y { DEFAULT -> case y of z { pi -> ei } alts2 } ---> CaseMerge case x of { pi -> let z = y in ei ; alts2 } The "let z=y" case-binder-swap gets dealt with in the next pass -} pprTickCounts :: Map Tick Int -> SDoc pprTickCounts counts = vcat (map pprTickGroup groups) where groups :: [[(Tick,Int)]] -- Each group shares a comon tag -- toList returns common tags adjacent groups = groupBy same_tag (Map.toList counts) same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2 pprTickGroup :: [(Tick, Int)] -> SDoc pprTickGroup group@((tick1,_):_) = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1)) 2 (vcat [ int n <+> pprTickCts tick -- flip as we want largest first | (tick,n) <- sortBy (flip (comparing snd)) group]) pprTickGroup [] = panic "pprTickGroup" data Tick -- See Note [Which transformations are innocuous] = PreInlineUnconditionally Id | PostInlineUnconditionally Id | UnfoldingDone Id | RuleFired FastString -- Rule name | LetFloatFromLet | EtaExpansion Id -- LHS binder | EtaReduction Id -- Binder on outer lambda | BetaReduction Id -- Lambda binder | CaseOfCase Id -- Bndr on *inner* case | KnownBranch Id -- Case binder | CaseMerge Id -- Binder on outer case | AltMerge Id -- Case binder | CaseElim Id -- Case binder | CaseIdentity Id -- Case binder | FillInCaseDefault Id -- Case binder | SimplifierDone -- Ticked at each iteration of the simplifier instance Outputable Tick where ppr tick = text (tickString tick) <+> pprTickCts tick instance Eq Tick where a == b = case a `cmpTick` b of EQ -> True _ -> False instance Ord Tick where compare = cmpTick tickToTag :: Tick -> Int tickToTag (PreInlineUnconditionally _) = 0 tickToTag (PostInlineUnconditionally _) = 1 tickToTag (UnfoldingDone _) = 2 tickToTag (RuleFired _) = 3 tickToTag LetFloatFromLet = 4 tickToTag (EtaExpansion _) = 5 tickToTag (EtaReduction _) = 6 tickToTag (BetaReduction _) = 7 tickToTag (CaseOfCase _) = 8 tickToTag (KnownBranch _) = 9 tickToTag (CaseMerge _) = 10 tickToTag (CaseElim _) = 11 tickToTag (CaseIdentity _) = 12 tickToTag (FillInCaseDefault _) = 13 tickToTag SimplifierDone = 16 tickToTag (AltMerge _) = 17 tickString :: Tick -> String tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" tickString (UnfoldingDone _) = "UnfoldingDone" tickString (RuleFired _) = "RuleFired" tickString LetFloatFromLet = "LetFloatFromLet" tickString (EtaExpansion _) = "EtaExpansion" tickString (EtaReduction _) = "EtaReduction" tickString (BetaReduction _) = "BetaReduction" tickString (CaseOfCase _) = "CaseOfCase" tickString (KnownBranch _) = "KnownBranch" tickString (CaseMerge _) = "CaseMerge" tickString (AltMerge _) = "AltMerge" tickString (CaseElim _) = "CaseElim" tickString (CaseIdentity _) = "CaseIdentity" tickString (FillInCaseDefault _) = "FillInCaseDefault" tickString SimplifierDone = "SimplifierDone" pprTickCts :: Tick -> SDoc pprTickCts (PreInlineUnconditionally v) = ppr v pprTickCts (PostInlineUnconditionally v)= ppr v pprTickCts (UnfoldingDone v) = ppr v pprTickCts (RuleFired v) = ppr v pprTickCts LetFloatFromLet = Outputable.empty pprTickCts (EtaExpansion v) = ppr v pprTickCts (EtaReduction v) = ppr v pprTickCts (BetaReduction v) = ppr v pprTickCts (CaseOfCase v) = ppr v pprTickCts (KnownBranch v) = ppr v pprTickCts (CaseMerge v) = ppr v pprTickCts (AltMerge v) = ppr v pprTickCts (CaseElim v) = ppr v pprTickCts (CaseIdentity v) = ppr v pprTickCts (FillInCaseDefault v) = ppr v pprTickCts _ = Outputable.empty cmpTick :: Tick -> Tick -> Ordering cmpTick a b = case (tickToTag a `compare` tickToTag b) of GT -> GT EQ -> cmpEqTick a b LT -> LT cmpEqTick :: Tick -> Tick -> Ordering cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b cmpEqTick _ _ = EQ {- ************************************************************************ * * Monad and carried data structure definitions * * ************************************************************************ -} data CoreReader = CoreReader { cr_hsc_env :: HscEnv, cr_rule_base :: RuleBase, cr_module :: Module, cr_print_unqual :: PrintUnqualified, cr_loc :: SrcSpan, -- Use this for log/error messages so they -- are at least tagged with the right source file cr_visible_orphan_mods :: !ModuleSet, cr_uniq_mask :: !Char -- Mask for creating unique values } -- Note: CoreWriter used to be defined with data, rather than newtype. If it -- is defined that way again, the cw_simpl_count field, at least, must be -- strict to avoid a space leak (#7702). newtype CoreWriter = CoreWriter { cw_simpl_count :: SimplCount } emptyWriter :: DynFlags -> CoreWriter emptyWriter dflags = CoreWriter { cw_simpl_count = zeroSimplCount dflags } plusWriter :: CoreWriter -> CoreWriter -> CoreWriter plusWriter w1 w2 = CoreWriter { cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2) } type CoreIOEnv = IOEnv CoreReader -- | The monad used by Core-to-Core passes to register simplification statistics. -- Also used to have common state (in the form of UniqueSupply) for generating Uniques. newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) } deriving (Functor) instance Monad CoreM where mx >>= f = CoreM $ do (x, w1) <- unCoreM mx (y, w2) <- unCoreM (f x) let w = w1 `plusWriter` w2 return $ seq w (y, w) -- forcing w before building the tuple avoids a space leak -- (#7702) instance Applicative CoreM where pure x = CoreM $ nop x (<*>) = ap m *> k = m >>= \_ -> k instance Alternative CoreM where empty = CoreM Control.Applicative.empty m <|> n = CoreM (unCoreM m <|> unCoreM n) instance MonadPlus CoreM instance MonadUnique CoreM where getUniqueSupplyM = do mask <- read cr_uniq_mask liftIO $! mkSplitUniqSupply mask getUniqueM = do mask <- read cr_uniq_mask liftIO $! uniqFromMask mask runCoreM :: HscEnv -> RuleBase -> Char -- ^ Mask -> Module -> ModuleSet -> PrintUnqualified -> SrcSpan -> CoreM a -> IO (a, SimplCount) runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m = liftM extract $ runIOEnv reader $ unCoreM m where reader = CoreReader { cr_hsc_env = hsc_env, cr_rule_base = rule_base, cr_module = mod, cr_visible_orphan_mods = orph_imps, cr_print_unqual = print_unqual, cr_loc = loc, cr_uniq_mask = mask } extract :: (a, CoreWriter) -> (a, SimplCount) extract (value, writer) = (value, cw_simpl_count writer) {- ************************************************************************ * * Core combinators, not exported * * ************************************************************************ -} nop :: a -> CoreIOEnv (a, CoreWriter) nop x = do r <- getEnv return (x, emptyWriter $ (hsc_dflags . cr_hsc_env) r) read :: (CoreReader -> a) -> CoreM a read f = CoreM $ getEnv >>= (\r -> nop (f r)) write :: CoreWriter -> CoreM () write w = CoreM $ return ((), w) -- \subsection{Lifting IO into the monad} -- | Lift an 'IOEnv' operation into 'CoreM' liftIOEnv :: CoreIOEnv a -> CoreM a liftIOEnv mx = CoreM (mx >>= (\x -> nop x)) instance MonadIO CoreM where liftIO = liftIOEnv . IOEnv.liftIO -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount' liftIOWithCount :: IO (SimplCount, a) -> CoreM a liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x) {- ************************************************************************ * * Reader, writer and state accessors * * ************************************************************************ -} getHscEnv :: CoreM HscEnv getHscEnv = read cr_hsc_env getRuleBase :: CoreM RuleBase getRuleBase = read cr_rule_base getVisibleOrphanMods :: CoreM ModuleSet getVisibleOrphanMods = read cr_visible_orphan_mods getPrintUnqualified :: CoreM PrintUnqualified getPrintUnqualified = read cr_print_unqual getSrcSpanM :: CoreM SrcSpan getSrcSpanM = read cr_loc addSimplCount :: SimplCount -> CoreM () addSimplCount count = write (CoreWriter { cw_simpl_count = count }) getUniqMask :: CoreM Char getUniqMask = read cr_uniq_mask -- Convenience accessors for useful fields of HscEnv instance HasDynFlags CoreM where getDynFlags = fmap hsc_dflags getHscEnv instance HasModule CoreM where getModule = read cr_module -- | The original name cache is the current mapping from 'Module' and -- 'OccName' to a compiler-wide unique 'Name' getOrigNameCache :: CoreM OrigNameCache getOrigNameCache = do nameCacheRef <- fmap hsc_NC getHscEnv liftIO $ fmap nsNames $ readIORef nameCacheRef getPackageFamInstEnv :: CoreM PackageFamInstEnv getPackageFamInstEnv = do hsc_env <- getHscEnv eps <- liftIO $ hscEPS hsc_env return $ eps_fam_inst_env eps {- ************************************************************************ * * Dealing with annotations * * ************************************************************************ -} -- | Get all annotations of a given type. This happens lazily, that is -- no deserialization will take place until the [a] is actually demanded and -- the [a] can also be empty (the UniqFM is not filtered). -- -- This should be done once at the start of a Core-to-Core pass that uses -- annotations. -- -- See Note [Annotations] getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a]) getAnnotations deserialize guts = do hsc_env <- getHscEnv ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts) return (deserializeAnns deserialize ann_env) -- | Get at most one annotation of a given type per Unique. getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a) getFirstAnnotations deserialize guts = liftM (mapUFM head . filterUFM (not . null)) $ getAnnotations deserialize guts {- Note [Annotations] ~~~~~~~~~~~~~~~~~~ A Core-to-Core pass that wants to make use of annotations calls getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with annotations of a specific type. This produces all annotations from interface files read so far. However, annotations from interface files read during the pass will not be visible until getAnnotations is called again. This is similar to how rules work and probably isn't too bad. The current implementation could be optimised a bit: when looking up annotations for a thing from the HomePackageTable, we could search directly in the module where the thing is defined rather than building one UniqFM which contains all annotations we know of. This would work because annotations can only be given to things defined in the same module. However, since we would only want to deserialise every annotation once, we would have to build a cache for every module in the HTP. In the end, it's probably not worth it as long as we aren't using annotations heavily. ************************************************************************ * * Direct screen output * * ************************************************************************ -} msg :: Severity -> WarnReason -> SDoc -> CoreM () msg sev reason doc = do { dflags <- getDynFlags ; loc <- getSrcSpanM ; unqual <- getPrintUnqualified ; let sty = case sev of SevError -> err_sty SevWarning -> err_sty SevDump -> dump_sty _ -> user_sty err_sty = mkErrStyle dflags unqual user_sty = mkUserStyle dflags unqual AllTheWay dump_sty = mkDumpStyle dflags unqual ; liftIO $ putLogMsg dflags reason sev loc sty doc } -- | Output a String message to the screen putMsgS :: String -> CoreM () putMsgS = putMsg . text -- | Output a message to the screen putMsg :: SDoc -> CoreM () putMsg = msg SevInfo NoReason -- | Output an error to the screen. Does not cause the compiler to die. errorMsgS :: String -> CoreM () errorMsgS = errorMsg . text -- | Output an error to the screen. Does not cause the compiler to die. errorMsg :: SDoc -> CoreM () errorMsg = msg SevError NoReason warnMsg :: WarnReason -> SDoc -> CoreM () warnMsg = msg SevWarning -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsgS :: String -> CoreM () fatalErrorMsgS = fatalErrorMsg . text -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsg :: SDoc -> CoreM () fatalErrorMsg = msg SevFatal NoReason -- | Output a string debugging message at verbosity level of @-v@ or higher debugTraceMsgS :: String -> CoreM () debugTraceMsgS = debugTraceMsg . text -- | Outputs a debugging message at verbosity level of @-v@ or higher debugTraceMsg :: SDoc -> CoreM () debugTraceMsg = msg SevDump NoReason -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM () dumpIfSet_dyn flag str doc = do { dflags <- getDynFlags ; unqual <- getPrintUnqualified ; when (dopt flag dflags) $ liftIO $ Err.dumpSDoc dflags unqual flag str doc } ghc-lib-parser-8.10.2.20200808/compiler/coreSyn/CoreOpt.hs0000644000000000000000000015542313713635744020663 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} {-# LANGUAGE CPP #-} module CoreOpt ( -- ** Simple expression optimiser simpleOptPgm, simpleOptExpr, simpleOptExprWith, -- ** Join points joinPointBinding_maybe, joinPointBindings_maybe, -- ** Predicates on expressions exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe, -- ** Coercions and casts pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo ) where #include "GhclibHsVersions.h" import GhcPrelude import CoreArity( etaExpandToJoinPoint ) import CoreSyn import CoreSubst import CoreUtils import CoreFVs import {-#SOURCE #-} CoreUnfold ( mkUnfolding ) import MkCore ( FloatBind(..) ) import PprCore ( pprCoreBindings, pprRules ) import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) import Literal ( Literal(LitString) ) import Id import IdInfo ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) ) import Var ( isNonCoVarId ) import VarSet import VarEnv import DataCon import Demand( etaExpandStrictSig ) import OptCoercion ( optCoercion ) import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList , isInScope, substTyVarBndr, cloneTyVarBndr ) import Coercion hiding ( substCo, substCoVarBndr ) import TyCon ( tyConArity ) import TysWiredIn import PrelNames import BasicTypes import Module ( Module ) import ErrUtils import DynFlags import Outputable import Pair import Util import Maybes ( orElse ) import FastString import Data.List import qualified Data.ByteString as BS {- ************************************************************************ * * The Simple Optimiser * * ************************************************************************ Note [The simple optimiser] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ The simple optimiser is a lightweight, pure (non-monadic) function that rapidly does a lot of simple optimisations, including - inlining things that occur just once, or whose RHS turns out to be trivial - beta reduction - case of known constructor - dead code elimination It does NOT do any call-site inlining; it only inlines a function if it can do so unconditionally, dropping the binding. It thereby guarantees to leave no un-reduced beta-redexes. It is careful to follow the guidance of "Secrets of the GHC inliner", and in particular the pre-inline-unconditionally and post-inline-unconditionally story, to do effective beta reduction on functions called precisely once, without repeatedly optimising the same expression. In fact, the simple optimiser is a good example of this little dance in action; the full Simplifier is a lot more complicated. -} simpleOptExpr :: DynFlags -> CoreExpr -> CoreExpr -- See Note [The simple optimiser] -- Do simple optimisation on an expression -- The optimisation is very straightforward: just -- inline non-recursive bindings that are used only once, -- or where the RHS is trivial -- -- We also inline bindings that bind a Eq# box: see -- See Note [Getting the map/coerce RULE to work]. -- -- Also we convert functions to join points where possible (as -- the occurrence analyser does most of the work anyway). -- -- The result is NOT guaranteed occurrence-analysed, because -- in (let x = y in ....) we substitute for x; so y's occ-info -- may change radically simpleOptExpr dflags expr = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) simpleOptExprWith dflags init_subst expr where init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr)) -- It's potentially important to make a proper in-scope set -- Consider let x = ..y.. in \y. ...x... -- Then we should remember to clone y before substituting -- for x. It's very unlikely to occur, because we probably -- won't *be* substituting for x if it occurs inside a -- lambda. -- -- It's a bit painful to call exprFreeVars, because it makes -- three passes instead of two (occ-anal, and go) simpleOptExprWith :: DynFlags -> Subst -> InExpr -> OutExpr -- See Note [The simple optimiser] simpleOptExprWith dflags subst expr = simple_opt_expr init_env (occurAnalyseExpr expr) where init_env = SOE { soe_dflags = dflags , soe_inl = emptyVarEnv , soe_subst = subst } ---------------------- simpleOptPgm :: DynFlags -> Module -> CoreProgram -> [CoreRule] -> IO (CoreProgram, [CoreRule]) -- See Note [The simple optimiser] simpleOptPgm dflags this_mod binds rules = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" (pprCoreBindings occ_anald_binds $$ pprRules rules ); ; return (reverse binds', rules') } where occ_anald_binds = occurAnalysePgm this_mod (\_ -> True) {- All unfoldings active -} (\_ -> False) {- No rules active -} rules binds (final_env, binds') = foldl' do_one (emptyEnv dflags, []) occ_anald_binds final_subst = soe_subst final_env rules' = substRulesForImportedIds final_subst rules -- We never unconditionally inline into rules, -- hence paying just a substitution do_one (env, binds') bind = case simple_opt_bind env bind TopLevel of (env', Nothing) -> (env', binds') (env', Just bind') -> (env', bind':binds') -- In these functions the substitution maps InVar -> OutExpr ---------------------- type SimpleClo = (SimpleOptEnv, InExpr) data SimpleOptEnv = SOE { soe_dflags :: DynFlags , soe_inl :: IdEnv SimpleClo -- Deals with preInlineUnconditionally; things -- that occur exactly once and are inlined -- without having first been simplified , soe_subst :: Subst -- Deals with cloning; includes the InScopeSet } instance Outputable SimpleOptEnv where ppr (SOE { soe_inl = inl, soe_subst = subst }) = text "SOE {" <+> vcat [ text "soe_inl =" <+> ppr inl , text "soe_subst =" <+> ppr subst ] <+> text "}" emptyEnv :: DynFlags -> SimpleOptEnv emptyEnv dflags = SOE { soe_dflags = dflags , soe_inl = emptyVarEnv , soe_subst = emptySubst } soeZapSubst :: SimpleOptEnv -> SimpleOptEnv soeZapSubst env@(SOE { soe_subst = subst }) = env { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst } soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv -- Take in-scope set from env1, and the rest from env2 soeSetInScope (SOE { soe_subst = subst1 }) env2@(SOE { soe_subst = subst2 }) = env2 { soe_subst = setInScope subst2 (substInScope subst1) } --------------- simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr simple_opt_clo env (e_env, e) = simple_opt_expr (soeSetInScope env e_env) e simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr simple_opt_expr env expr = go expr where subst = soe_subst env in_scope = substInScope subst in_scope_env = (in_scope, simpleUnfoldingFun) go (Var v) | Just clo <- lookupVarEnv (soe_inl env) v = simple_opt_clo env clo | otherwise = lookupIdSubst (text "simpleOptExpr") (soe_subst env) v go (App e1 e2) = simple_app env e1 [(env,e2)] go (Type ty) = Type (substTy subst ty) go (Coercion co) = Coercion (optCoercion (soe_dflags env) (getTCvSubst subst) co) go (Lit lit) = Lit lit go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) go (Cast e co) | isReflCo co' = go e | otherwise = Cast (go e) co' where co' = optCoercion (soe_dflags env) (getTCvSubst subst) co go (Let bind body) = case simple_opt_bind env bind NotTopLevel of (env', Nothing) -> simple_opt_expr env' body (env', Just bind) -> Let bind (simple_opt_expr env' body) go lam@(Lam {}) = go_lam env [] lam go (Case e b ty as) -- See Note [Getting the map/coerce RULE to work] | isDeadBinder b , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e' -- We don't need to be concerned about floats when looking for coerce. , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as = case altcon of DEFAULT -> go rhs _ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs where (env', mb_prs) = mapAccumL (simple_out_bind NotTopLevel) env $ zipEqual "simpleOptExpr" bs es -- Note [Getting the map/coerce RULE to work] | isDeadBinder b , [(DEFAULT, _, rhs)] <- as , isCoVarType (varType b) , (Var fun, _args) <- collectArgs e , fun `hasKey` coercibleSCSelIdKey -- without this last check, we get #11230 = go rhs | otherwise = Case e' b' (substTy subst ty) (map (go_alt env') as) where e' = go e (env', b') = subst_opt_bndr env b ---------------------- go_alt env (con, bndrs, rhs) = (con, bndrs', simple_opt_expr env' rhs) where (env', bndrs') = subst_opt_bndrs env bndrs ---------------------- -- go_lam tries eta reduction go_lam env bs' (Lam b e) = go_lam env' (b':bs') e where (env', b') = subst_opt_bndr env b go_lam env bs' e | Just etad_e <- tryEtaReduce bs e' = etad_e | otherwise = mkLams bs e' where bs = reverse bs' e' = simple_opt_expr env e ---------------------- -- simple_app collects arguments for beta reduction simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr simple_app env (Var v) as | Just (env', e) <- lookupVarEnv (soe_inl env) v = simple_app (soeSetInScope env env') e as | let unf = idUnfolding v , isCompulsoryUnfolding (idUnfolding v) , isAlwaysActive (idInlineActivation v) -- See Note [Unfold compulsory unfoldings in LHSs] = simple_app (soeZapSubst env) (unfoldingTemplate unf) as | otherwise , let out_fn = lookupIdSubst (text "simple_app") (soe_subst env) v = finish_app env out_fn as simple_app env (App e1 e2) as = simple_app env e1 ((env, e2) : as) simple_app env (Lam b e) (a:as) = wrapLet mb_pr (simple_app env' e as) where (env', mb_pr) = simple_bind_pair env b Nothing a NotTopLevel simple_app env (Tick t e) as -- Okay to do "(Tick t e) x ==> Tick t (e x)"? | t `tickishScopesLike` SoftScope = mkTick t $ simple_app env e as -- (let x = e in b) a1 .. an => let x = e in (b a1 .. an) -- The let might appear there as a result of inlining -- e.g. let f = let x = e in b -- in f a1 a2 -- (#13208) -- However, do /not/ do this transformation for join points -- See Note [simple_app and join points] simple_app env (Let bind body) args = case simple_opt_bind env bind NotTopLevel of (env', Nothing) -> simple_app env' body args (env', Just bind') | isJoinBind bind' -> finish_app env expr' args | otherwise -> Let bind' (simple_app env' body args) where expr' = Let bind' (simple_opt_expr env' body) simple_app env e as = finish_app env (simple_opt_expr env e) as finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr finish_app _ fun [] = fun finish_app env fun (arg:args) = finish_app env (App fun (simple_opt_clo env arg)) args ---------------------- simple_opt_bind :: SimpleOptEnv -> InBind -> TopLevelFlag -> (SimpleOptEnv, Maybe OutBind) simple_opt_bind env (NonRec b r) top_level = (env', case mb_pr of Nothing -> Nothing Just (b,r) -> Just (NonRec b r)) where (b', r') = joinPointBinding_maybe b r `orElse` (b, r) (env', mb_pr) = simple_bind_pair env b' Nothing (env,r') top_level simple_opt_bind env (Rec prs) top_level = (env'', res_bind) where res_bind = Just (Rec (reverse rev_prs')) prs' = joinPointBindings_maybe prs `orElse` prs (env', bndrs') = subst_opt_bndrs env (map fst prs') (env'', rev_prs') = foldl' do_pr (env', []) (prs' `zip` bndrs') do_pr (env, prs) ((b,r), b') = (env', case mb_pr of Just pr -> pr : prs Nothing -> prs) where (env', mb_pr) = simple_bind_pair env b (Just b') (env,r) top_level ---------------------- simple_bind_pair :: SimpleOptEnv -> InVar -> Maybe OutVar -> SimpleClo -> TopLevelFlag -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) -- (simple_bind_pair subst in_var out_rhs) -- either extends subst with (in_var -> out_rhs) -- or returns Nothing simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst }) in_bndr mb_out_bndr clo@(rhs_env, in_rhs) top_level | Type ty <- in_rhs -- let a::* = TYPE ty in , let out_ty = substTy (soe_subst rhs_env) ty = ASSERT( isTyVar in_bndr ) (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) | Coercion co <- in_rhs , let out_co = optCoercion (soe_dflags env) (getTCvSubst (soe_subst rhs_env)) co = ASSERT( isCoVar in_bndr ) (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr ) -- The previous two guards got rid of tyvars and coercions -- See Note [CoreSyn type and coercion invariant] in CoreSyn pre_inline_unconditionally = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing) | otherwise = simple_out_bind_pair env in_bndr mb_out_bndr out_rhs occ active stable_unf top_level where stable_unf = isStableUnfolding (idUnfolding in_bndr) active = isAlwaysActive (idInlineActivation in_bndr) occ = idOccInfo in_bndr out_rhs | Just join_arity <- isJoinId_maybe in_bndr = simple_join_rhs join_arity | otherwise = simple_opt_clo env clo simple_join_rhs join_arity -- See Note [Preserve join-binding arity] = mkLams join_bndrs' (simple_opt_expr env_body join_body) where env0 = soeSetInScope env rhs_env (join_bndrs, join_body) = collectNBinders join_arity in_rhs (env_body, join_bndrs') = subst_opt_bndrs env0 join_bndrs pre_inline_unconditionally :: Bool pre_inline_unconditionally | isExportedId in_bndr = False | stable_unf = False | not active = False -- Note [Inline prag in simplOpt] | not (safe_to_inline occ) = False | otherwise = True -- Unconditionally safe to inline safe_to_inline :: OccInfo -> Bool safe_to_inline (IAmALoopBreaker {}) = False safe_to_inline IAmDead = True safe_to_inline occ@(OneOcc {}) = not (occ_in_lam occ) && occ_one_br occ safe_to_inline (ManyOccs {}) = False ------------------- simple_out_bind :: TopLevelFlag -> SimpleOptEnv -> (InVar, OutExpr) -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) simple_out_bind top_level env@(SOE { soe_subst = subst }) (in_bndr, out_rhs) | Type out_ty <- out_rhs = ASSERT( isTyVar in_bndr ) (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) | Coercion out_co <- out_rhs = ASSERT( isCoVar in_bndr ) (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) | otherwise = simple_out_bind_pair env in_bndr Nothing out_rhs (idOccInfo in_bndr) True False top_level ------------------- simple_out_bind_pair :: SimpleOptEnv -> InId -> Maybe OutId -> OutExpr -> OccInfo -> Bool -> Bool -> TopLevelFlag -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) simple_out_bind_pair env in_bndr mb_out_bndr out_rhs occ_info active stable_unf top_level | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr ) -- Type and coercion bindings are caught earlier -- See Note [CoreSyn type and coercion invariant] post_inline_unconditionally = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs } , Nothing) | otherwise = ( env', Just (out_bndr, out_rhs) ) where (env', bndr1) = case mb_out_bndr of Just out_bndr -> (env, out_bndr) Nothing -> subst_opt_bndr env in_bndr out_bndr = add_info env' in_bndr top_level out_rhs bndr1 post_inline_unconditionally :: Bool post_inline_unconditionally | isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs] | stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally] | not active = False -- in SimplUtils | is_loop_breaker = False -- If it's a loop-breaker of any kind, don't inline -- because it might be referred to "earlier" | exprIsTrivial out_rhs = True | coercible_hack = True | otherwise = False is_loop_breaker = isWeakLoopBreaker occ_info -- See Note [Getting the map/coerce RULE to work] coercible_hack | (Var fun, args) <- collectArgs out_rhs , Just dc <- isDataConWorkId_maybe fun , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey = all exprIsTrivial args | otherwise = False {- Note [Exported Ids and trivial RHSs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We obviously do not want to unconditionally inline an Id that is exported. In SimplUtils, Note [Top level and postInlineUnconditionally], we explain why we don't inline /any/ top-level things unconditionally, even trivial ones. But we do here! Why? In the simple optimiser * We do no rule rewrites * We do no call-site inlining Those differences obviate the reasons for not inlining a trivial rhs, and increase the benefit for doing so. So we unconditionally inline trivial rhss here. Note [Preserve join-binding arity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Be careful /not/ to eta-reduce the RHS of a join point, lest we lose the join-point arity invariant. #15108 was caused by simplifying the RHS with simple_opt_expr, which does eta-reduction. Solution: simplify the RHS of a join point by simplifying under the lambdas (which of course should be there). Note [simple_app and join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In general for let-bindings we can do this: (let { x = e } in b) a ==> let { x = e } in b a But not for join points! For two reasons: - We would need to push the continuation into the RHS: (join { j = e } in b) a ==> let { j' = e a } in b[j'/j] a NB ----^^ and also change the type of j, hence j'. That's a bit sophisticated for the very simple optimiser. - We might end up with something like join { j' = e a } in (case blah of ) ( True -> j' void# ) a ( False -> blah ) and now the call to j' doesn't look like a tail call, and Lint may reject. I say "may" because this is /explicitly/ allowed in the "Compiling without Continuations" paper (Section 3, "Managing \Delta"). But GHC currently does not allow this slightly-more-flexible form. See CoreSyn Note [Join points are less general than the paper]. The simple thing to do is to disable this transformation for join points in the simple optimiser Note [The Let-Unfoldings Invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A program has the Let-Unfoldings property iff: - For every let-bound variable f, whether top-level or nested, whether recursive or not: - Both the binding Id of f, and every occurence Id of f, has an idUnfolding. - For non-INLINE things, that unfolding will be f's right hand sids - For INLINE things (which have a "stable" unfolding) that unfolding is semantically equivalent to f's RHS, but derived from the original RHS of f rather that its current RHS. Informally, we can say that in a program that has the Let-Unfoldings property, all let-bound Id's have an explicit unfolding attached to them. Currently, the simplifier guarantees the Let-Unfoldings invariant for anything it outputs. -} ---------------------- subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar]) subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar) subst_opt_bndr env bndr | isTyVar bndr = (env { soe_subst = subst_tv }, tv') | isCoVar bndr = (env { soe_subst = subst_cv }, cv') | otherwise = subst_opt_id_bndr env bndr where subst = soe_subst env (subst_tv, tv') = substTyVarBndr subst bndr (subst_cv, cv') = substCoVarBndr subst bndr subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId) -- Nuke all fragile IdInfo, unfolding, and RULES; it gets added back later by -- add_info. -- -- Rather like SimplEnv.substIdBndr -- -- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr -- carefully does not do) because simplOptExpr invalidates it subst_opt_id_bndr env@(SOE { soe_subst = subst, soe_inl = inl }) old_id = (env { soe_subst = new_subst, soe_inl = new_inl }, new_id) where Subst in_scope id_subst tv_subst cv_subst = subst id1 = uniqAway in_scope old_id id2 = setIdType id1 (substTy subst (idType old_id)) new_id = zapFragileIdInfo id2 -- Zaps rules, unfolding, and fragile OccInfo -- The unfolding and rules will get added back later, by add_info new_in_scope = in_scope `extendInScopeSet` new_id no_change = new_id == old_id -- Extend the substitution if the unique has changed, -- See the notes with substTyVarBndr for the delSubstEnv new_id_subst | no_change = delVarEnv id_subst old_id | otherwise = extendVarEnv id_subst old_id (Var new_id) new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst new_inl = delVarEnv inl old_id ---------------------- add_info :: SimpleOptEnv -> InVar -> TopLevelFlag -> OutExpr -> OutVar -> OutVar add_info env old_bndr top_level new_rhs new_bndr | isTyVar old_bndr = new_bndr | otherwise = lazySetIdInfo new_bndr new_info where subst = soe_subst env dflags = soe_dflags env old_info = idInfo old_bndr -- Add back in the rules and unfolding which were -- removed by zapFragileIdInfo in subst_opt_id_bndr. -- -- See Note [The Let-Unfoldings Invariant] new_info = idInfo new_bndr `setRuleInfo` new_rules `setUnfoldingInfo` new_unfolding old_rules = ruleInfo old_info new_rules = substSpec subst new_bndr old_rules old_unfolding = unfoldingInfo old_info new_unfolding | isStableUnfolding old_unfolding = substUnfolding subst old_unfolding | otherwise = unfolding_from_rhs unfolding_from_rhs = mkUnfolding dflags InlineRhs (isTopLevel top_level) False -- may be bottom or not new_rhs simpleUnfoldingFun :: IdUnfoldingFun simpleUnfoldingFun id | isAlwaysActive (idInlineActivation id) = idUnfolding id | otherwise = noUnfolding wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr wrapLet Nothing body = body wrapLet (Just (b,r)) body = Let (NonRec b r) body {- Note [Inline prag in simplOpt] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If there's an INLINE/NOINLINE pragma that restricts the phase in which the binder can be inlined, we don't inline here; after all, we don't know what phase we're in. Here's an example foo :: Int -> Int -> Int {-# INLINE foo #-} foo m n = inner m where {-# INLINE [1] inner #-} inner m = m+n bar :: Int -> Int bar n = foo n 1 When inlining 'foo' in 'bar' we want the let-binding for 'inner' to remain visible until Phase 1 Note [Unfold compulsory unfoldings in LHSs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When the user writes `RULES map coerce = coerce` as a rule, the rule will only ever match if simpleOptExpr replaces coerce by its unfolding on the LHS, because that is the core that the rule matching engine will find. So do that for everything that has a compulsory unfolding. Also see Note [Desugaring coerce as cast] in Desugar. However, we don't want to inline 'seq', which happens to also have a compulsory unfolding, so we only do this unfolding only for things that are always-active. See Note [User-defined RULES for seq] in MkId. Note [Getting the map/coerce RULE to work] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We wish to allow the "map/coerce" RULE to fire: {-# RULES "map/coerce" map coerce = coerce #-} The naive core produced for this is forall a b (dict :: Coercible * a b). map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict' where dict' :: Coercible [a] [b] dict' = ... This matches literal uses of `map coerce` in code, but that's not what we want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int) too. Some of this is addressed by compulsorily unfolding coerce on the LHS, yielding forall a b (dict :: Coercible * a b). map @a @b (\(x :: a) -> case dict of MkCoercible (co :: a ~R# b) -> x |> co) = ... Getting better. But this isn't exactly what gets produced. This is because Coercible essentially has ~R# as a superclass, and superclasses get eagerly extracted during solving. So we get this: forall a b (dict :: Coercible * a b). case Coercible_SCSel @* @a @b dict of _ [Dead] -> map @a @b (\(x :: a) -> case dict of MkCoercible (co :: a ~R# b) -> x |> co) = ... Unfortunately, this still abstracts over a Coercible dictionary. We really want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, which transforms the above to (see also Note [Desugaring coerce as cast] in Desugar) forall a b (co :: a ~R# b). let dict = MkCoercible @* @a @b co in case Coercible_SCSel @* @a @b dict of _ [Dead] -> map @a @b (\(x :: a) -> case dict of MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... Now, we need simpleOptExpr to fix this up. It does so by taking three separate actions: 1. Inline certain non-recursive bindings. The choice whether to inline is made in simple_bind_pair. Note the rather specific check for MkCoercible in there. 2. Stripping case expressions like the Coercible_SCSel one. See the `Case` case of simple_opt_expr's `go` function. 3. Look for case expressions that unpack something that was just packed and inline them. This is also done in simple_opt_expr's `go` function. This is all a fair amount of special-purpose hackery, but it's for a good cause. And it won't hurt other RULES and such that it comes across. ************************************************************************ * * Join points * * ************************************************************************ -} -- | Returns Just (bndr,rhs) if the binding is a join point: -- If it's a JoinId, just return it -- If it's not yet a JoinId but is always tail-called, -- make it into a JoinId and return it. -- In the latter case, eta-expand the RHS if necessary, to make the -- lambdas explicit, as is required for join points -- -- Precondition: the InBndr has been occurrence-analysed, -- so its OccInfo is valid joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr) joinPointBinding_maybe bndr rhs | not (isId bndr) = Nothing | isJoinId bndr = Just (bndr, rhs) | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr) , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs , let str_sig = idStrictness bndr str_arity = count isId bndrs -- Strictness demands are for Ids only join_bndr = bndr `asJoinId` join_arity `setIdStrictness` etaExpandStrictSig str_arity str_sig = Just (join_bndr, mkLams bndrs body) | otherwise = Nothing joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)] joinPointBindings_maybe bndrs = mapM (uncurry joinPointBinding_maybe) bndrs {- Note [Strictness and join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have let f = \x. if x>200 then e1 else e1 and we know that f is strict in x. Then if we subsequently discover that f is an arity-2 join point, we'll eta-expand it to let f = \x y. if x>200 then e1 else e1 and now it's only strict if applied to two arguments. So we should adjust the strictness info. A more common case is when f = \x. error ".." and again its arity increases (#15517) -} {- ********************************************************************* * * exprIsConApp_maybe * * ************************************************************************ Note [exprIsConApp_maybe] ~~~~~~~~~~~~~~~~~~~~~~~~~ exprIsConApp_maybe is a very important function. There are two principal uses: * case e of { .... } * cls_op e, where cls_op is a class operation In both cases you want to know if e is of form (C e1..en) where C is a data constructor. However e might not *look* as if Note [exprIsConApp_maybe on literal strings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See #9400 and #13317. Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core they are represented as unpackCString# "abc"# by MkCore.mkStringExprFS, or unpackCStringUtf8# when the literal contains multi-byte UTF8 characters. For optimizations we want to be able to treat it as a list, so they can be decomposed when used in a case-statement. exprIsConApp_maybe detects those calls to unpackCString# and returns: Just (':', [Char], ['a', unpackCString# "bc"]). We need to be careful about UTF8 strings here. ""# contains a ByteString, so we must parse it back into a FastString to split off the first character. That way we can treat unpackCString# and unpackCStringUtf8# in the same way. We must also be caeful about lvl = "foo"# ...(unpackCString# lvl)... to ensure that we see through the let-binding for 'lvl'. Hence the (exprIsLiteral_maybe .. arg) in the guard before the call to dealWithStringLiteral. Note [Push coercions in exprIsConApp_maybe] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In #13025 I found a case where we had op (df @t1 @t2) -- op is a ClassOp where df = (/\a b. K e1 e2) |> g To get this to come out we need to simplify on the fly ((/\a b. K e1 e2) |> g) @t1 @t2 Hence the use of pushCoArgs. Note [exprIsConApp_maybe on data constructors with wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Problem: - some data constructors have wrappers - these wrappers inline late (see MkId Note [Activation for data constructor wrappers]) - but we still want case-of-known-constructor to fire early. Example: data T = MkT !Int $WMkT n = case n of n' -> MkT n' -- Wrapper for MkT foo x = case $WMkT e of MkT y -> blah Here we want the case-of-known-constructor transformation to fire, giving foo x = case e of x' -> let y = x' in blah Here's how exprIsConApp_maybe achieves this: 0. Start with scrutinee = $WMkT e 1. Inline $WMkT on-the-fly. That's why data-constructor wrappers are marked as expandable. (See CoreUtils.isExpandableApp.) Now we have scrutinee = (\n. case n of n' -> MkT n') e 2. Beta-reduce the application, generating a floated 'let'. See Note [beta-reduction in exprIsConApp_maybe] below. Now we have scrutinee = case n of n' -> MkT n' with floats {Let n = e} 3. Float the "case x of x' ->" binding out. Now we have scrutinee = MkT n' with floats {Let n = e; case n of n' ->} And now we have a known-constructor MkT that we can return. Notice that both (2) and (3) require exprIsConApp_maybe to gather and return a bunch of floats, both let and case bindings. Note [beta-reduction in exprIsConApp_maybe] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The unfolding a definition (_e.g._ a let-bound variable or a datacon wrapper) is typically a function. For instance, take the wrapper for MkT in Note [exprIsConApp_maybe on data constructors with wrappers]: $WMkT n = case n of { n' -> T n' } If `exprIsConApp_maybe` is trying to analyse `$MkT arg`, upon unfolding of $MkT, it will see (\n -> case n of { n' -> T n' }) arg In order to go progress, `exprIsConApp_maybe` must perform a beta-reduction. We don't want to blindly substitute `arg` in the body of the function, because it duplicates work. We can (and, in fact, used to) substitute `arg` in the body, but only when `arg` is a variable (or something equally work-free). But, because of Note [exprIsConApp_maybe on data constructors with wrappers], 'exprIsConApp_maybe' now returns floats. So, instead, we can beta-reduce _always_: (\x -> body) arg Is transformed into let x = arg in body Which, effectively, means emitting a float `let x = arg` and recursively analysing the body. For newtypes, this strategy requires that their wrappers have compulsory unfoldings. Suppose we have newtype T a b where MkT :: a -> T b a -- Note args swapped This defines a worker function MkT, a wrapper function $WMkT, and an axT: $WMkT :: forall a b. a -> T b a $WMkT = /\b a. \(x:a). MkT a b x -- A real binding MkT :: forall a b. a -> T a b MkT = /\a b. \(x:a). x |> (ax a b) -- A compulsory unfolding axiom axT :: a ~R# T a b Now we are optimising case $WMkT (I# 3) |> sym axT of I# y -> ... we clearly want to simplify this. If $WMkT did not have a compulsory unfolding, we would end up with let a = I#3 in case a of I# y -> ... because in general, we do this on-the-fly beta-reduction (\x. e) blah --> let x = blah in e and then float the the let. (Substitution would risk duplicating 'blah'.) But if the case-of-known-constructor doesn't actually fire (i.e. exprIsConApp_maybe does not return Just) then nothing happens, and nothing will happen the next time either. See test T16254, which checks the behavior of newtypes. -} data ConCont = CC [CoreExpr] Coercion -- Substitution already applied -- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument -- expression is a *saturated* constructor application of the form @let b1 in -- .. let bp in dc t1..tk x1 .. xn@, where t1..tk are the -- *universally-quantified* type args of 'dc'. Floats can also be (and most -- likely are) single-alternative case expressions. Why does -- 'exprIsConApp_maybe' return floats? We may have to look through lets and -- cases to detect that we are in the presence of a data constructor wrapper. In -- this case, we need to return the lets and cases that we traversed. See Note -- [exprIsConApp_maybe on data constructors with wrappers]. Data constructor wrappers -- are unfolded late, but we really want to trigger case-of-known-constructor as -- early as possible. See also Note [Activation for data constructor wrappers] -- in MkId. -- -- We also return the incoming InScopeSet, augmented with -- the binders from any [FloatBind] that we return exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) exprIsConApp_maybe (in_scope, id_unf) expr = go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr))) where go :: Either InScopeSet Subst -- Left in-scope means "empty substitution" -- Right subst means "apply this substitution to the CoreExpr" -- NB: in the call (go subst floats expr cont) -- the substitution applies to 'expr', but /not/ to 'floats' or 'cont' -> [FloatBind] -> CoreExpr -> ConCont -- Notice that the floats here are in reverse order -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) go subst floats (Tick t expr) cont | not (tickishIsCode t) = go subst floats expr cont go subst floats (Cast expr co1) (CC args co2) | Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args -- See Note [Push coercions in exprIsConApp_maybe] = case m_co1' of MCo co1' -> go subst floats expr (CC args' (co1' `mkTransCo` co2)) MRefl -> go subst floats expr (CC args' co2) go subst floats (App fun arg) (CC args co) = go subst floats fun (CC (subst_expr subst arg : args) co) go subst floats (Lam bndr body) (CC (arg:args) co) | exprIsTrivial arg -- Don't duplicate stuff! = go (extend subst bndr arg) floats body (CC args co) | otherwise = let (subst', bndr') = subst_bndr subst bndr float = FloatLet (NonRec bndr' arg) in go subst' (float:floats) body (CC args co) go subst floats (Let (NonRec bndr rhs) expr) cont = let rhs' = subst_expr subst rhs (subst', bndr') = subst_bndr subst bndr float = FloatLet (NonRec bndr' rhs') in go subst' (float:floats) expr cont go subst floats (Case scrut b _ [(con, vars, expr)]) cont = let scrut' = subst_expr subst scrut (subst', b') = subst_bndr subst b (subst'', vars') = subst_bndrs subst' vars float = FloatCase scrut' b' con vars' in go subst'' (float:floats) expr cont go (Right sub) floats (Var v) cont = go (Left (substInScope sub)) floats (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v) cont go (Left in_scope) floats (Var fun) cont@(CC args co) | Just con <- isDataConWorkId_maybe fun , count isValArg args == idArity fun = succeedWith in_scope floats $ pushCoDataCon con args co -- Look through data constructor wrappers: they inline late (See Note -- [Activation for data constructor wrappers]) but we want to do -- case-of-known-constructor optimisation eagerly. | isDataConWrapId fun , let rhs = uf_tmpl (realIdUnfolding fun) = go (Left in_scope) floats rhs cont -- Look through dictionary functions; see Note [Unfolding DFuns] | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding , bndrs `equalLength` args -- See Note [DFun arity check] , let subst = mkOpenSubst in_scope (bndrs `zip` args) = succeedWith in_scope floats $ pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co -- Look through unfoldings, but only arity-zero one; -- if arity > 0 we are effectively inlining a function call, -- and that is the business of callSiteInline. -- In practice, without this test, most of the "hits" were -- CPR'd workers getting inlined back into their wrappers, | idArity fun == 0 , Just rhs <- expandUnfolding_maybe unfolding , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs) = go (Left in_scope') floats rhs cont -- See Note [exprIsConApp_maybe on literal strings] | (fun `hasKey` unpackCStringIdKey) || (fun `hasKey` unpackCStringUtf8IdKey) , [arg] <- args , Just (LitString str) <- exprIsLiteral_maybe (in_scope, id_unf) arg = succeedWith in_scope floats $ dealWithStringLiteral fun str co where unfolding = id_unf fun go _ _ _ _ = Nothing succeedWith :: InScopeSet -> [FloatBind] -> Maybe (DataCon, [Type], [CoreExpr]) -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) succeedWith in_scope rev_floats x = do { (con, tys, args) <- x ; let floats = reverse rev_floats ; return (in_scope, floats, con, tys, args) } ---------------------------- -- Operations on the (Either InScopeSet CoreSubst) -- The Left case is wildly dominant subst_co (Left {}) co = co subst_co (Right s) co = CoreSubst.substCo s co subst_expr (Left {}) e = e subst_expr (Right s) e = substExpr (text "exprIsConApp2") s e subst_bndr msubst bndr = (Right subst', bndr') where (subst', bndr') = substBndr subst bndr subst = case msubst of Left in_scope -> mkEmptySubst in_scope Right subst -> subst subst_bndrs subst bs = mapAccumL subst_bndr subst bs extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) extend (Right s) v e = Right (extendSubst s v e) -- See Note [exprIsConApp_maybe on literal strings] dealWithStringLiteral :: Var -> BS.ByteString -> Coercion -> Maybe (DataCon, [Type], [CoreExpr]) -- This is not possible with user-supplied empty literals, MkCore.mkStringExprFS -- turns those into [] automatically, but just in case something else in GHC -- generates a string literal directly. dealWithStringLiteral _ str co | BS.null str = pushCoDataCon nilDataCon [Type charTy] co dealWithStringLiteral fun str co = let strFS = mkFastStringByteString str char = mkConApp charDataCon [mkCharLit (headFS strFS)] charTail = bytesFS (tailFS strFS) -- In singleton strings, just add [] instead of unpackCstring# ""#. rest = if BS.null charTail then mkConApp nilDataCon [Type charTy] else App (Var fun) (Lit (LitString charTail)) in pushCoDataCon consDataCon [Type charTy, char, rest] co {- Note [Unfolding DFuns] ~~~~~~~~~~~~~~~~~~~~~~ DFuns look like df :: forall a b. (Eq a, Eq b) -> Eq (a,b) df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b) ($c2 a b d_a d_b) So to split it up we just need to apply the ops $c1, $c2 etc to the very same args as the dfun. It takes a little more work to compute the type arguments to the dictionary constructor. Note [DFun arity check] ~~~~~~~~~~~~~~~~~~~~~~~ Here we check that the total number of supplied arguments (inclding type args) matches what the dfun is expecting. This may be *less* than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn -} exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal -- Same deal as exprIsConApp_maybe, but much simpler -- Nevertheless we do need to look through unfoldings for -- Integer and string literals, which are vigorously hoisted to top level -- and not subsequently inlined exprIsLiteral_maybe env@(_, id_unf) e = case e of Lit l -> Just l Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? Var v | Just rhs <- expandUnfolding_maybe (id_unf v) -> exprIsLiteral_maybe env rhs _ -> Nothing {- Note [exprIsLambda_maybe] ~~~~~~~~~~~~~~~~~~~~~~~~~~ exprIsLambda_maybe will, given an expression `e`, try to turn it into the form `Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through casts (using the Push rule), and it unfolds function calls if the unfolding has a greater arity than arguments are present. Currently, it is used in Rules.match, and is required to make "map coerce = coerce" match. -} exprIsLambda_maybe :: InScopeEnv -> CoreExpr -> Maybe (Var, CoreExpr,[Tickish Id]) -- See Note [exprIsLambda_maybe] -- The simple case: It is a lambda already exprIsLambda_maybe _ (Lam x e) = Just (x, e, []) -- Still straightforward: Ticks that we can float out of the way exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e) | tickishFloatable t , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e = Just (x, e, t:ts) -- Also possible: A casted lambda. Push the coercion inside exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e -- Only do value lambdas. -- this implies that x is not in scope in gamma (makes this code simpler) , not (isTyVar x) && not (isCoVar x) , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co , let res = Just (x',e',ts) = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)]) res -- Another attempt: See if we find a partial unfolding exprIsLambda_maybe (in_scope_set, id_unf) e | (Var f, as, ts) <- collectArgsTicks tickishFloatable e , idArity f > count isValArg as -- Make sure there is hope to get a lambda , Just rhs <- expandUnfolding_maybe (id_unf f) -- Optimize, for beta-reduction , let e' = simpleOptExprWith unsafeGlobalDynFlags (mkEmptySubst in_scope_set) (rhs `mkApps` as) -- Recurse, because of possible casts , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e' , let res = Just (x', e'', ts++ts') = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')]) res exprIsLambda_maybe _ _e = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e]) Nothing {- ********************************************************************* * * The "push rules" * * ************************************************************************ Here we implement the "push rules" from FC papers: * The push-argument rules, where we can move a coercion past an argument. We have (fun |> co) arg and we want to transform it to (fun arg') |> co' for some suitable co' and tranformed arg'. * The PushK rule for data constructors. We have (K e1 .. en) |> co and we want to tranform to (K e1' .. en') by pushing the coercion into the arguments -} pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion) pushCoArgs co [] = return ([], MCo co) pushCoArgs co (arg:args) = do { (arg', m_co1) <- pushCoArg co arg ; case m_co1 of MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args ; return (arg':args', m_co2) } MRefl -> return (arg':args, MRefl) } pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) -- We have (fun |> co) arg, and we want to transform it to -- (fun arg) |> co -- This may fail, e.g. if (fun :: N) where N is a newtype -- C.f. simplCast in Simplify.hs -- 'co' is always Representational -- If the returned coercion is Nothing, then it would have been reflexive pushCoArg co (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty ; return (Type ty', m_co') } pushCoArg co val_arg = do { (arg_co, m_co') <- pushCoValArg co ; return (val_arg `mkCast` arg_co, m_co') } pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR) -- We have (fun |> co) @ty -- Push the coercion through to return -- (fun @ty') |> co' -- 'co' is always Representational -- If the returned coercion is Nothing, then it would have been reflexive; -- it's faster not to compute it, though. pushCoTyArg co ty -- The following is inefficient - don't do `eqType` here, the coercion -- optimizer will take care of it. See #14737. -- -- | tyL `eqType` tyR -- -- = Just (ty, Nothing) | isReflCo co = Just (ty, MRefl) | isForAllTy_ty tyL = ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty ) Just (ty `mkCastTy` co1, MCo co2) | otherwise = Nothing where Pair tyL tyR = coercionKind co -- co :: tyL ~ tyR -- tyL = forall (a1 :: k1). ty1 -- tyR = forall (a2 :: k2). ty2 co1 = mkSymCo (mkNthCo Nominal 0 co) -- co1 :: k2 ~N k1 -- Note that NthCo can extract a Nominal equality between the -- kinds of the types related by a coercion between forall-types. -- See the NthCo case in CoreLint. co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1) -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ] -- Arg of mkInstCo is always nominal, hence mkNomReflCo pushCoValArg :: CoercionR -> Maybe (Coercion, MCoercion) -- We have (fun |> co) arg -- Push the coercion through to return -- (fun (arg |> co_arg)) |> co_res -- 'co' is always Representational -- If the second returned Coercion is actually Nothing, then no cast is necessary; -- the returned coercion would have been reflexive. pushCoValArg co -- The following is inefficient - don't do `eqType` here, the coercion -- optimizer will take care of it. See #14737. -- -- | tyL `eqType` tyR -- -- = Just (mkRepReflCo arg, Nothing) | isReflCo co = Just (mkRepReflCo arg, MRefl) | isFunTy tyL , (co1, co2) <- decomposeFunCo Representational co -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) -- then co1 :: tyL1 ~ tyR1 -- co2 :: tyL2 ~ tyR2 = ASSERT2( isFunTy tyR, ppr co $$ ppr arg ) Just (mkSymCo co1, MCo co2) | otherwise = Nothing where arg = funArgTy tyR Pair tyL tyR = coercionKind co pushCoercionIntoLambda :: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) -- This implements the Push rule from the paper on coercions -- (\x. e) |> co -- ===> -- (\x'. e |> co') pushCoercionIntoLambda in_scope x e co | ASSERT(not (isTyVar x) && not (isCoVar x)) True , Pair s1s2 t1t2 <- coercionKind co , Just (_s1,_s2) <- splitFunTy_maybe s1s2 , Just (t1,_t2) <- splitFunTy_maybe t1t2 = let (co1, co2) = decomposeFunCo Representational co -- Should we optimize the coercions here? -- Otherwise they might not match too well x' = x `setIdType` t1 in_scope' = in_scope `extendInScopeSet` x' subst = extendIdSubst (mkEmptySubst in_scope') x (mkCast (Var x') co1) in Just (x', substExpr (text "pushCoercionIntoLambda") subst e `mkCast` co2) | otherwise = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) Nothing pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion -> Maybe (DataCon , [Type] -- Universal type args , [CoreExpr]) -- All other args incl existentials -- Implement the KPush reduction rule as described in "Down with kinds" -- The transformation applies iff we have -- (C e1 ... en) `cast` co -- where co :: (T t1 .. tn) ~ to_ty -- The left-hand one must be a T, because exprIsConApp returned True -- but the right-hand one might not be. (Though it usually will.) pushCoDataCon dc dc_args co | isReflCo co || from_ty `eqType` to_ty -- try cheap test first , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args = Just (dc, map exprToType univ_ty_args, rest_args) | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty , to_tc == dataConTyCon dc -- These two tests can fail; we might see -- (C x y) `cast` (g :: T a ~ S [a]), -- where S is a type function. In fact, exprIsConApp -- will probably not be called in such circumstances, -- but there's nothing wrong with it = let tc_arity = tyConArity to_tc dc_univ_tyvars = dataConUnivTyVars dc dc_ex_tcvars = dataConExTyCoVars dc arg_tys = dataConRepArgTys dc non_univ_args = dropList dc_univ_tyvars dc_args (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args -- Make the "Psi" from the paper omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc) (psi_subst, to_ex_arg_tys) = liftCoSubstWithEx Representational dc_univ_tyvars omegas dc_ex_tcvars (map exprToType ex_args) -- Cast the value arguments (which include dictionaries) new_val_args = zipWith cast_arg arg_tys val_args cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) to_ex_args = map Type to_ex_arg_tys dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars, ppr arg_tys, ppr dc_args, ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ] in ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc ) ASSERT2( equalLength val_args arg_tys, dump_doc ) Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) | otherwise = Nothing where Pair from_ty to_ty = coercionKind co collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) -- Collect lambda binders, pushing coercions inside if possible -- E.g. (\x.e) |> g g :: -> blah -- = (\x. e |> Nth 1 g) -- -- That is, -- -- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g) collectBindersPushingCo e = go [] e where -- Peel off lambdas until we hit a cast. go :: [Var] -> CoreExpr -> ([Var], CoreExpr) -- The accumulator is in reverse order go bs (Lam b e) = go (b:bs) e go bs (Cast e co) = go_c bs e co go bs e = (reverse bs, e) -- We are in a cast; peel off casts until we hit a lambda. go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr) -- (go_c bs e c) is same as (go bs e (e |> c)) go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2) go_c bs (Lam b e) co = go_lam bs b e co go_c bs e co = (reverse bs, mkCast e co) -- We are in a lambda under a cast; peel off lambdas and build a -- new coercion for the body. go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr) -- (go_lam bs b e c) is same as (go_c bs (\b.e) c) go_lam bs b e co | isTyVar b , let Pair tyL tyR = coercionKind co , ASSERT( isForAllTy_ty tyL ) isForAllTy_ty tyR , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) | isCoVar b , let Pair tyL tyR = coercionKind co , ASSERT( isForAllTy_co tyL ) isForAllTy_co tyR , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] , let cov = mkCoVarCo b = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov))) | isId b , let Pair tyL tyR = coercionKind co , ASSERT( isFunTy tyL) isFunTy tyR , (co_arg, co_res) <- decomposeFunCo Representational co , isReflCo co_arg -- See Note [collectBindersPushingCo] = go_c (b:bs) e co_res | otherwise = (reverse bs, mkCast (Lam b e) co) {- Note [collectBindersPushingCo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We just look for coercions of form -> blah (and similarly for foralls) to keep this function simple. We could do more elaborate stuff, but it'd involve substitution etc. -} ghc-lib-parser-8.10.2.20200808/compiler/coreSyn/CoreSeq.hs0000644000000000000000000000720513713635744020643 0ustar0000000000000000-- | -- Various utilities for forcing Core structures -- -- It can often be useful to force various parts of the AST. This module -- provides a number of @seq@-like functions to accomplish this. module CoreSeq ( -- * Utilities for forcing Core structures seqExpr, seqExprs, seqUnfolding, seqRules, megaSeqIdInfo, seqRuleInfo, seqBinds, ) where import GhcPrelude import CoreSyn import IdInfo import Demand( seqDemand, seqStrictSig ) import BasicTypes( seqOccInfo ) import VarSet( seqDVarSet ) import Var( varType, tyVarKind ) import Type( seqType, isTyVar ) import Coercion( seqCo ) import Id( Id, idInfo ) -- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the -- compiler megaSeqIdInfo :: IdInfo -> () megaSeqIdInfo info = seqRuleInfo (ruleInfo info) `seq` -- Omitting this improves runtimes a little, presumably because -- some unfoldings are not calculated at all -- seqUnfolding (unfoldingInfo info) `seq` seqDemand (demandInfo info) `seq` seqStrictSig (strictnessInfo info) `seq` seqCaf (cafInfo info) `seq` seqOneShot (oneShotInfo info) `seq` seqOccInfo (occInfo info) seqOneShot :: OneShotInfo -> () seqOneShot l = l `seq` () seqRuleInfo :: RuleInfo -> () seqRuleInfo (RuleInfo rules fvs) = seqRules rules `seq` seqDVarSet fvs seqCaf :: CafInfo -> () seqCaf c = c `seq` () seqRules :: [CoreRule] -> () seqRules [] = () seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules seqRules (BuiltinRule {} : rules) = seqRules rules seqExpr :: CoreExpr -> () seqExpr (Var v) = v `seq` () seqExpr (Lit lit) = lit `seq` () seqExpr (App f a) = seqExpr f `seq` seqExpr a seqExpr (Lam b e) = seqBndr b `seq` seqExpr e seqExpr (Let b e) = seqBind b `seq` seqExpr e seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as seqExpr (Cast e co) = seqExpr e `seq` seqCo co seqExpr (Tick n e) = seqTickish n `seq` seqExpr e seqExpr (Type t) = seqType t seqExpr (Coercion co) = seqCo co seqExprs :: [CoreExpr] -> () seqExprs [] = () seqExprs (e:es) = seqExpr e `seq` seqExprs es seqTickish :: Tickish Id -> () seqTickish ProfNote{ profNoteCC = cc } = cc `seq` () seqTickish HpcTick{} = () seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids seqTickish SourceNote{} = () seqBndr :: CoreBndr -> () seqBndr b | isTyVar b = seqType (tyVarKind b) | otherwise = seqType (varType b) `seq` megaSeqIdInfo (idInfo b) seqBndrs :: [CoreBndr] -> () seqBndrs [] = () seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs seqBinds :: [Bind CoreBndr] -> () seqBinds bs = foldr (seq . seqBind) () bs seqBind :: Bind CoreBndr -> () seqBind (NonRec b e) = seqBndr b `seq` seqExpr e seqBind (Rec prs) = seqPairs prs seqPairs :: [(CoreBndr, CoreExpr)] -> () seqPairs [] = () seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs seqAlts :: [CoreAlt] -> () seqAlts [] = () seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts seqUnfolding :: Unfolding -> () seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, uf_is_value = b1, uf_is_work_free = b2, uf_expandable = b3, uf_is_conlike = b4, uf_guidance = g}) = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g seqUnfolding _ = () seqGuidance :: UnfoldingGuidance -> () seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () seqGuidance _ = () ghc-lib-parser-8.10.2.20200808/compiler/coreSyn/CoreStats.hs0000644000000000000000000001123613713635744021210 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-2015 -} -- | Functions to computing the statistics reflective of the "size" -- of a Core expression module CoreStats ( -- * Expression and bindings size coreBindsSize, exprSize, CoreStats(..), coreBindsStats, exprStats, ) where import GhcPrelude import BasicTypes import CoreSyn import Outputable import Coercion import Var import Type (Type, typeSize) import Id (isJoinId) data CoreStats = CS { cs_tm :: !Int -- Terms , cs_ty :: !Int -- Types , cs_co :: !Int -- Coercions , cs_vb :: !Int -- Local value bindings , cs_jb :: !Int } -- Local join bindings instance Outputable CoreStats where ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3, cs_vb = i4, cs_jb = i5 }) = braces (sep [text "terms:" <+> intWithCommas i1 <> comma, text "types:" <+> intWithCommas i2 <> comma, text "coercions:" <+> intWithCommas i3 <> comma, text "joins:" <+> intWithCommas i5 <> char '/' <> intWithCommas (i4 + i5) ]) plusCS :: CoreStats -> CoreStats -> CoreStats plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1, cs_vb = v1, cs_jb = j1 }) (CS { cs_tm = p2, cs_ty = q2, cs_co = r2, cs_vb = v2, cs_jb = j2 }) = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2, cs_vb = v1+v2 , cs_jb = j1+j2 } zeroCS, oneTM :: CoreStats zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0, cs_vb = 0, cs_jb = 0 } oneTM = zeroCS { cs_tm = 1 } sumCS :: (a -> CoreStats) -> [a] -> CoreStats sumCS f = foldl' (\s a -> plusCS s (f a)) zeroCS coreBindsStats :: [CoreBind] -> CoreStats coreBindsStats = sumCS (bindStats TopLevel) bindStats :: TopLevelFlag -> CoreBind -> CoreStats bindStats top_lvl (NonRec v r) = bindingStats top_lvl v r bindStats top_lvl (Rec prs) = sumCS (\(v,r) -> bindingStats top_lvl v r) prs bindingStats :: TopLevelFlag -> Var -> CoreExpr -> CoreStats bindingStats top_lvl v r = letBndrStats top_lvl v `plusCS` exprStats r bndrStats :: Var -> CoreStats bndrStats v = oneTM `plusCS` tyStats (varType v) letBndrStats :: TopLevelFlag -> Var -> CoreStats letBndrStats top_lvl v | isTyVar v || isTopLevel top_lvl = bndrStats v | isJoinId v = oneTM { cs_jb = 1 } `plusCS` ty_stats | otherwise = oneTM { cs_vb = 1 } `plusCS` ty_stats where ty_stats = tyStats (varType v) exprStats :: CoreExpr -> CoreStats exprStats (Var {}) = oneTM exprStats (Lit {}) = oneTM exprStats (Type t) = tyStats t exprStats (Coercion c) = coStats c exprStats (App f a) = exprStats f `plusCS` exprStats a exprStats (Lam b e) = bndrStats b `plusCS` exprStats e exprStats (Let b e) = bindStats NotTopLevel b `plusCS` exprStats e exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b `plusCS` sumCS altStats as exprStats (Cast e co) = coStats co `plusCS` exprStats e exprStats (Tick _ e) = exprStats e altStats :: CoreAlt -> CoreStats altStats (_, bs, r) = altBndrStats bs `plusCS` exprStats r altBndrStats :: [Var] -> CoreStats -- Charge one for the alternative, not for each binder altBndrStats vs = oneTM `plusCS` sumCS (tyStats . varType) vs tyStats :: Type -> CoreStats tyStats ty = zeroCS { cs_ty = typeSize ty } coStats :: Coercion -> CoreStats coStats co = zeroCS { cs_co = coercionSize co } coreBindsSize :: [CoreBind] -> Int -- We use coreBindStats for user printout -- but this one is a quick and dirty basis for -- the simplifier's tick limit coreBindsSize bs = sum (map bindSize bs) exprSize :: CoreExpr -> Int -- ^ A measure of the size of the expressions, strictly greater than 0 -- Counts *leaves*, not internal nodes. Types and coercions are not counted. exprSize (Var _) = 1 exprSize (Lit _) = 1 exprSize (App f a) = exprSize f + exprSize a exprSize (Lam b e) = bndrSize b + exprSize e exprSize (Let b e) = bindSize b + exprSize e exprSize (Case e b _ as) = exprSize e + bndrSize b + 1 + sum (map altSize as) exprSize (Cast e _) = 1 + exprSize e exprSize (Tick n e) = tickSize n + exprSize e exprSize (Type _) = 1 exprSize (Coercion _) = 1 tickSize :: Tickish Id -> Int tickSize (ProfNote _ _ _) = 1 tickSize _ = 1 bndrSize :: Var -> Int bndrSize _ = 1 bndrsSize :: [Var] -> Int bndrsSize = sum . map bndrSize bindSize :: CoreBind -> Int bindSize (NonRec b e) = bndrSize b + exprSize e bindSize (Rec prs) = sum (map pairSize prs) pairSize :: (Var, CoreExpr) -> Int pairSize (b,e) = bndrSize b + exprSize e altSize :: CoreAlt -> Int altSize (_,bs,e) = bndrsSize bs + exprSize e ghc-lib-parser-8.10.2.20200808/compiler/coreSyn/CoreSubst.hs0000644000000000000000000007447013713635744021223 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 Utility functions on @Core@ syntax -} {-# LANGUAGE CPP #-} module CoreSubst ( -- * Main data types Subst(..), -- Implementation exported for supercompiler's Renaming.hs only TvSubstEnv, IdSubstEnv, InScopeSet, -- ** Substituting into expressions and related types deShadowBinds, substSpec, substRulesForImportedIds, substTy, substCo, substExpr, substExprSC, substBind, substBindSC, substUnfolding, substUnfoldingSC, lookupIdSubst, lookupTCvSubst, substIdType, substIdOcc, substTickish, substDVarSet, substIdInfo, -- ** Operations on substitutions emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds, isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst, delBndr, delBndrs, -- ** Substituting and cloning binders substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr, cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, ) where #include "GhclibHsVersions.h" import GhcPrelude import CoreSyn import CoreFVs import CoreSeq import CoreUtils import qualified Type import qualified Coercion -- We are defining local versions import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList , isInScope, substTyVarBndr, cloneTyVarBndr ) import Coercion hiding ( substCo, substCoVarBndr ) import PrelNames import VarSet import VarEnv import Id import Name ( Name ) import Var import IdInfo import UniqSupply import Maybes import Util import Outputable import Data.List {- ************************************************************************ * * \subsection{Substitutions} * * ************************************************************************ -} -- | A substitution environment, containing 'Id', 'TyVar', and 'CoVar' -- substitutions. -- -- Some invariants apply to how you use the substitution: -- -- 1. Note [The substitution invariant] in TyCoSubst -- -- 2. Note [Substitutions apply only once] in TyCoSubst data Subst = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/ -- applying the substitution IdSubstEnv -- Substitution from NcIds to CoreExprs TvSubstEnv -- Substitution from TyVars to Types CvSubstEnv -- Substitution from CoVars to Coercions -- INVARIANT 1: See TyCoSubst Note [The substitution invariant] -- This is what lets us deal with name capture properly -- It's a hard invariant to check... -- -- INVARIANT 2: The substitution is apply-once; see Note [Apply once] with -- Types.TvSubstEnv -- -- INVARIANT 3: See Note [Extending the Subst] {- Note [Extending the Subst] ~~~~~~~~~~~~~~~~~~~~~~~~~~ For a core Subst, which binds Ids as well, we make a different choice for Ids than we do for TyVars. For TyVars, see Note [Extending the TCvSubst] in TyCoSubst. For Ids, we have a different invariant The IdSubstEnv is extended *only* when the Unique on an Id changes Otherwise, we just extend the InScopeSet In consequence: * If all subst envs are empty, substExpr would be a no-op, so substExprSC ("short cut") does nothing. However, substExpr still goes ahead and substitutes. Reason: we may want to replace existing Ids with new ones from the in-scope set, to avoid space leaks. * In substIdBndr, we extend the IdSubstEnv only when the unique changes * If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty, substExpr does nothing (Note that the above rule for substIdBndr maintains this property. If the incoming envts are both empty, then substituting the type and IdInfo can't change anything.) * In lookupIdSubst, we *must* look up the Id in the in-scope set, because it may contain non-trivial changes. Example: (/\a. \x:a. ...x...) Int We extend the TvSubstEnv with [a |-> Int]; but x's unique does not change so we only extend the in-scope set. Then we must look up in the in-scope set when we find the occurrence of x. * The requirement to look up the Id in the in-scope set means that we must NOT take no-op short cut when the IdSubst is empty. We must still look up every Id in the in-scope set. * (However, we don't need to do so for expressions found in the IdSubst itself, whose range is assumed to be correct wrt the in-scope set.) Why do we make a different choice for the IdSubstEnv than the TvSubstEnv and CvSubstEnv? * For Ids, we change the IdInfo all the time (e.g. deleting the unfolding), and adding it back later, so using the TyVar convention would entail extending the substitution almost all the time * The simplifier wants to look up in the in-scope set anyway, in case it can see a better unfolding from an enclosing case expression * For TyVars, only coercion variables can possibly change, and they are easy to spot -} -- | An environment for substituting for 'Id's type IdSubstEnv = IdEnv CoreExpr -- Domain is NcIds, i.e. not coercions ---------------------------- isEmptySubst :: Subst -> Bool isEmptySubst (Subst _ id_env tv_env cv_env) = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env emptySubst :: Subst emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv mkEmptySubst :: InScopeSet -> Subst mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs -- | Find the in-scope set: see TyCoSubst Note [The substitution invariant] substInScope :: Subst -> InScopeSet substInScope (Subst in_scope _ _ _) = in_scope -- | Remove all substitutions for 'Id's and 'Var's that might have been built up -- while preserving the in-scope set zapSubstEnv :: Subst -> Subst zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is -- such that TyCoSubst Note [The substitution invariant] -- holds after extending the substitution like this extendIdSubst :: Subst -> Id -> CoreExpr -> Subst -- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set extendIdSubst (Subst in_scope ids tvs cvs) v r = ASSERT2( isNonCoVarId v, ppr v $$ ppr r ) Subst in_scope (extendVarEnv ids v r) tvs cvs -- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst' extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst extendIdSubstList (Subst in_scope ids tvs cvs) prs = ASSERT( all (isNonCoVarId . fst) prs ) Subst in_scope (extendVarEnvList ids prs) tvs cvs -- | Add a substitution for a 'TyVar' to the 'Subst' -- The 'TyVar' *must* be a real TyVar, and not a CoVar -- You must ensure that the in-scope set is such that -- TyCoSubst Note [The substitution invariant] holds -- after extending the substitution like this. extendTvSubst :: Subst -> TyVar -> Type -> Subst extendTvSubst (Subst in_scope ids tvs cvs) tv ty = ASSERT( isTyVar tv ) Subst in_scope ids (extendVarEnv tvs tv ty) cvs -- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst extendTvSubstList subst vrs = foldl' extend subst vrs where extend subst (v, r) = extendTvSubst subst v r -- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': -- you must ensure that the in-scope set satisfies -- TyCoSubst Note [The substitution invariant] -- after extending the substitution like this extendCvSubst :: Subst -> CoVar -> Coercion -> Subst extendCvSubst (Subst in_scope ids tvs cvs) v r = ASSERT( isCoVar v ) Subst in_scope ids tvs (extendVarEnv cvs v r) -- | Add a substitution appropriate to the thing being substituted -- (whether an expression, type, or coercion). See also -- 'extendIdSubst', 'extendTvSubst', 'extendCvSubst' extendSubst :: Subst -> Var -> CoreArg -> Subst extendSubst subst var arg = case arg of Type ty -> ASSERT( isTyVar var ) extendTvSubst subst var ty Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co _ -> ASSERT( isId var ) extendIdSubst subst var arg extendSubstWithVar :: Subst -> Var -> Var -> Subst extendSubstWithVar subst v1 v2 | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2) | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2) | otherwise = ASSERT( isId v2 ) extendIdSubst subst v1 (Var v2) -- | Add a substitution as appropriate to each of the terms being -- substituted (whether expressions, types, or coercions). See also -- 'extendSubst'. extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst extendSubstList subst [] = subst extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs -- | Find the substitution for an 'Id' in the 'Subst' lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr lookupIdSubst doc (Subst in_scope ids _ _) v | not (isLocalId v) = Var v | Just e <- lookupVarEnv ids v = e | Just v' <- lookupInScope in_scope v = Var v' -- Vital! See Note [Extending the Subst] | otherwise = WARN( True, text "CoreSubst.lookupIdSubst" <+> doc <+> ppr v $$ ppr in_scope) Var v -- | Find the substitution for a 'TyVar' in the 'Subst' lookupTCvSubst :: Subst -> TyVar -> Type lookupTCvSubst (Subst _ _ tvs cvs) v | isTyVar v = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v | otherwise = mkCoercionTy $ lookupVarEnv cvs v `orElse` mkCoVarCo v delBndr :: Subst -> Var -> Subst delBndr (Subst in_scope ids tvs cvs) v | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v) | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs delBndrs :: Subst -> [Var] -> Subst delBndrs (Subst in_scope ids tvs cvs) vs = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs) -- Easiest thing is just delete all from all! -- | Simultaneously substitute for a bunch of variables -- No left-right shadowing -- ie the substitution for (\x \y. e) a1 a2 -- so neither x nor y scope over a1 a2 mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst mkOpenSubst in_scope pairs = Subst in_scope (mkVarEnv [(id,e) | (id, e) <- pairs, isId id]) (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs]) (mkVarEnv [(v,co) | (v, Coercion co) <- pairs]) ------------------------------ isInScope :: Var -> Subst -> Bool isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope -- | Add the 'Var' to the in-scope set, but do not remove -- any existing substitutions for it addInScopeSet :: Subst -> VarSet -> Subst addInScopeSet (Subst in_scope ids tvs cvs) vs = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs -- | Add the 'Var' to the in-scope set: as a side effect, -- and remove any existing substitutions for it extendInScope :: Subst -> Var -> Subst extendInScope (Subst in_scope ids tvs cvs) v = Subst (in_scope `extendInScopeSet` v) (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v) -- | Add the 'Var's to the in-scope set: see also 'extendInScope' extendInScopeList :: Subst -> [Var] -> Subst extendInScopeList (Subst in_scope ids tvs cvs) vs = Subst (in_scope `extendInScopeSetList` vs) (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs) -- | Optimized version of 'extendInScopeList' that can be used if you are certain -- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's extendInScopeIds :: Subst -> [Id] -> Subst extendInScopeIds (Subst in_scope ids tvs cvs) vs = Subst (in_scope `extendInScopeSetList` vs) (ids `delVarEnvList` vs) tvs cvs setInScope :: Subst -> InScopeSet -> Subst setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs -- Pretty printing, for debugging only instance Outputable Subst where ppr (Subst in_scope ids tvs cvs) = text " in_scope_doc $$ text " IdSubst =" <+> ppr ids $$ text " TvSubst =" <+> ppr tvs $$ text " CvSubst =" <+> ppr cvs <> char '>' where in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr) {- ************************************************************************ * * Substituting expressions * * ************************************************************************ -} -- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only -- apply the substitution /once/: -- See Note [Substitutions apply only once] in TyCoSubst -- -- Do *not* attempt to short-cut in the case of an empty substitution! -- See Note [Extending the Subst] substExprSC :: SDoc -> Subst -> CoreExpr -> CoreExpr substExprSC doc subst orig_expr | isEmptySubst subst = orig_expr | otherwise = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $ subst_expr doc subst orig_expr substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr substExpr doc subst orig_expr = subst_expr doc subst orig_expr subst_expr :: SDoc -> Subst -> CoreExpr -> CoreExpr subst_expr doc subst expr = go expr where go (Var v) = lookupIdSubst (doc $$ text "subst_expr") subst v go (Type ty) = Type (substTy subst ty) go (Coercion co) = Coercion (substCo subst co) go (Lit lit) = Lit lit go (App fun arg) = App (go fun) (go arg) go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) go (Cast e co) = Cast (go e) (substCo subst co) -- Do not optimise even identity coercions -- Reason: substitution applies to the LHS of RULES, and -- if you "optimise" an identity coercion, you may -- lose a binder. We optimise the LHS of rules at -- construction time go (Lam bndr body) = Lam bndr' (subst_expr doc subst' body) where (subst', bndr') = substBndr subst bndr go (Let bind body) = Let bind' (subst_expr doc subst' body) where (subst', bind') = substBind subst bind go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts) where (subst', bndr') = substBndr subst bndr go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr doc subst' rhs) where (subst', bndrs') = substBndrs subst bndrs -- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst' -- that should be used by subsequent substitutions. substBind, substBindSC :: Subst -> CoreBind -> (Subst, CoreBind) substBindSC subst bind -- Short-cut if the substitution is empty | not (isEmptySubst subst) = substBind subst bind | otherwise = case bind of NonRec bndr rhs -> (subst', NonRec bndr' rhs) where (subst', bndr') = substBndr subst bndr Rec pairs -> (subst', Rec (bndrs' `zip` rhss')) where (bndrs, rhss) = unzip pairs (subst', bndrs') = substRecBndrs subst bndrs rhss' | isEmptySubst subst' = rhss | otherwise = map (subst_expr (text "substBindSC") subst') rhss substBind subst (NonRec bndr rhs) = (subst', NonRec bndr' (subst_expr (text "substBind") subst rhs)) where (subst', bndr') = substBndr subst bndr substBind subst (Rec pairs) = (subst', Rec (bndrs' `zip` rhss')) where (bndrs, rhss) = unzip pairs (subst', bndrs') = substRecBndrs subst bndrs rhss' = map (subst_expr (text "substBind") subst') rhss -- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply -- by running over the bindings with an empty substitution, because substitution -- returns a result that has no-shadowing guaranteed. -- -- (Actually, within a single /type/ there might still be shadowing, because -- 'substTy' is a no-op for the empty substitution, but that's probably OK.) -- -- [Aug 09] This function is not used in GHC at the moment, but seems so -- short and simple that I'm going to leave it here deShadowBinds :: CoreProgram -> CoreProgram deShadowBinds binds = snd (mapAccumL substBind emptySubst binds) {- ************************************************************************ * * Substituting binders * * ************************************************************************ Remember that substBndr and friends are used when doing expression substitution only. Their only business is substitution, so they preserve all IdInfo (suitably substituted). For example, we *want* to preserve occ info in rules. -} -- | Substitutes a 'Var' for another one according to the 'Subst' given, returning -- the result and an updated 'Subst' that should be used by subsequent substitutions. -- 'IdInfo' is preserved by this process, although it is substituted into appropriately. substBndr :: Subst -> Var -> (Subst, Var) substBndr subst bndr | isTyVar bndr = substTyVarBndr subst bndr | isCoVar bndr = substCoVarBndr subst bndr | otherwise = substIdBndr (text "var-bndr") subst subst bndr -- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right substBndrs :: Subst -> [Var] -> (Subst, [Var]) substBndrs subst bndrs = mapAccumL substBndr subst bndrs -- | Substitute in a mutually recursive group of 'Id's substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) substRecBndrs subst bndrs = (new_subst, new_bndrs) where -- Here's the reason we need to pass rec_subst to subst_id (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs substIdBndr :: SDoc -> Subst -- ^ Substitution to use for the IdInfo -> Subst -> Id -- ^ Substitution and Id to transform -> (Subst, Id) -- ^ Transformed pair -- NB: unfolding may be zapped substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $ (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id) where id1 = uniqAway in_scope old_id -- id1 is cloned if necessary id2 | no_type_change = id1 | otherwise = setIdType id1 (substTy subst old_ty) old_ty = idType old_id no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) || noFreeVarsOfType old_ty -- new_id has the right IdInfo -- The lazy-set is because we're in a loop here, with -- rec_subst, when dealing with a mutually-recursive group new_id = maybeModifyIdInfo mb_new_info id2 mb_new_info = substIdInfo rec_subst id2 (idInfo id2) -- NB: unfolding info may be zapped -- Extend the substitution if the unique has changed -- See the notes with substTyVarBndr for the delVarEnv new_env | no_change = delVarEnv env old_id | otherwise = extendVarEnv env old_id (Var new_id) no_change = id1 == old_id -- See Note [Extending the Subst] -- it's /not/ necessary to check mb_new_info and no_type_change {- Now a variant that unconditionally allocates a new unique. It also unconditionally zaps the OccInfo. -} -- | Very similar to 'substBndr', but it always allocates a new 'Unique' for -- each variable in its output. It substitutes the IdInfo though. cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id) cloneIdBndr subst us old_id = clone_id subst subst (old_id, uniqFromSupply us) -- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final -- substitution from left to right cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) cloneIdBndrs subst us ids = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var]) -- Works for all kinds of variables (typically case binders) -- not just Ids cloneBndrs subst us vs = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us) cloneBndr :: Subst -> Unique -> Var -> (Subst, Var) cloneBndr subst uniq v | isTyVar v = cloneTyVarBndr subst v uniq | otherwise = clone_id subst subst (v,uniq) -- Works for coercion variables too -- | Clone a mutually recursive group of 'Id's cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) cloneRecIdBndrs subst us ids = (subst', ids') where (subst', ids') = mapAccumL (clone_id subst') subst (ids `zip` uniqsFromSupply us) -- Just like substIdBndr, except that it always makes a new unique -- It is given the unique to use clone_id :: Subst -- Substitution for the IdInfo -> Subst -> (Id, Unique) -- Substitution and Id to transform -> (Subst, Id) -- Transformed pair clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq) = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id) where id1 = setVarUnique old_id uniq id2 = substIdType subst id1 new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2 (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id)) | otherwise = (extendVarEnv idvs old_id (Var new_id), cvs) {- ************************************************************************ * * Types and Coercions * * ************************************************************************ For types and coercions we just call the corresponding functions in Type and Coercion, but we have to repackage the substitution, from a Subst to a TCvSubst. -} substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv = case Type.substTyVarBndr (TCvSubst in_scope tv_env cv_env) tv of (TCvSubst in_scope' tv_env' cv_env', tv') -> (Subst in_scope' id_env tv_env' cv_env', tv') cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq = case Type.cloneTyVarBndr (TCvSubst in_scope tv_env cv_env) tv uniq of (TCvSubst in_scope' tv_env' cv_env', tv') -> (Subst in_scope' id_env tv_env' cv_env', tv') substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar) substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv = case Coercion.substCoVarBndr (TCvSubst in_scope tv_env cv_env) cv of (TCvSubst in_scope' tv_env' cv_env', cv') -> (Subst in_scope' id_env tv_env' cv_env', cv') -- | See 'Type.substTy' substTy :: Subst -> Type -> Type substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty getTCvSubst :: Subst -> TCvSubst getTCvSubst (Subst in_scope _ tenv cenv) = TCvSubst in_scope tenv cenv -- | See 'Coercion.substCo' substCo :: HasCallStack => Subst -> Coercion -> Coercion substCo subst co = Coercion.substCo (getTCvSubst subst) co {- ************************************************************************ * * \section{IdInfo substitution} * * ************************************************************************ -} substIdType :: Subst -> Id -> Id substIdType subst@(Subst _ _ tv_env cv_env) id | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || noFreeVarsOfType old_ty = id | otherwise = setIdType id (substTy subst old_ty) -- The tyCoVarsOfType is cheaper than it looks -- because we cache the free tyvars of the type -- in a Note in the id's type itself where old_ty = idType id ------------------ -- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'. substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo substIdInfo subst new_id info | nothing_to_do = Nothing | otherwise = Just (info `setRuleInfo` substSpec subst new_id old_rules `setUnfoldingInfo` substUnfolding subst old_unf) where old_rules = ruleInfo info old_unf = unfoldingInfo info nothing_to_do = isEmptyRuleInfo old_rules && not (isFragileUnfolding old_unf) ------------------ -- | Substitutes for the 'Id's within an unfolding substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding -- Seq'ing on the returned Unfolding is enough to cause -- all the substitutions to happen completely substUnfoldingSC subst unf -- Short-cut version | isEmptySubst subst = unf | otherwise = substUnfolding subst unf substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) = df { df_bndrs = bndrs', df_args = args' } where (subst',bndrs') = substBndrs subst bndrs args' = map (substExpr (text "subst-unf:dfun") subst') args substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) -- Retain an InlineRule! | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work = NoUnfolding | otherwise -- But keep a stable one! = seqExpr new_tmpl `seq` unf { uf_tmpl = new_tmpl } where new_tmpl = substExpr (text "subst-unf") subst tmpl substUnfolding _ unf = unf -- NoUnfolding, OtherCon ------------------ substIdOcc :: Subst -> Id -> Id -- These Ids should not be substituted to non-Ids substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of Var v' -> v' other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst]) ------------------ -- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id' substSpec :: Subst -> Id -> RuleInfo -> RuleInfo substSpec subst new_id (RuleInfo rules rhs_fvs) = seqRuleInfo new_spec `seq` new_spec where subst_ru_fn = const (idName new_id) new_spec = RuleInfo (map (substRule subst subst_ru_fn) rules) (substDVarSet subst rhs_fvs) ------------------ substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule] substRulesForImportedIds subst rules = map (substRule subst not_needed) rules where not_needed name = pprPanic "substRulesForImportedIds" (ppr name) ------------------ substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule -- The subst_ru_fn argument is applied to substitute the ru_fn field -- of the rule: -- - Rules for *imported* Ids never change ru_fn -- - Rules for *local* Ids are in the IdInfo for that Id, -- and the ru_fn field is simply replaced by the new name -- of the Id substRule _ _ rule@(BuiltinRule {}) = rule substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args , ru_fn = fn_name, ru_rhs = rhs , ru_local = is_local }) = rule { ru_bndrs = bndrs' , ru_fn = if is_local then subst_ru_fn fn_name else fn_name , ru_args = map (substExpr doc subst') args , ru_rhs = substExpr (text "foo") subst' rhs } -- Do NOT optimise the RHS (previously we did simplOptExpr here) -- See Note [Substitute lazily] where doc = text "subst-rule" <+> ppr fn_name (subst', bndrs') = substBndrs subst bndrs ------------------ substDVarSet :: Subst -> DVarSet -> DVarSet substDVarSet subst fvs = mkDVarSet $ fst $ foldr (subst_fv subst) ([], emptyVarSet) $ dVarSetElems fvs where subst_fv subst fv acc | isId fv = expr_fvs (lookupIdSubst (text "substDVarSet") subst fv) isLocalVar emptyVarSet $! acc | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc ------------------ substTickish :: Subst -> Tickish Id -> Tickish Id substTickish subst (Breakpoint n ids) = Breakpoint n (map do_one ids) where do_one = getIdFromTrivialExpr . lookupIdSubst (text "subst_tickish") subst substTickish _subst other = other {- Note [Substitute lazily] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ The functions that substitute over IdInfo must be pretty lazy, because they are knot-tied by substRecBndrs. One case in point was #10627 in which a rule for a function 'f' referred to 'f' (at a different type) on the RHS. But instead of just substituting in the rhs of the rule, we were calling simpleOptExpr, which looked at the idInfo for 'f'; result <>. In any case we don't need to optimise the RHS of rules, or unfoldings, because the simplifier will do that. Note [substTickish] ~~~~~~~~~~~~~~~~~~~~~~ A Breakpoint contains a list of Ids. What happens if we ever want to substitute an expression for one of these Ids? First, we ensure that we only ever substitute trivial expressions for these Ids, by marking them as NoOccInfo in the occurrence analyser. Then, when substituting for the Id, we unwrap any type applications and abstractions to get back to an Id, with getIdFromTrivialExpr. Second, we have to ensure that we never try to substitute a literal for an Id in a breakpoint. We ensure this by never storing an Id with an unlifted type in a Breakpoint - see Coverage.mkTickish. Breakpoints can't handle free variables with unlifted types anyway. -} {- Note [Worker inlining] ~~~~~~~~~~~~~~~~~~~~~~ A worker can get sustituted away entirely. - it might be trivial - it might simply be very small We do not treat an InlWrapper as an 'occurrence' in the occurrence analyser, so it's possible that the worker is not even in scope any more. In all all these cases we simply drop the special case, returning to InlVanilla. The WARN is just so I can see if it happens a lot. -} ghc-lib-parser-8.10.2.20200808/compiler/coreSyn/CoreSyn.hs0000644000000000000000000026770313713635744020677 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-} -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection module CoreSyn ( -- * Main data types Expr(..), Alt, Bind(..), AltCon(..), Arg, Tickish(..), TickishScoping(..), TickishPlacement(..), CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr, -- * In/Out type synonyms InId, InBind, InExpr, InAlt, InArg, InType, InKind, InBndr, InVar, InCoercion, InTyVar, InCoVar, OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutKind, OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar, MOutCoercion, -- ** 'Expr' construction mkLet, mkLets, mkLetNonRec, mkLetRec, mkLams, mkApps, mkTyApps, mkCoApps, mkVarApps, mkTyArg, mkIntLit, mkIntLitInt, mkWordLit, mkWordLitWord, mkWord64LitWord64, mkInt64LitInt64, mkCharLit, mkStringLit, mkFloatLit, mkFloatLitFloat, mkDoubleLit, mkDoubleLitDouble, mkConApp, mkConApp2, mkTyBind, mkCoBind, varToCoreExpr, varsToCoreExprs, isId, cmpAltCon, cmpAlt, ltAlt, -- ** Simple 'Expr' access functions and predicates bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, collectBinders, collectTyBinders, collectTyAndValBinders, collectNBinders, collectArgs, stripNArgs, collectArgsTicks, flattenBinds, exprToType, exprToCoercion_maybe, applyTypeToArg, isValArg, isTypeArg, isCoArg, isTyCoArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, -- * Tick-related functions tickishCounts, tickishScoped, tickishScopesLike, tickishFloatable, tickishCanSplit, mkNoCount, mkNoScope, tickishIsCode, tickishPlace, tickishContains, -- * Unfolding data types Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), -- ** Constructing 'Unfolding's noUnfolding, bootUnfolding, evaldUnfolding, mkOtherCon, unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, -- ** Predicates and deconstruction on 'Unfolding' unfoldingTemplate, expandUnfolding_maybe, maybeUnfoldingTemplate, otherCons, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, isStableUnfolding, isFragileUnfolding, hasSomeUnfolding, isBootUnfolding, canUnfold, neverUnfoldGuidance, isStableSource, -- * Annotated expression data types AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, -- ** Operations on annotated expressions collectAnnArgs, collectAnnArgsTicks, -- ** Operations on annotations deAnnotate, deAnnotate', deAnnAlt, deAnnBind, collectAnnBndrs, collectNAnnBndrs, -- * Orphanhood IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor, -- * Core rule data types CoreRule(..), RuleBase, RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, RuleEnv(..), mkRuleEnv, emptyRuleEnv, -- ** Operations on 'CoreRule's ruleArity, ruleName, ruleIdName, ruleActivation, setRuleIdName, ruleModule, isBuiltinRule, isLocalRule, isAutoRule, ) where #include "GhclibHsVersions.h" import GhcPrelude import CostCentre import VarEnv( InScopeSet ) import Var import Type import Coercion import Name import NameSet import NameEnv( NameEnv, emptyNameEnv ) import Literal import DataCon import Module import BasicTypes import DynFlags import Outputable import Util import UniqSet import SrcLoc ( RealSrcSpan, containsSpan ) import Binary import Data.Data hiding (TyCon) import Data.Int import Data.Word infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys) {- ************************************************************************ * * \subsection{The main data types} * * ************************************************************************ These data types are the heart of the compiler -} -- | This is the data type that represents GHCs core intermediate language. Currently -- GHC uses System FC for this purpose, -- which is closely related to the simpler and better known System F . -- -- We get from Haskell source to this Core language in a number of stages: -- -- 1. The source code is parsed into an abstract syntax tree, which is represented -- by the data type 'GHC.Hs.Expr.HsExpr' with the names being 'RdrName.RdrNames' -- -- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName' -- (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical. -- For example, this program: -- -- @ -- f x = let f x = x + 1 -- in f (x - 2) -- @ -- -- Would be renamed by having 'Unique's attached so it looked something like this: -- -- @ -- f_1 x_2 = let f_3 x_4 = x_4 + 1 -- in f_3 (x_2 - 2) -- @ -- But see Note [Shadowing] below. -- -- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating -- type class arguments) to yield a 'GHC.Hs.Expr.HsExpr' type that has 'Id.Id' as it's names. -- -- 4. Finally the syntax tree is /desugared/ from the expressive 'GHC.Hs.Expr.HsExpr' type into -- this 'Expr' type, which has far fewer constructors and hence is easier to perform -- optimization, analysis and code generation on. -- -- The type parameter @b@ is for the type of binders in the expression tree. -- -- The language consists of the following elements: -- -- * Variables -- See Note [Variable occurrences in Core] -- -- * Primitive literals -- -- * Applications: note that the argument may be a 'Type'. -- See Note [CoreSyn let/app invariant] -- See Note [Levity polymorphism invariants] -- -- * Lambda abstraction -- See Note [Levity polymorphism invariants] -- -- * Recursive and non recursive @let@s. Operationally -- this corresponds to allocating a thunk for the things -- bound and then executing the sub-expression. -- -- See Note [CoreSyn letrec invariant] -- See Note [CoreSyn let/app invariant] -- See Note [Levity polymorphism invariants] -- See Note [CoreSyn type and coercion invariant] -- -- * Case expression. Operationally this corresponds to evaluating -- the scrutinee (expression examined) to weak head normal form -- and then examining at most one level of resulting constructor (i.e. you -- cannot do nested pattern matching directly with this). -- -- The binder gets bound to the value of the scrutinee, -- and the 'Type' must be that of all the case alternatives -- -- IMPORTANT: see Note [Case expression invariants] -- -- * Cast an expression to a particular type. -- This is used to implement @newtype@s (a @newtype@ constructor or -- destructor just becomes a 'Cast' in Core) and GADTs. -- -- * Notes. These allow general information to be added to expressions -- in the syntax tree -- -- * A type: this should only show up at the top level of an Arg -- -- * A coercion {- Note [Why does Case have a 'Type' field?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The obvious alternative is exprType (Case scrut bndr alts) | (_,_,rhs1):_ <- alts = exprType rhs1 But caching the type in the Case constructor exprType (Case scrut bndr ty alts) = ty is better for at least three reasons: * It works when there are no alternatives (see case invarant 1 above) * It might be faster in deeply-nested situations. * It might not be quite the same as (exprType rhs) for one of the RHSs in alts. Consider a phantom type synonym type S a = Int and we want to form the case expression case x of { K (a::*) -> (e :: S a) } Then exprType of the RHS is (S a), but we cannot make that be the 'ty' in the Case constructor because 'a' is simply not in scope there. Instead we must expand the synonym to Int before putting it in the Case constructor. See CoreUtils.mkSingleAltCase. So we'd have to do synonym expansion in exprType which would be inefficient. * The type stored in the case is checked with lintInTy. This checks (among other things) that it does not mention any variables that are not in scope. If we did not have the type there, it would be a bit harder for Core Lint to reject case blah of Ex x -> x where data Ex = forall a. Ex a. -} -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.hs data Expr b = Var Id | Lit Literal | App (Expr b) (Arg b) | Lam b (Expr b) | Let (Bind b) (Expr b) | Case (Expr b) b Type [Alt b] -- See Note [Case expression invariants] -- and Note [Why does Case have a 'Type' field?] | Cast (Expr b) Coercion | Tick (Tickish Id) (Expr b) | Type Type | Coercion Coercion deriving Data -- | Type synonym for expressions that occur in function argument positions. -- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not type Arg b = Expr b -- | A case split alternative. Consists of the constructor leading to the alternative, -- the variables bound from the constructor, and the expression to be executed given that binding. -- The default alternative is @(DEFAULT, [], rhs)@ -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.hs type Alt b = (AltCon, [b], Expr b) -- | A case alternative constructor (i.e. pattern match) -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.hs data AltCon = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@. -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@ | LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@ -- Invariant: always an *unlifted* literal -- See Note [Literal alternatives] | DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@ deriving (Eq, Data) -- This instance is a bit shady. It can only be used to compare AltCons for -- a single type constructor. Fortunately, it seems quite unlikely that we'll -- ever need to compare AltCons for different type constructors. -- The instance adheres to the order described in [CoreSyn case invariants] instance Ord AltCon where compare (DataAlt con1) (DataAlt con2) = ASSERT( dataConTyCon con1 == dataConTyCon con2 ) compare (dataConTag con1) (dataConTag con2) compare (DataAlt _) _ = GT compare _ (DataAlt _) = LT compare (LitAlt l1) (LitAlt l2) = compare l1 l2 compare (LitAlt _) DEFAULT = GT compare DEFAULT DEFAULT = EQ compare DEFAULT _ = LT -- | Binding, used for top level bindings in a module and local bindings in a @let@. -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.hs data Bind b = NonRec b (Expr b) | Rec [(b, (Expr b))] deriving Data {- Note [Shadowing] ~~~~~~~~~~~~~~~~ While various passes attempt to rename on-the-fly in a manner that avoids "shadowing" (thereby simplifying downstream optimizations), neither the simplifier nor any other pass GUARANTEES that shadowing is avoided. Thus, all passes SHOULD work fine even in the presence of arbitrary shadowing in their inputs. In particular, scrutinee variables `x` in expressions of the form `Case e x t` are often renamed to variables with a prefix "wild_". These "wild" variables may appear in the body of the case-expression, and further, may be shadowed within the body. So the Unique in a Var is not really unique at all. Still, it's very useful to give a constant-time equality/ordering for Vars, and to give a key that can be used to make sets of Vars (VarSet), or mappings from Vars to other things (VarEnv). Moreover, if you do want to eliminate shadowing, you can give a new Unique to an Id without changing its printable name, which makes debugging easier. Note [Literal alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Literal alternatives (LitAlt lit) are always for *un-lifted* literals. We have one literal, a literal Integer, that is lifted, and we don't allow in a LitAlt, because LitAlt cases don't do any evaluation. Also (see #5603) if you say case 3 of S# x -> ... J# _ _ -> ... (where S#, J# are the constructors for Integer) we don't want the simplifier calling findAlt with argument (LitAlt 3). No no. Integer literals are an opaque encoding of an algebraic data type, not of an unlifted literal, like all the others. Also, we do not permit case analysis with literal patterns on floating-point types. See #9238 and Note [Rules for floating-point comparisons] in PrelRules for the rationale for this restriction. -------------------------- CoreSyn INVARIANTS --------------------------- Note [Variable occurrences in Core] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Variable /occurrences/ are never CoVars, though /bindings/ can be. All CoVars appear in Coercions. For example \(c :: Age~#Int) (d::Int). d |> (sym c) Here 'c' is a CoVar, which is lambda-bound, but it /occurs/ in a Coercion, (sym c). Note [CoreSyn letrec invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The right hand sides of all top-level and recursive @let@s /must/ be of lifted type (see "Type#type_classification" for the meaning of /lifted/ vs. /unlifted/). There is one exception to this rule, top-level @let@s are allowed to bind primitive string literals: see Note [CoreSyn top-level string literals]. Note [CoreSyn top-level string literals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As an exception to the usual rule that top-level binders must be lifted, we allow binding primitive string literals (of type Addr#) of type Addr# at the top level. This allows us to share string literals earlier in the pipeline and crucially allows other optimizations in the Core2Core pipeline to fire. Consider, f n = let a::Addr# = "foo"# in \x -> blah In order to be able to inline `f`, we would like to float `a` to the top. Another option would be to inline `a`, but that would lead to duplicating string literals, which we want to avoid. See #8472. The solution is simply to allow top-level unlifted binders. We can't allow arbitrary unlifted expression at the top-level though, unlifted binders cannot be thunks, so we just allow string literals. We allow the top-level primitive string literals to be wrapped in Ticks in the same way they can be wrapped when nested in an expression. CoreToSTG currently discards Ticks around top-level primitive string literals. See #14779. Also see Note [Compilation plan for top-level string literals]. Note [Compilation plan for top-level string literals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is a summary on how top-level string literals are handled by various parts of the compilation pipeline. * In the source language, there is no way to bind a primitive string literal at the top level. * In Core, we have a special rule that permits top-level Addr# bindings. See Note [CoreSyn top-level string literals]. Core-to-core passes may introduce new top-level string literals. * In STG, top-level string literals are explicitly represented in the syntax tree. * A top-level string literal may end up exported from a module. In this case, in the object file, the content of the exported literal is given a label with the _bytes suffix. Note [CoreSyn let/app invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The let/app invariant the right hand side of a non-recursive 'Let', and the argument of an 'App', /may/ be of unlifted type, but only if the expression is ok-for-speculation or the 'Let' is for a join point. This means that the let can be floated around without difficulty. For example, this is OK: y::Int# = x +# 1# But this is not, as it may affect termination if the expression is floated out: y::Int# = fac 4# In this situation you should use @case@ rather than a @let@. The function 'CoreUtils.needsCaseBinding' can help you determine which to generate, or alternatively use 'MkCore.mkCoreLet' rather than this constructor directly, which will generate a @case@ if necessary The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in coreSyn/MkCore. For discussion of some implications of the let/app invariant primops see Note [Checking versus non-checking primops] in PrimOp. Note [Case expression invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Case expressions are one of the more complicated elements of the Core language, and come with a number of invariants. All of them should be checked by Core Lint. 1. The list of alternatives may be empty; See Note [Empty case alternatives] 2. The 'DEFAULT' case alternative must be first in the list, if it occurs at all. Checked in CoreLint.checkCaseAlts. 3. The remaining cases are in order of (strictly) increasing tag (for 'DataAlts') or lit (for 'LitAlts'). This makes finding the relevant constructor easy, and makes comparison easier too. Checked in CoreLint.checkCaseAlts. 4. The list of alternatives must be exhaustive. An /exhaustive/ case does not necessarily mention all constructors: @ data Foo = Red | Green | Blue ... case x of Red -> True other -> f (case x of Green -> ... Blue -> ... ) ... @ The inner case does not need a @Red@ alternative, because @x@ can't be @Red@ at that program point. This is not checked by Core Lint -- it's very hard to do so. E.g. suppose that inner case was floated out, thus: let a = case x of Green -> ... Blue -> ... ) case x of Red -> True other -> f a Now it's really hard to see that the Green/Blue case is exhaustive. But it is. If you have a case-expression that really /isn't/ exhaustive, we may generate seg-faults. Consider the Green/Blue case above. Since there are only two branches we may generate code that tests for Green, and if not Green simply /assumes/ Blue (since, if the case is exhaustive, that's all that remains). Of course, if it's not Blue and we start fetching fields that should be in a Blue constructor, we may die horribly. See also Note [Core Lint guarantee] in CoreLint. 5. Floating-point values must not be scrutinised against literals. See #9238 and Note [Rules for floating-point comparisons] in PrelRules for rationale. Checked in lintCaseExpr; see the call to isFloatingTy. 6. The 'ty' field of (Case scrut bndr ty alts) is the type of the /entire/ case expression. Checked in lintAltExpr. See also Note [Why does Case have a 'Type' field?]. 7. The type of the scrutinee must be the same as the type of the case binder, obviously. Checked in lintCaseExpr. Note [CoreSyn type and coercion invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We allow a /non-recursive/, /non-top-level/ let to bind type and coercion variables. These can be very convenient for postponing type substitutions until the next run of the simplifier. * A type variable binding must have a RHS of (Type ty) * A coercion variable binding must have a RHS of (Coercion co) It is possible to have terms that return a coercion, but we use case-binding for those; e.g. case (eq_sel d) of (co :: a ~# b) -> blah where eq_sel :: (a~b) -> (a~#b) Or even even case (df @Int) of (co :: a ~# b) -> blah Which is very exotic, and I think never encountered; but see Note [Equality superclasses in quantified constraints] in TcCanonical Note [CoreSyn case invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See #case_invariants# Note [Levity polymorphism invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The levity-polymorphism invariants are these (as per "Levity Polymorphism", PLDI '17): * The type of a term-binder must not be levity-polymorphic, unless it is a let(rec)-bound join point (see Note [Invariants on join points]) * The type of the argument of an App must not be levity-polymorphic. A type (t::TYPE r) is "levity polymorphic" if 'r' has any free variables. For example \(r::RuntimeRep). \(a::TYPE r). \(x::a). e is illegal because x's type has kind (TYPE r), which has 'r' free. See Note [Levity polymorphism checking] in DsMonad to see where these invariants are established for user-written code. Note [CoreSyn let goal] ~~~~~~~~~~~~~~~~~~~~~~~ * The simplifier tries to ensure that if the RHS of a let is a constructor application, its arguments are trivial, so that the constructor can be inlined vigorously. Note [Type let] ~~~~~~~~~~~~~~~ See #type_let# Note [Empty case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The alternatives of a case expression should be exhaustive. But this exhaustive list can be empty! * A case expression can have empty alternatives if (and only if) the scrutinee is bound to raise an exception or diverge. When do we know this? See Note [Bottoming expressions] in CoreUtils. * The possibility of empty alternatives is one reason we need a type on the case expression: if the alternatives are empty we can't get the type from the alternatives! * In the case of empty types (see Note [Bottoming expressions]), say data T we do NOT want to replace case (x::T) of Bool {} --> error Bool "Inaccessible case" because x might raise an exception, and *that*'s what we want to see! (#6067 is an example.) To preserve semantics we'd have to say x `seq` error Bool "Inaccessible case" but the 'seq' is just a case, so we are back to square 1. Or I suppose we could say x |> UnsafeCoerce T Bool but that loses all trace of the fact that this originated with an empty set of alternatives. * We can use the empty-alternative construct to coerce error values from one type to another. For example f :: Int -> Int f n = error "urk" g :: Int -> (# Char, Bool #) g x = case f x of { 0 -> ..., n -> ... } Then if we inline f in g's RHS we get case (error Int "urk") of (# Char, Bool #) { ... } and we can discard the alternatives since the scrutinee is bottom to give case (error Int "urk") of (# Char, Bool #) {} This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #), if for no other reason that we don't need to instantiate the (~) at an unboxed type. * We treat a case expression with empty alternatives as trivial iff its scrutinee is (see CoreUtils.exprIsTrivial). This is actually important; see Note [Empty case is trivial] in CoreUtils * An empty case is replaced by its scrutinee during the CoreToStg conversion; remember STG is un-typed, so there is no need for the empty case to do the type conversion. Note [Join points] ~~~~~~~~~~~~~~~~~~ In Core, a *join point* is a specially tagged function whose only occurrences are saturated tail calls. A tail call can appear in these places: 1. In the branches (not the scrutinee) of a case 2. Underneath a let (value or join point) 3. Inside another join point We write a join-point declaration as join j @a @b x y = e1 in e2, like a let binding but with "join" instead (or "join rec" for "let rec"). Note that we put the parameters before the = rather than using lambdas; this is because it's relevant how many parameters the join point takes *as a join point.* This number is called the *join arity,* distinct from arity because it counts types as well as values. Note that a join point may return a lambda! So join j x = x + 1 is different from join j = \x -> x + 1 The former has join arity 1, while the latter has join arity 0. The identifier for a join point is called a join id or a *label.* An invocation is called a *jump.* We write a jump using the jump keyword: jump j 3 The words *label* and *jump* are evocative of assembly code (or Cmm) for a reason: join points are indeed compiled as labeled blocks, and jumps become actual jumps (plus argument passing and stack adjustment). There is no closure allocated and only a fraction of the function-call overhead. Hence we would like as many functions as possible to become join points (see OccurAnal) and the type rules for join points ensure we preserve the properties that make them efficient. In the actual AST, a join point is indicated by the IdDetails of the binder: a local value binding gets 'VanillaId' but a join point gets a 'JoinId' with its join arity. For more details, see the paper: Luke Maurer, Paul Downen, Zena Ariola, and Simon Peyton Jones. "Compiling without continuations." Submitted to PLDI'17. https://www.microsoft.com/en-us/research/publication/compiling-without-continuations/ Note [Invariants on join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Join points must follow these invariants: 1. All occurrences must be tail calls. Each of these tail calls must pass the same number of arguments, counting both types and values; we call this the "join arity" (to distinguish from regular arity, which only counts values). See Note [Join points are less general than the paper] 2. For join arity n, the right-hand side must begin with at least n lambdas. No ticks, no casts, just lambdas! C.f. CoreUtils.joinRhsArity. 2a. Moreover, this same constraint applies to any unfolding of the binder. Reason: if we want to push a continuation into the RHS we must push it into the unfolding as well. 2b. The Arity (in the IdInfo) of a join point is the number of value binders in the top n lambdas, where n is the join arity. So arity <= join arity; the former counts only value binders while the latter counts all binders. e.g. Suppose $j has join arity 1 let j = \x y. e in case x of { A -> j 1; B -> j 2 } Then its ordinary arity is also 1, not 2. The arity of a join point isn't very important; but short of setting it to zero, it is helpful to have an invariant. E.g. #17294. 3. If the binding is recursive, then all other bindings in the recursive group must also be join points. 4. The binding's type must not be polymorphic in its return type (as defined in Note [The polymorphism rule of join points]). However, join points have simpler invariants in other ways 5. A join point can have an unboxed type without the RHS being ok-for-speculation (i.e. drop the let/app invariant) e.g. let j :: Int# = factorial x in ... 6. A join point can have a levity-polymorphic RHS e.g. let j :: r :: TYPE l = fail void# in ... This happened in an intermediate program #13394 Examples: join j1 x = 1 + x in jump j (jump j x) -- Fails 1: non-tail call join j1' x = 1 + x in if even a then jump j1 a else jump j1 a b -- Fails 1: inconsistent calls join j2 x = flip (+) x in j2 1 2 -- Fails 2: not enough lambdas join j2' x = \y -> x + y in j3 1 -- Passes: extra lams ok join j @a (x :: a) = x -- Fails 4: polymorphic in ret type Invariant 1 applies to left-hand sides of rewrite rules, so a rule for a join point must have an exact call as its LHS. Strictly speaking, invariant 3 is redundant, since a call from inside a lazy binding isn't a tail call. Since a let-bound value can't invoke a free join point, then, they can't be mutually recursive. (A Core binding group *can* include spurious extra bindings if the occurrence analyser hasn't run, so invariant 3 does still need to be checked.) For the rigorous definition of "tail call", see Section 3 of the paper (Note [Join points]). Invariant 4 is subtle; see Note [The polymorphism rule of join points]. Invariant 6 is to enable code like this: f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T). join j :: a j = error @r @a "bloop" in case x of A -> j B -> j C -> error @r @a "blurp" Core Lint will check these invariants, anticipating that any binder whose OccInfo is marked AlwaysTailCalled will become a join point as soon as the simplifier (or simpleOptPgm) runs. Note [Join points are less general than the paper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the paper "Compiling without continuations", this expression is perfectly valid: join { j = \_ -> e } in (case blah of ) ( True -> j void# ) arg ( False -> blah ) assuming 'j' has arity 1. Here the call to 'j' does not look like a tail call, but actually everything is fine. See Section 3, "Managing \Delta" in the paper. In GHC, however, we adopt a slightly more restrictive subset, in which join point calls must be tail calls. I think we /could/ loosen it up, but in fact the simplifier ensures that we always get tail calls, and it makes the back end a bit easier I think. Generally, just less to think about; nothing deeper than that. Note [The type of a join point] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A join point has the same type it would have as a function. That is, if it takes an Int and a Bool and its body produces a String, its type is `Int -> Bool -> String`. Natural as this may seem, it can be awkward. A join point shouldn't be thought to "return" in the same sense a function does---a jump is one-way. This is crucial for understanding how case-of-case interacts with join points: case (join j :: Int -> Bool -> String j x y = ... in jump j z w) of "" -> True _ -> False The simplifier will pull the case into the join point (see Note [Case-of-case and join points] in Simplify): join j :: Int -> Bool -> Bool -- changed! j x y = case ... of "" -> True _ -> False in jump j z w The body of the join point now returns a Bool, so the label `j` has to have its type updated accordingly. Inconvenient though this may be, it has the advantage that 'CoreUtils.exprType' can still return a type for any expression, including a jump. This differs from the paper (see Note [Invariants on join points]). In the paper, we instead give j the type `Int -> Bool -> forall a. a`. Then each jump carries the "return type" as a parameter, exactly the way other non-returning functions like `error` work: case (join j :: Int -> Bool -> forall a. a j x y = ... in jump j z w @String) of "" -> True _ -> False Now we can move the case inward and we only have to change the jump: join j :: Int -> Bool -> forall a. a j x y = case ... of "" -> True _ -> False in jump j z w @Bool (Core Lint would still check that the body of the join point has the right type; that type would simply not be reflected in the join id.) Note [The polymorphism rule of join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Invariant 4 of Note [Invariants on join points] forbids a join point to be polymorphic in its return type. That is, if its type is forall a1 ... ak. t1 -> ... -> tn -> r where its join arity is k+n, none of the type parameters ai may occur free in r. In some way, this falls out of the fact that given join j @a1 ... @ak x1 ... xn = e1 in e2 then all calls to `j` are in tail-call positions of `e`, and expressions in tail-call positions in `e` have the same type as `e`. Therefore the type of `e1` -- the return type of the join point -- must be the same as the type of e2. Since the type variables aren't bound in `e2`, its type can't include them, and thus neither can the type of `e1`. This unfortunately prevents the `go` in the following code from being a join-point: iter :: forall a. Int -> (a -> a) -> a -> a iter @a n f x = go @a n f x where go :: forall a. Int -> (a -> a) -> a -> a go @a 0 _ x = x go @a n f x = go @a (n-1) f (f x) In this case, a static argument transformation would fix that (see ticket #14620): iter :: forall a. Int -> (a -> a) -> a -> a iter @a n f x = go' @a n f x where go' :: Int -> (a -> a) -> a -> a go' 0 _ x = x go' n f x = go' (n-1) f (f x) In general, loopification could be employed to do that (see #14068.) Can we simply drop the requirement, and allow `go` to be a join-point? We could, and it would work. But we could not longer apply the case-of-join-point transformation universally. This transformation would do: case (join go @a n f x = case n of 0 -> x n -> go @a (n-1) f (f x) in go @Bool n neg True) of True -> e1; False -> e2 ===> join go @a n f x = case n of 0 -> case x of True -> e1; False -> e2 n -> go @a (n-1) f (f x) in go @Bool n neg True but that is ill-typed, as `x` is type `a`, not `Bool`. This also justifies why we do not consider the `e` in `e |> co` to be in tail position: A cast changes the type, but the type must be the same. But operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for ideas how to fix this. ************************************************************************ * * In/Out type synonyms * * ********************************************************************* -} {- Many passes apply a substitution, and it's very handy to have type synonyms to remind us whether or not the substitution has been applied -} -- Pre-cloning or substitution type InBndr = CoreBndr type InType = Type type InKind = Kind type InBind = CoreBind type InExpr = CoreExpr type InAlt = CoreAlt type InArg = CoreArg type InCoercion = Coercion -- Post-cloning or substitution type OutBndr = CoreBndr type OutType = Type type OutKind = Kind type OutCoercion = Coercion type OutBind = CoreBind type OutExpr = CoreExpr type OutAlt = CoreAlt type OutArg = CoreArg type MOutCoercion = MCoercion {- ********************************************************************* * * Ticks * * ************************************************************************ -} -- | Allows attaching extra information to points in expressions -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.hs data Tickish id = -- | An @{-# SCC #-}@ profiling annotation, either automatically -- added by the desugarer as a result of -auto-all, or added by -- the user. ProfNote { profNoteCC :: CostCentre, -- ^ the cost centre profNoteCount :: !Bool, -- ^ bump the entry count? profNoteScope :: !Bool -- ^ scopes over the enclosed expression -- (i.e. not just a tick) } -- | A "tick" used by HPC to track the execution of each -- subexpression in the original source code. | HpcTick { tickModule :: Module, tickId :: !Int } -- | A breakpoint for the GHCi debugger. This behaves like an HPC -- tick, but has a list of free variables which will be available -- for inspection in GHCi when the program stops at the breakpoint. -- -- NB. we must take account of these Ids when (a) counting free variables, -- and (b) substituting (don't substitute for them) | Breakpoint { breakpointId :: !Int , breakpointFVs :: [id] -- ^ the order of this list is important: -- it matches the order of the lists in the -- appropriate entry in HscTypes.ModBreaks. -- -- Careful about substitution! See -- Note [substTickish] in CoreSubst. } -- | A source note. -- -- Source notes are pure annotations: Their presence should neither -- influence compilation nor execution. The semantics are given by -- causality: The presence of a source note means that a local -- change in the referenced source code span will possibly provoke -- the generated code to change. On the flip-side, the functionality -- of annotated code *must* be invariant against changes to all -- source code *except* the spans referenced in the source notes -- (see "Causality of optimized Haskell" paper for details). -- -- Therefore extending the scope of any given source note is always -- valid. Note that it is still undesirable though, as this reduces -- their usefulness for debugging and profiling. Therefore we will -- generally try only to make use of this property where it is -- necessary to enable optimizations. | SourceNote { sourceSpan :: RealSrcSpan -- ^ Source covered , sourceName :: String -- ^ Name for source location -- (uses same names as CCs) } deriving (Eq, Ord, Data) -- | A "counting tick" (where tickishCounts is True) is one that -- counts evaluations in some way. We cannot discard a counting tick, -- and the compiler should preserve the number of counting ticks as -- far as possible. -- -- However, we still allow the simplifier to increase or decrease -- sharing, so in practice the actual number of ticks may vary, except -- that we never change the value from zero to non-zero or vice versa. tickishCounts :: Tickish id -> Bool tickishCounts n@ProfNote{} = profNoteCount n tickishCounts HpcTick{} = True tickishCounts Breakpoint{} = True tickishCounts _ = False -- | Specifies the scoping behaviour of ticks. This governs the -- behaviour of ticks that care about the covered code and the cost -- associated with it. Important for ticks relating to profiling. data TickishScoping = -- | No scoping: The tick does not care about what code it -- covers. Transformations can freely move code inside as well as -- outside without any additional annotation obligations NoScope -- | Soft scoping: We want all code that is covered to stay -- covered. Note that this scope type does not forbid -- transformations from happening, as long as all results of -- the transformations are still covered by this tick or a copy of -- it. For example -- -- let x = tick<...> (let y = foo in bar) in baz -- ===> -- let x = tick<...> bar; y = tick<...> foo in baz -- -- Is a valid transformation as far as "bar" and "foo" is -- concerned, because both still are scoped over by the tick. -- -- Note though that one might object to the "let" not being -- covered by the tick any more. However, we are generally lax -- with this - constant costs don't matter too much, and given -- that the "let" was effectively merged we can view it as having -- lost its identity anyway. -- -- Also note that this scoping behaviour allows floating a tick -- "upwards" in pretty much any situation. For example: -- -- case foo of x -> tick<...> bar -- ==> -- tick<...> case foo of x -> bar -- -- While this is always leagl, we want to make a best effort to -- only make us of this where it exposes transformation -- opportunities. | SoftScope -- | Cost centre scoping: We don't want any costs to move to other -- cost-centre stacks. This means we not only want no code or cost -- to get moved out of their cost centres, but we also object to -- code getting associated with new cost-centre ticks - or -- changing the order in which they get applied. -- -- A rule of thumb is that we don't want any code to gain new -- annotations. However, there are notable exceptions, for -- example: -- -- let f = \y -> foo in tick<...> ... (f x) ... -- ==> -- tick<...> ... foo[x/y] ... -- -- In-lining lambdas like this is always legal, because inlining a -- function does not change the cost-centre stack when the -- function is called. | CostCentreScope deriving (Eq) -- | Returns the intended scoping rule for a Tickish tickishScoped :: Tickish id -> TickishScoping tickishScoped n@ProfNote{} | profNoteScope n = CostCentreScope | otherwise = NoScope tickishScoped HpcTick{} = NoScope tickishScoped Breakpoint{} = CostCentreScope -- Breakpoints are scoped: eventually we're going to do call -- stacks, but also this helps prevent the simplifier from moving -- breakpoints around and changing their result type (see #1531). tickishScoped SourceNote{} = SoftScope -- | Returns whether the tick scoping rule is at least as permissive -- as the given scoping rule. tickishScopesLike :: Tickish id -> TickishScoping -> Bool tickishScopesLike t scope = tickishScoped t `like` scope where NoScope `like` _ = True _ `like` NoScope = False SoftScope `like` _ = True _ `like` SoftScope = False CostCentreScope `like` _ = True -- | Returns @True@ for ticks that can be floated upwards easily even -- where it might change execution counts, such as: -- -- Just (tick<...> foo) -- ==> -- tick<...> (Just foo) -- -- This is a combination of @tickishSoftScope@ and -- @tickishCounts@. Note that in principle splittable ticks can become -- floatable using @mkNoTick@ -- even though there's currently no -- tickish for which that is the case. tickishFloatable :: Tickish id -> Bool tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t) -- | Returns @True@ for a tick that is both counting /and/ scoping and -- can be split into its (tick, scope) parts using 'mkNoScope' and -- 'mkNoTick' respectively. tickishCanSplit :: Tickish id -> Bool tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True} = True tickishCanSplit _ = False mkNoCount :: Tickish id -> Tickish id mkNoCount n | not (tickishCounts n) = n | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!" mkNoCount n@ProfNote{} = n {profNoteCount = False} mkNoCount _ = panic "mkNoCount: Undefined split!" mkNoScope :: Tickish id -> Tickish id mkNoScope n | tickishScoped n == NoScope = n | not (tickishCanSplit n) = panic "mkNoScope: Cannot split!" mkNoScope n@ProfNote{} = n {profNoteScope = False} mkNoScope _ = panic "mkNoScope: Undefined split!" -- | Return @True@ if this source annotation compiles to some backend -- code. Without this flag, the tickish is seen as a simple annotation -- that does not have any associated evaluation code. -- -- What this means that we are allowed to disregard the tick if doing -- so means that we can skip generating any code in the first place. A -- typical example is top-level bindings: -- -- foo = tick<...> \y -> ... -- ==> -- foo = \y -> tick<...> ... -- -- Here there is just no operational difference between the first and -- the second version. Therefore code generation should simply -- translate the code as if it found the latter. tickishIsCode :: Tickish id -> Bool tickishIsCode SourceNote{} = False tickishIsCode _tickish = True -- all the rest for now -- | Governs the kind of expression that the tick gets placed on when -- annotating for example using @mkTick@. If we find that we want to -- put a tickish on an expression ruled out here, we try to float it -- inwards until we find a suitable expression. data TickishPlacement = -- | Place ticks exactly on run-time expressions. We can still -- move the tick through pure compile-time constructs such as -- other ticks, casts or type lambdas. This is the most -- restrictive placement rule for ticks, as all tickishs have in -- common that they want to track runtime processes. The only -- legal placement rule for counting ticks. PlaceRuntime -- | As @PlaceRuntime@, but we float the tick through all -- lambdas. This makes sense where there is little difference -- between annotating the lambda and annotating the lambda's code. | PlaceNonLam -- | In addition to floating through lambdas, cost-centre style -- tickishs can also be moved from constructors, non-function -- variables and literals. For example: -- -- let x = scc<...> C (scc<...> y) (scc<...> 3) in ... -- -- Neither the constructor application, the variable or the -- literal are likely to have any cost worth mentioning. And even -- if y names a thunk, the call would not care about the -- evaluation context. Therefore removing all annotations in the -- above example is safe. | PlaceCostCentre deriving (Eq) -- | Placement behaviour we want for the ticks tickishPlace :: Tickish id -> TickishPlacement tickishPlace n@ProfNote{} | profNoteCount n = PlaceRuntime | otherwise = PlaceCostCentre tickishPlace HpcTick{} = PlaceRuntime tickishPlace Breakpoint{} = PlaceRuntime tickishPlace SourceNote{} = PlaceNonLam -- | Returns whether one tick "contains" the other one, therefore -- making the second tick redundant. tickishContains :: Eq b => Tickish b -> Tickish b -> Bool tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2) = containsSpan sp1 sp2 && n1 == n2 -- compare the String last tickishContains t1 t2 = t1 == t2 {- ************************************************************************ * * Orphans * * ************************************************************************ -} -- | Is this instance an orphan? If it is not an orphan, contains an 'OccName' -- witnessing the instance's non-orphanhood. -- See Note [Orphans] data IsOrphan = IsOrphan | NotOrphan OccName -- The OccName 'n' witnesses the instance's non-orphanhood -- In that case, the instance is fingerprinted as part -- of the definition of 'n's definition deriving Data -- | Returns true if 'IsOrphan' is orphan. isOrphan :: IsOrphan -> Bool isOrphan IsOrphan = True isOrphan _ = False -- | Returns true if 'IsOrphan' is not an orphan. notOrphan :: IsOrphan -> Bool notOrphan NotOrphan{} = True notOrphan _ = False chooseOrphanAnchor :: NameSet -> IsOrphan -- Something (rule, instance) is relate to all the Names in this -- list. Choose one of them to be an "anchor" for the orphan. We make -- the choice deterministic to avoid gratuitious changes in the ABI -- hash (#4012). Specifically, use lexicographic comparison of -- OccName rather than comparing Uniques -- -- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically -- chooseOrphanAnchor local_names | isEmptyNameSet local_names = IsOrphan | otherwise = NotOrphan (minimum occs) where occs = map nameOccName $ nonDetEltsUniqSet local_names -- It's OK to use nonDetEltsUFM here, see comments above instance Binary IsOrphan where put_ bh IsOrphan = putByte bh 0 put_ bh (NotOrphan n) = do putByte bh 1 put_ bh n get bh = do h <- getByte bh case h of 0 -> return IsOrphan _ -> do n <- get bh return $ NotOrphan n {- Note [Orphans] ~~~~~~~~~~~~~~ Class instances, rules, and family instances are divided into orphans and non-orphans. Roughly speaking, an instance/rule is an orphan if its left hand side mentions nothing defined in this module. Orphan-hood has two major consequences * A module that contains orphans is called an "orphan module". If the module being compiled depends (transitively) on an oprhan module M, then M.hi is read in regardless of whether M is oherwise needed. This is to ensure that we don't miss any instance decls in M. But it's painful, because it means we need to keep track of all the orphan modules below us. * A non-orphan is not finger-printed separately. Instead, for fingerprinting purposes it is treated as part of the entity it mentions on the LHS. For example data T = T1 | T2 instance Eq T where .... The instance (Eq T) is incorprated as part of T's fingerprint. In contrast, orphans are all fingerprinted together in the mi_orph_hash field of the ModIface. See MkIface.addFingerprints. Orphan-hood is computed * For class instances: when we make a ClsInst (because it is needed during instance lookup) * For rules and family instances: when we generate an IfaceRule (MkIface.coreRuleToIfaceRule) or IfaceFamInst (MkIface.instanceToIfaceInst) -} {- ************************************************************************ * * \subsection{Transformation rules} * * ************************************************************************ The CoreRule type and its friends are dealt with mainly in CoreRules, but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation. -} -- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules type RuleBase = NameEnv [CoreRule] -- The rules are unordered; -- we sort out any overlaps on lookup -- | A full rule environment which we can apply rules from. Like a 'RuleBase', -- but it also includes the set of visible orphans we use to filter out orphan -- rules which are not visible (even though we can see them...) data RuleEnv = RuleEnv { re_base :: RuleBase , re_visible_orphs :: ModuleSet } mkRuleEnv :: RuleBase -> [Module] -> RuleEnv mkRuleEnv rules vis_orphs = RuleEnv rules (mkModuleSet vis_orphs) emptyRuleEnv :: RuleEnv emptyRuleEnv = RuleEnv emptyNameEnv emptyModuleSet -- | A 'CoreRule' is: -- -- * \"Local\" if the function it is a rule for is defined in the -- same module as the rule itself. -- -- * \"Orphan\" if nothing on the LHS is defined in the same module -- as the rule itself data CoreRule = Rule { ru_name :: RuleName, -- ^ Name of the rule, for communication with the user ru_act :: Activation, -- ^ When the rule is active -- Rough-matching stuff -- see comments with InstEnv.ClsInst( is_cls, is_rough ) ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side -- Proper-matching stuff -- see comments with InstEnv.ClsInst( is_tvs, is_tys ) ru_bndrs :: [CoreBndr], -- ^ Variables quantified over ru_args :: [CoreExpr], -- ^ Left hand side arguments -- And the right-hand side ru_rhs :: CoreExpr, -- ^ Right hand side of the rule -- Occurrence info is guaranteed correct -- See Note [OccInfo in unfoldings and rules] -- Locality ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated -- (notably by Specialise or SpecConstr) -- @False@ <=> generated at the user's behest -- See Note [Trimming auto-rules] in TidyPgm -- for the sole purpose of this field. ru_origin :: !Module, -- ^ 'Module' the rule was defined in, used -- to test if we should see an orphan rule. ru_orphan :: !IsOrphan, -- ^ Whether or not the rule is an orphan. ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is -- defined in the same module as the rule -- and is not an implicit 'Id' (like a record selector, -- class operation, or data constructor). This -- is different from 'ru_orphan', where a rule -- can avoid being an orphan if *any* Name in -- LHS of the rule was defined in the same -- module as the rule. } -- | Built-in rules are used for constant folding -- and suchlike. They have no free variables. -- A built-in rule is always visible (there is no such thing as -- an orphan built-in rule.) | BuiltinRule { ru_name :: RuleName, -- ^ As above ru_fn :: Name, -- ^ As above ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, -- if it fires, including type arguments ru_try :: RuleFun -- ^ This function does the rewrite. It given too many -- arguments, it simply discards them; the returned 'CoreExpr' -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args } -- See Note [Extra args in rule matching] in Rules.hs type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr type InScopeEnv = (InScopeSet, IdUnfoldingFun) type IdUnfoldingFun = Id -> Unfolding -- A function that embodies how to unfold an Id if you need -- to do that in the Rule. The reason we need to pass this info in -- is that whether an Id is unfoldable depends on the simplifier phase isBuiltinRule :: CoreRule -> Bool isBuiltinRule (BuiltinRule {}) = True isBuiltinRule _ = False isAutoRule :: CoreRule -> Bool isAutoRule (BuiltinRule {}) = False isAutoRule (Rule { ru_auto = is_auto }) = is_auto -- | The number of arguments the 'ru_fn' must be applied -- to before the rule can match on it ruleArity :: CoreRule -> Int ruleArity (BuiltinRule {ru_nargs = n}) = n ruleArity (Rule {ru_args = args}) = length args ruleName :: CoreRule -> RuleName ruleName = ru_name ruleModule :: CoreRule -> Maybe Module ruleModule Rule { ru_origin } = Just ru_origin ruleModule BuiltinRule {} = Nothing ruleActivation :: CoreRule -> Activation ruleActivation (BuiltinRule { }) = AlwaysActive ruleActivation (Rule { ru_act = act }) = act -- | The 'Name' of the 'Id.Id' at the head of the rule left hand side ruleIdName :: CoreRule -> Name ruleIdName = ru_fn isLocalRule :: CoreRule -> Bool isLocalRule = ru_local -- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side setRuleIdName :: Name -> CoreRule -> CoreRule setRuleIdName nm ru = ru { ru_fn = nm } {- ************************************************************************ * * Unfoldings * * ************************************************************************ The @Unfolding@ type is declared here to avoid numerous loops -} -- | Records the /unfolding/ of an identifier, which is approximately the form the -- identifier would have if we substituted its definition in for the identifier. -- This type should be treated as abstract everywhere except in "CoreUnfold" data Unfolding = NoUnfolding -- ^ We have no information about the unfolding. | BootUnfolding -- ^ We have no information about the unfolding, because -- this 'Id' came from an @hi-boot@ file. -- See Note [Inlining and hs-boot files] in ToIface -- for what this is used for. | OtherCon [AltCon] -- ^ It ain't one of these constructors. -- @OtherCon xs@ also indicates that something has been evaluated -- and hence there's no point in re-evaluating it. -- @OtherCon []@ is used even for non-data-type values -- to indicated evaluated-ness. Notably: -- -- > data C = C !(Int -> Int) -- > case x of { C f -> ... } -- -- Here, @f@ gets an @OtherCon []@ unfolding. | DFunUnfolding { -- The Unfolding of a DFunId -- See Note [DFun unfoldings] -- df = /\a1..am. \d1..dn. MkD t1 .. tk -- (op1 a1..am d1..dn) -- (op2 a1..am d1..dn) df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn] df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon) df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods, } -- in positional order | CoreUnfolding { -- An unfolding for an Id with no pragma, -- or perhaps a NOINLINE pragma -- (For NOINLINE, the phase, if any, is in the -- InlinePragInfo for this Id.) uf_tmpl :: CoreExpr, -- Template; occurrence info is correct uf_src :: UnfoldingSource, -- Where the unfolding came from uf_is_top :: Bool, -- True <=> top level binding uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard -- a `seq` on this variable uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function -- Cached version of exprIsConLike uf_is_work_free :: Bool, -- True <=> doesn't waste (much) work to expand -- inside an inlining -- Cached version of exprIsCheap uf_expandable :: Bool, -- True <=> can expand in RULE matching -- Cached version of exprIsExpandable uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template. } -- ^ An unfolding with redundant cached information. Parameters: -- -- uf_tmpl: Template used to perform unfolding; -- NB: Occurrence info is guaranteed correct: -- see Note [OccInfo in unfoldings and rules] -- -- uf_is_top: Is this a top level binding? -- -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on -- this variable -- -- uf_is_work_free: Does this waste only a little work if we expand it inside an inlining? -- Basically this is a cached version of 'exprIsWorkFree' -- -- uf_guidance: Tells us about the /size/ of the unfolding template ------------------------------------------------ data UnfoldingSource = -- See also Note [Historical note: unfoldings for wrappers] InlineRhs -- The current rhs of the function -- Replace uf_tmpl each time around | InlineStable -- From an INLINE or INLINABLE pragma -- INLINE if guidance is UnfWhen -- INLINABLE if guidance is UnfIfGoodArgs/UnfoldNever -- (well, technically an INLINABLE might be made -- UnfWhen if it was small enough, and then -- it will behave like INLINE outside the current -- module, but that is the way automatic unfoldings -- work so it is consistent with the intended -- meaning of INLINABLE). -- -- uf_tmpl may change, but only as a result of -- gentle simplification, it doesn't get updated -- to the current RHS during compilation as with -- InlineRhs. -- -- See Note [InlineStable] | InlineCompulsory -- Something that *has* no binding, so you *must* inline it -- Only a few primop-like things have this property -- (see MkId.hs, calls to mkCompulsoryUnfolding). -- Inline absolutely always, however boring the context. -- | 'UnfoldingGuidance' says when unfolding should take place data UnfoldingGuidance = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl -- Used (a) for small *and* cheap unfoldings -- (b) for INLINE functions -- See Note [INLINE for small functions] in CoreUnfold ug_arity :: Arity, -- Number of value arguments expected ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring -- So True,True means "always" } | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the -- result of a simple analysis of the RHS ug_args :: [Int], -- Discount if the argument is evaluated. -- (i.e., a simplification will definitely -- be possible). One elt of the list per *value* arg. ug_size :: Int, -- The "size" of the unfolding. ug_res :: Int -- Scrutinee discount: the discount to substract if the thing is in } -- a context (case (thing args) of ...), -- (where there are the right number of arguments.) | UnfNever -- The RHS is big, so don't inline it deriving (Eq) {- Note [Historical note: unfoldings for wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to have a nice clever scheme in interface files for wrappers. A wrapper's unfolding can be reconstructed from its worker's id and its strictness. This decreased .hi file size (sometimes significantly, for modules like GHC.Classes with many high-arity w/w splits) and had a slight corresponding effect on compile times. However, when we added the second demand analysis, this scheme lead to some Core lint errors. The second analysis could change the strictness signatures, which sometimes resulted in a wrapper's regenerated unfolding applying the wrapper to too many arguments. Instead of repairing the clever .hi scheme, we abandoned it in favor of simplicity. The .hi sizes are usually insignificant (excluding the +1M for base libraries), and compile time barely increases (~+1% for nofib). The nicer upshot is that the UnfoldingSource no longer mentions an Id, so, eg, substitutions need not traverse them. Note [DFun unfoldings] ~~~~~~~~~~~~~~~~~~~~~~ The Arity in a DFunUnfolding is total number of args (type and value) that the DFun needs to produce a dictionary. That's not necessarily related to the ordinary arity of the dfun Id, esp if the class has one method, so the dictionary is represented by a newtype. Example class C a where { op :: a -> Int } instance C a -> C [a] where op xs = op (head xs) The instance translates to $dfCList :: forall a. C a => C [a] -- Arity 2! $dfCList = /\a.\d. $copList {a} d |> co $copList :: forall a. C a => [a] -> Int -- Arity 2! $copList = /\a.\d.\xs. op {a} d (head xs) Now we might encounter (op (dfCList {ty} d) a1 a2) and we want the (op (dfList {ty} d)) rule to fire, because $dfCList has all its arguments, even though its (value) arity is 2. That's why we record the number of expected arguments in the DFunUnfolding. Note that although it's an Arity, it's most convenient for it to give the *total* number of arguments, both type and value. See the use site in exprIsConApp_maybe. -} -- Constants for the UnfWhen constructor needSaturated, unSaturatedOk :: Bool needSaturated = False unSaturatedOk = True boringCxtNotOk, boringCxtOk :: Bool boringCxtOk = True boringCxtNotOk = False ------------------------------------------------ noUnfolding :: Unfolding -- ^ There is no known 'Unfolding' evaldUnfolding :: Unfolding -- ^ This unfolding marks the associated thing as being evaluated noUnfolding = NoUnfolding evaldUnfolding = OtherCon [] -- | There is no known 'Unfolding', because this came from an -- hi-boot file. bootUnfolding :: Unfolding bootUnfolding = BootUnfolding mkOtherCon :: [AltCon] -> Unfolding mkOtherCon = OtherCon isStableSource :: UnfoldingSource -> Bool -- Keep the unfolding template isStableSource InlineCompulsory = True isStableSource InlineStable = True isStableSource InlineRhs = False -- | Retrieves the template of an unfolding: panics if none is known unfoldingTemplate :: Unfolding -> CoreExpr unfoldingTemplate = uf_tmpl -- | Retrieves the template of an unfolding if possible -- maybeUnfoldingTemplate is used mainly wnen specialising, and we do -- want to specialise DFuns, so it's important to return a template -- for DFunUnfoldings maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) = Just expr maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) = Just (mkLams bndrs (mkApps (Var (dataConWorkId con)) args)) maybeUnfoldingTemplate _ = Nothing -- | The constructors that the unfolding could never be: -- returns @[]@ if no information is available otherCons :: Unfolding -> [AltCon] otherCons (OtherCon cons) = cons otherCons _ = [] -- | Determines if it is certainly the case that the unfolding will -- yield a value (something in HNF): returns @False@ if unsure isValueUnfolding :: Unfolding -> Bool -- Returns False for OtherCon isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald isValueUnfolding _ = False -- | Determines if it possibly the case that the unfolding will -- yield a value. Unlike 'isValueUnfolding' it returns @True@ -- for 'OtherCon' isEvaldUnfolding :: Unfolding -> Bool -- Returns True for OtherCon isEvaldUnfolding (OtherCon _) = True isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald isEvaldUnfolding _ = False -- | @True@ if the unfolding is a constructor application, the application -- of a CONLIKE function or 'OtherCon' isConLikeUnfolding :: Unfolding -> Bool isConLikeUnfolding (OtherCon _) = True isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con }) = con isConLikeUnfolding _ = False -- | Is the thing we will unfold into certainly cheap? isCheapUnfolding :: Unfolding -> Bool isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf isCheapUnfolding _ = False isExpandableUnfolding :: Unfolding -> Bool isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable isExpandableUnfolding _ = False expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr -- Expand an expandable unfolding; this is used in rule matching -- See Note [Expanding variables] in Rules.hs -- The key point here is that CONLIKE things can be expanded expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs expandUnfolding_maybe _ = Nothing isCompulsoryUnfolding :: Unfolding -> Bool isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True isCompulsoryUnfolding _ = False isStableUnfolding :: Unfolding -> Bool -- True of unfoldings that should not be overwritten -- by a CoreUnfolding for the RHS of a let-binding isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src isStableUnfolding (DFunUnfolding {}) = True isStableUnfolding _ = False -- | Only returns False if there is no unfolding information available at all hasSomeUnfolding :: Unfolding -> Bool hasSomeUnfolding NoUnfolding = False hasSomeUnfolding BootUnfolding = False hasSomeUnfolding _ = True isBootUnfolding :: Unfolding -> Bool isBootUnfolding BootUnfolding = True isBootUnfolding _ = False neverUnfoldGuidance :: UnfoldingGuidance -> Bool neverUnfoldGuidance UnfNever = True neverUnfoldGuidance _ = False isFragileUnfolding :: Unfolding -> Bool -- An unfolding is fragile if it mentions free variables or -- is otherwise subject to change. A robust one can be kept. -- See Note [Fragile unfoldings] isFragileUnfolding (CoreUnfolding {}) = True isFragileUnfolding (DFunUnfolding {}) = True isFragileUnfolding _ = False -- NoUnfolding, BootUnfolding, OtherCon are all non-fragile canUnfold :: Unfolding -> Bool canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) canUnfold _ = False {- Note [Fragile unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An unfolding is "fragile" if it mentions free variables (and hence would need substitution) or might be affected by optimisation. The non-fragile ones are NoUnfolding, BootUnfolding OtherCon {} If we know this binder (say a lambda binder) will be bound to an evaluated thing, we want to retain that info in simpleOptExpr; see #13077. We consider even a StableUnfolding as fragile, because it needs substitution. Note [InlineStable] ~~~~~~~~~~~~~~~~~ When you say {-# INLINE f #-} f x = you intend that calls (f e) are replaced by [e/x] So we should capture (\x.) in the Unfolding of 'f', and never meddle with it. Meanwhile, we can optimise to our heart's content, leaving the original unfolding intact in Unfolding of 'f'. For example all xs = foldr (&&) True xs any p = all . map p {-# INLINE any #-} We optimise any's RHS fully, but leave the InlineRule saying "all . map p", which deforests well at the call site. So INLINE pragma gives rise to an InlineRule, which captures the original RHS. Moreover, it's only used when 'f' is applied to the specified number of arguments; that is, the number of argument on the LHS of the '=' sign in the original source definition. For example, (.) is now defined in the libraries like this {-# INLINE (.) #-} (.) f g = \x -> f (g x) so that it'll inline when applied to two arguments. If 'x' appeared on the left, thus (.) f g x = f (g x) it'd only inline when applied to three arguments. This slightly-experimental change was requested by Roman, but it seems to make sense. See also Note [Inlining an InlineRule] in CoreUnfold. Note [OccInfo in unfoldings and rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In unfoldings and rules, we guarantee that the template is occ-analysed, so that the occurrence info on the binders is correct. This is important, because the Simplifier does not re-analyse the template when using it. If the occurrence info is wrong - We may get more simplifier iterations than necessary, because once-occ info isn't there - More seriously, we may get an infinite loop if there's a Rec without a loop breaker marked ************************************************************************ * * AltCon * * ************************************************************************ -} -- The Ord is needed for the FiniteMap used in the lookForConstructor -- in SimplEnv. If you declared that lookForConstructor *ignores* -- constructor-applications with LitArg args, then you could get -- rid of this Ord. instance Outputable AltCon where ppr (DataAlt dc) = ppr dc ppr (LitAlt lit) = ppr lit ppr DEFAULT = text "__DEFAULT" cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2 ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT cmpAltCon :: AltCon -> AltCon -> Ordering -- ^ Compares 'AltCon's within a single list of alternatives -- DEFAULT comes out smallest, so that sorting by AltCon puts -- alternatives in the order required: see Note [Case expression invariants] cmpAltCon DEFAULT DEFAULT = EQ cmpAltCon DEFAULT _ = LT cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2 cmpAltCon (DataAlt _) DEFAULT = GT cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2 cmpAltCon (LitAlt _) DEFAULT = GT cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+> ppr con1 <+> ppr con2 ) LT {- ************************************************************************ * * \subsection{Useful synonyms} * * ************************************************************************ Note [CoreProgram] ~~~~~~~~~~~~~~~~~~ The top level bindings of a program, a CoreProgram, are represented as a list of CoreBind * Later bindings in the list can refer to earlier ones, but not vice versa. So this is OK NonRec { x = 4 } Rec { p = ...q...x... ; q = ...p...x } Rec { f = ...p..x..f.. } NonRec { g = ..f..q...x.. } But it would NOT be ok for 'f' to refer to 'g'. * The occurrence analyser does strongly-connected component analysis on each Rec binding, and splits it into a sequence of smaller bindings where possible. So the program typically starts life as a single giant Rec, which is then dependency-analysed into smaller chunks. -} -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.hs type CoreProgram = [CoreBind] -- See Note [CoreProgram] -- | The common case for the type of binders and variables when -- we are manipulating the Core language within GHC type CoreBndr = Var -- | Expressions where binders are 'CoreBndr's type CoreExpr = Expr CoreBndr -- | Argument expressions where binders are 'CoreBndr's type CoreArg = Arg CoreBndr -- | Binding groups where binders are 'CoreBndr's type CoreBind = Bind CoreBndr -- | Case alternatives where binders are 'CoreBndr's type CoreAlt = Alt CoreBndr {- ************************************************************************ * * \subsection{Tagging} * * ************************************************************************ -} -- | Binders are /tagged/ with a t data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder" type TaggedBind t = Bind (TaggedBndr t) type TaggedExpr t = Expr (TaggedBndr t) type TaggedArg t = Arg (TaggedBndr t) type TaggedAlt t = Alt (TaggedBndr t) instance Outputable b => Outputable (TaggedBndr b) where ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>' deTagExpr :: TaggedExpr t -> CoreExpr deTagExpr (Var v) = Var v deTagExpr (Lit l) = Lit l deTagExpr (Type ty) = Type ty deTagExpr (Coercion co) = Coercion co deTagExpr (App e1 e2) = App (deTagExpr e1) (deTagExpr e2) deTagExpr (Lam (TB b _) e) = Lam b (deTagExpr e) deTagExpr (Let bind body) = Let (deTagBind bind) (deTagExpr body) deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts) deTagExpr (Tick t e) = Tick t (deTagExpr e) deTagExpr (Cast e co) = Cast (deTagExpr e) co deTagBind :: TaggedBind t -> CoreBind deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs) deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs] deTagAlt :: TaggedAlt t -> CoreAlt deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs) {- ************************************************************************ * * \subsection{Core-constructing functions with checking} * * ************************************************************************ -} -- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to -- use 'MkCore.mkCoreApps' if possible mkApps :: Expr b -> [Arg b] -> Expr b -- | Apply a list of type argument expressions to a function expression in a nested fashion mkTyApps :: Expr b -> [Type] -> Expr b -- | Apply a list of coercion argument expressions to a function expression in a nested fashion mkCoApps :: Expr b -> [Coercion] -> Expr b -- | Apply a list of type or value variables to a function expression in a nested fashion mkVarApps :: Expr b -> [Var] -> Expr b -- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to -- use 'MkCore.mkCoreConApps' if possible mkConApp :: DataCon -> [Arg b] -> Expr b mkApps f args = foldl' App f args mkCoApps f args = foldl' (\ e a -> App e (Coercion a)) f args mkVarApps f vars = foldl' (\ e a -> App e (varToCoreExpr a)) f vars mkConApp con args = mkApps (Var (dataConWorkId con)) args mkTyApps f args = foldl' (\ e a -> App e (mkTyArg a)) f args mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b mkConApp2 con tys arg_ids = Var (dataConWorkId con) `mkApps` map Type tys `mkApps` map varToCoreExpr arg_ids mkTyArg :: Type -> Expr b mkTyArg ty | Just co <- isCoercionTy_maybe ty = Coercion co | otherwise = Type ty -- | Create a machine integer literal expression of type @Int#@ from an @Integer@. -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' mkIntLit :: DynFlags -> Integer -> Expr b -- | Create a machine integer literal expression of type @Int#@ from an @Int@. -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' mkIntLitInt :: DynFlags -> Int -> Expr b mkIntLit dflags n = Lit (mkLitInt dflags n) mkIntLitInt dflags n = Lit (mkLitInt dflags (toInteger n)) -- | Create a machine word literal expression of type @Word#@ from an @Integer@. -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' mkWordLit :: DynFlags -> Integer -> Expr b -- | Create a machine word literal expression of type @Word#@ from a @Word@. -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' mkWordLitWord :: DynFlags -> Word -> Expr b mkWordLit dflags w = Lit (mkLitWord dflags w) mkWordLitWord dflags w = Lit (mkLitWord dflags (toInteger w)) mkWord64LitWord64 :: Word64 -> Expr b mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w)) mkInt64LitInt64 :: Int64 -> Expr b mkInt64LitInt64 w = Lit (mkLitInt64 (toInteger w)) -- | Create a machine character literal expression of type @Char#@. -- If you want an expression of type @Char@ use 'MkCore.mkCharExpr' mkCharLit :: Char -> Expr b -- | Create a machine string literal expression of type @Addr#@. -- If you want an expression of type @String@ use 'MkCore.mkStringExpr' mkStringLit :: String -> Expr b mkCharLit c = Lit (mkLitChar c) mkStringLit s = Lit (mkLitString s) -- | Create a machine single precision literal expression of type @Float#@ from a @Rational@. -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' mkFloatLit :: Rational -> Expr b -- | Create a machine single precision literal expression of type @Float#@ from a @Float@. -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' mkFloatLitFloat :: Float -> Expr b mkFloatLit f = Lit (mkLitFloat f) mkFloatLitFloat f = Lit (mkLitFloat (toRational f)) -- | Create a machine double precision literal expression of type @Double#@ from a @Rational@. -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' mkDoubleLit :: Rational -> Expr b -- | Create a machine double precision literal expression of type @Double#@ from a @Double@. -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' mkDoubleLitDouble :: Double -> Expr b mkDoubleLit d = Lit (mkLitDouble d) mkDoubleLitDouble d = Lit (mkLitDouble (toRational d)) -- | Bind all supplied binding groups over an expression in a nested let expression. Assumes -- that the rhs satisfies the let/app invariant. Prefer to use 'MkCore.mkCoreLets' if -- possible, which does guarantee the invariant mkLets :: [Bind b] -> Expr b -> Expr b -- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to -- use 'MkCore.mkCoreLams' if possible mkLams :: [b] -> Expr b -> Expr b mkLams binders body = foldr Lam body binders mkLets binds body = foldr mkLet body binds mkLet :: Bind b -> Expr b -> Expr b -- The desugarer sometimes generates an empty Rec group -- which Lint rejects, so we kill it off right away mkLet (Rec []) body = body mkLet bind body = Let bind body -- | @mkLetNonRec bndr rhs body@ wraps @body@ in a @let@ binding @bndr@. mkLetNonRec :: b -> Expr b -> Expr b -> Expr b mkLetNonRec b rhs body = Let (NonRec b rhs) body -- | @mkLetRec binds body@ wraps @body@ in a @let rec@ with the given set of -- @binds@ if binds is non-empty. mkLetRec :: [(b, Expr b)] -> Expr b -> Expr b mkLetRec [] body = body mkLetRec bs body = Let (Rec bs) body -- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", -- this can only be used to bind something in a non-recursive @let@ expression mkTyBind :: TyVar -> Type -> CoreBind mkTyBind tv ty = NonRec tv (Type ty) -- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", -- this can only be used to bind something in a non-recursive @let@ expression mkCoBind :: CoVar -> Coercion -> CoreBind mkCoBind cv co = NonRec cv (Coercion co) -- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately varToCoreExpr :: CoreBndr -> Expr b varToCoreExpr v | isTyVar v = Type (mkTyVarTy v) | isCoVar v = Coercion (mkCoVarCo v) | otherwise = ASSERT( isId v ) Var v varsToCoreExprs :: [CoreBndr] -> [Expr b] varsToCoreExprs vs = map varToCoreExpr vs {- ************************************************************************ * * Getting a result type * * ************************************************************************ These are defined here to avoid a module loop between CoreUtils and CoreFVs -} applyTypeToArg :: Type -> CoreExpr -> Type -- ^ Determines the type resulting from applying an expression with given type -- to a given argument expression applyTypeToArg fun_ty arg = piResultTy fun_ty (exprToType arg) -- | If the expression is a 'Type', converts. Otherwise, -- panics. NB: This does /not/ convert 'Coercion' to 'CoercionTy'. exprToType :: CoreExpr -> Type exprToType (Type ty) = ty exprToType _bad = pprPanic "exprToType" empty -- | If the expression is a 'Coercion', converts. exprToCoercion_maybe :: CoreExpr -> Maybe Coercion exprToCoercion_maybe (Coercion co) = Just co exprToCoercion_maybe _ = Nothing {- ************************************************************************ * * \subsection{Simple access functions} * * ************************************************************************ -} -- | Extract every variable by this group bindersOf :: Bind b -> [b] -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.hs bindersOf (NonRec binder _) = [binder] bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] -- | 'bindersOf' applied to a list of binding groups bindersOfBinds :: [Bind b] -> [b] bindersOfBinds binds = foldr ((++) . bindersOf) [] binds rhssOfBind :: Bind b -> [Expr b] rhssOfBind (NonRec _ rhs) = [rhs] rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] rhssOfAlts :: [Alt b] -> [Expr b] rhssOfAlts alts = [e | (_,_,e) <- alts] -- | Collapse all the bindings in the supplied groups into a single -- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group flattenBinds :: [Bind b] -> [(b, Expr b)] flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds flattenBinds [] = [] -- | We often want to strip off leading lambdas before getting down to -- business. Variants are 'collectTyBinders', 'collectValBinders', -- and 'collectTyAndValBinders' collectBinders :: Expr b -> ([b], Expr b) collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) collectValBinders :: CoreExpr -> ([Id], CoreExpr) collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) -- | Strip off exactly N leading lambdas (type or value). Good for use with -- join points. collectNBinders :: Int -> Expr b -> ([b], Expr b) collectBinders expr = go [] expr where go bs (Lam b e) = go (b:bs) e go bs e = (reverse bs, e) collectTyBinders expr = go [] expr where go tvs (Lam b e) | isTyVar b = go (b:tvs) e go tvs e = (reverse tvs, e) collectValBinders expr = go [] expr where go ids (Lam b e) | isId b = go (b:ids) e go ids body = (reverse ids, body) collectTyAndValBinders expr = (tvs, ids, body) where (tvs, body1) = collectTyBinders expr (ids, body) = collectValBinders body1 collectNBinders orig_n orig_expr = go orig_n [] orig_expr where go 0 bs expr = (reverse bs, expr) go n bs (Lam b e) = go (n-1) (b:bs) e go _ _ _ = pprPanic "collectNBinders" $ int orig_n -- | Takes a nested application expression and returns the function -- being applied and the arguments to which it is applied collectArgs :: Expr b -> (Expr b, [Arg b]) collectArgs expr = go expr [] where go (App f a) as = go f (a:as) go e as = (e, as) -- | Attempt to remove the last N arguments of a function call. -- Strip off any ticks or coercions encountered along the way and any -- at the end. stripNArgs :: Word -> Expr a -> Maybe (Expr a) stripNArgs !n (Tick _ e) = stripNArgs n e stripNArgs n (Cast f _) = stripNArgs n f stripNArgs 0 e = Just e stripNArgs n (App f _) = stripNArgs (n - 1) f stripNArgs _ _ = Nothing -- | Like @collectArgs@, but also collects looks through floatable -- ticks if it means that we can find more arguments. collectArgsTicks :: (Tickish Id -> Bool) -> Expr b -> (Expr b, [Arg b], [Tickish Id]) collectArgsTicks skipTick expr = go expr [] [] where go (App f a) as ts = go f (a:as) ts go (Tick t e) as ts | skipTick t = go e as (t:ts) go e as ts = (e, as, reverse ts) {- ************************************************************************ * * \subsection{Predicates} * * ************************************************************************ At one time we optionally carried type arguments through to runtime. @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime, i.e. if type applications are actual lambdas because types are kept around at runtime. Similarly isRuntimeArg. -} -- | Will this variable exist at runtime? isRuntimeVar :: Var -> Bool isRuntimeVar = isId -- | Will this argument expression exist at runtime? isRuntimeArg :: CoreExpr -> Bool isRuntimeArg = isValArg -- | Returns @True@ for value arguments, false for type args -- NB: coercions are value arguments (zero width, to be sure, -- like State#, but still value args). isValArg :: Expr b -> Bool isValArg e = not (isTypeArg e) -- | Returns @True@ iff the expression is a 'Type' or 'Coercion' -- expression at its top level isTyCoArg :: Expr b -> Bool isTyCoArg (Type {}) = True isTyCoArg (Coercion {}) = True isTyCoArg _ = False -- | Returns @True@ iff the expression is a 'Coercion' -- expression at its top level isCoArg :: Expr b -> Bool isCoArg (Coercion {}) = True isCoArg _ = False -- | Returns @True@ iff the expression is a 'Type' expression at its -- top level. Note this does NOT include 'Coercion's. isTypeArg :: Expr b -> Bool isTypeArg (Type {}) = True isTypeArg _ = False -- | The number of binders that bind values rather than types valBndrCount :: [CoreBndr] -> Int valBndrCount = count isId -- | The number of argument expressions that are values rather than types at their top level valArgCount :: [Arg b] -> Int valArgCount = count isValArg {- ************************************************************************ * * \subsection{Annotated core} * * ************************************************************************ -} -- | Annotated core: allows annotation at every node in the tree type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) -- | A clone of the 'Expr' type but allowing annotation at every tree node data AnnExpr' bndr annot = AnnVar Id | AnnLit Literal | AnnLam bndr (AnnExpr bndr annot) | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot] | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) | AnnCast (AnnExpr bndr annot) (annot, Coercion) -- Put an annotation on the (root of) the coercion | AnnTick (Tickish Id) (AnnExpr bndr annot) | AnnType Type | AnnCoercion Coercion -- | A clone of the 'Alt' type but allowing annotation at every tree node type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot) -- | A clone of the 'Bind' type but allowing annotation at every tree node data AnnBind bndr annot = AnnNonRec bndr (AnnExpr bndr annot) | AnnRec [(bndr, AnnExpr bndr annot)] -- | Takes a nested application expression and returns the function -- being applied and the arguments to which it is applied collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a]) collectAnnArgs expr = go expr [] where go (_, AnnApp f a) as = go f (a:as) go e as = (e, as) collectAnnArgsTicks :: (Tickish Var -> Bool) -> AnnExpr b a -> (AnnExpr b a, [AnnExpr b a], [Tickish Var]) collectAnnArgsTicks tickishOk expr = go expr [] [] where go (_, AnnApp f a) as ts = go f (a:as) ts go (_, AnnTick t e) as ts | tickishOk t = go e as (t:ts) go e as ts = (e, as, reverse ts) deAnnotate :: AnnExpr bndr annot -> Expr bndr deAnnotate (_, e) = deAnnotate' e deAnnotate' :: AnnExpr' bndr annot -> Expr bndr deAnnotate' (AnnType t) = Type t deAnnotate' (AnnCoercion co) = Coercion co deAnnotate' (AnnVar v) = Var v deAnnotate' (AnnLit lit) = Lit lit deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body) deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co deAnnotate' (AnnTick tick body) = Tick tick (deAnnotate body) deAnnotate' (AnnLet bind body) = Let (deAnnBind bind) (deAnnotate body) deAnnotate' (AnnCase scrut v t alts) = Case (deAnnotate scrut) v t (map deAnnAlt alts) deAnnAlt :: AnnAlt bndr annot -> Alt bndr deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) deAnnBind :: AnnBind b annot -> Bind b deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] -- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr' collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) collectAnnBndrs e = collect [] e where collect bs (_, AnnLam b body) = collect (b:bs) body collect bs body = (reverse bs, body) -- | As 'collectNBinders' but for 'AnnExpr' rather than 'Expr' collectNAnnBndrs :: Int -> AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) collectNAnnBndrs orig_n e = collect orig_n [] e where collect 0 bs body = (reverse bs, body) collect n bs (_, AnnLam b body) = collect (n-1) (b:bs) body collect _ _ _ = pprPanic "collectNBinders" $ int orig_n ghc-lib-parser-8.10.2.20200808/compiler/coreSyn/CoreTidy.hs0000644000000000000000000002444113713635744021025 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1996-1998 This module contains "tidying" code for *nested* expressions, bindings, rules. The code for *top-level* bindings is in TidyPgm. -} {-# LANGUAGE CPP #-} module CoreTidy ( tidyExpr, tidyRules, tidyUnfolding ) where #include "GhclibHsVersions.h" import GhcPrelude import CoreSyn import CoreSeq ( seqUnfolding ) import Id import IdInfo import Demand ( zapUsageEnvSig ) import Type( tidyType, tidyVarBndr ) import Coercion( tidyCo ) import Var import VarEnv import UniqFM import Name hiding (tidyNameOcc) import SrcLoc import Maybes import Data.List {- ************************************************************************ * * \subsection{Tidying expressions, rules} * * ************************************************************************ -} tidyBind :: TidyEnv -> CoreBind -> (TidyEnv, CoreBind) tidyBind env (NonRec bndr rhs) = tidyLetBndr env env bndr =: \ (env', bndr') -> (env', NonRec bndr' (tidyExpr env' rhs)) tidyBind env (Rec prs) = let (bndrs, rhss) = unzip prs (env', bndrs') = mapAccumL (tidyLetBndr env') env bndrs in map (tidyExpr env') rhss =: \ rhss' -> (env', Rec (zip bndrs' rhss')) ------------ Expressions -------------- tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr tidyExpr env (Var v) = Var (tidyVarOcc env v) tidyExpr env (Type ty) = Type (tidyType env ty) tidyExpr env (Coercion co) = Coercion (tidyCo env co) tidyExpr _ (Lit lit) = Lit lit tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a) tidyExpr env (Tick t e) = Tick (tidyTickish env t) (tidyExpr env e) tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyCo env co) tidyExpr env (Let b e) = tidyBind env b =: \ (env', b') -> Let b' (tidyExpr env' e) tidyExpr env (Case e b ty alts) = tidyBndr env b =: \ (env', b) -> Case (tidyExpr env e) b (tidyType env ty) (map (tidyAlt env') alts) tidyExpr env (Lam b e) = tidyBndr env b =: \ (env', b) -> Lam b (tidyExpr env' e) ------------ Case alternatives -------------- tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt tidyAlt env (con, vs, rhs) = tidyBndrs env vs =: \ (env', vs) -> (con, vs, tidyExpr env' rhs) ------------ Tickish -------------- tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id tidyTickish env (Breakpoint ix ids) = Breakpoint ix (map (tidyVarOcc env) ids) tidyTickish _ other_tickish = other_tickish ------------ Rules -------------- tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule] tidyRules _ [] = [] tidyRules env (rule : rules) = tidyRule env rule =: \ rule -> tidyRules env rules =: \ rules -> (rule : rules) tidyRule :: TidyEnv -> CoreRule -> CoreRule tidyRule _ rule@(BuiltinRule {}) = rule tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs, ru_fn = fn, ru_rough = mb_ns }) = tidyBndrs env bndrs =: \ (env', bndrs) -> map (tidyExpr env') args =: \ args -> rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = tidyExpr env' rhs, ru_fn = tidyNameOcc env fn, ru_rough = map (fmap (tidyNameOcc env')) mb_ns } {- ************************************************************************ * * \subsection{Tidying non-top-level binders} * * ************************************************************************ -} tidyNameOcc :: TidyEnv -> Name -> Name -- In rules and instances, we have Names, and we must tidy them too -- Fortunately, we can lookup in the VarEnv with a name tidyNameOcc (_, var_env) n = case lookupUFM var_env n of Nothing -> n Just v -> idName v tidyVarOcc :: TidyEnv -> Var -> Var tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v -- tidyBndr is used for lambda and case binders tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) tidyBndr env var | isTyCoVar var = tidyVarBndr env var | otherwise = tidyIdBndr env var tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) tidyBndrs env vars = mapAccumL tidyBndr env vars -- Non-top-level variables, not covars tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) tidyIdBndr env@(tidy_env, var_env) id = -- Do this pattern match strictly, otherwise we end up holding on to -- stuff in the OccName. case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> let -- Give the Id a fresh print-name, *and* rename its type -- The SrcLoc isn't important now, -- though we could extract it from the Id -- ty' = tidyType env (idType id) name' = mkInternalName (idUnique id) occ' noSrcSpan id' = mkLocalIdWithInfo name' ty' new_info var_env' = extendVarEnv var_env id id' -- Note [Tidy IdInfo] new_info = vanillaIdInfo `setOccInfo` occInfo old_info `setUnfoldingInfo` new_unf -- see Note [Preserve OneShotInfo] `setOneShotInfo` oneShotInfo old_info old_info = idInfo id old_unf = unfoldingInfo old_info new_unf = zapUnfolding old_unf -- See Note [Preserve evaluatedness] in ((tidy_env', var_env'), id') } tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings -> TidyEnv -- The one to extend -> Id -> (TidyEnv, Id) -- Used for local (non-top-level) let(rec)s -- Just like tidyIdBndr above, but with more IdInfo tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> let ty' = tidyType env (idType id) name' = mkInternalName (idUnique id) occ' noSrcSpan details = idDetails id id' = mkLocalVar details name' ty' new_info var_env' = extendVarEnv var_env id id' -- Note [Tidy IdInfo] -- We need to keep around any interesting strictness and -- demand info because later on we may need to use it when -- converting to A-normal form. -- eg. -- f (g x), where f is strict in its argument, will be converted -- into case (g x) of z -> f z by CorePrep, but only if f still -- has its strictness info. -- -- Similarly for the demand info - on a let binder, this tells -- CorePrep to turn the let into a case. -- But: Remove the usage demand here -- (See Note [Zapping DmdEnv after Demand Analyzer] in WorkWrap) -- -- Similarly arity info for eta expansion in CorePrep -- Don't attempt to recompute arity here; this is just tidying! -- Trying to do so led to #17294 -- -- Set inline-prag info so that we preseve it across -- separate compilation boundaries old_info = idInfo id new_info = vanillaIdInfo `setOccInfo` occInfo old_info `setArityInfo` arityInfo old_info `setStrictnessInfo` zapUsageEnvSig (strictnessInfo old_info) `setDemandInfo` demandInfo old_info `setInlinePragInfo` inlinePragInfo old_info `setUnfoldingInfo` new_unf old_unf = unfoldingInfo old_info new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf | otherwise = zapUnfolding old_unf -- See Note [Preserve evaluatedness] in ((tidy_env', var_env'), id') } ------------ Unfolding -------------- tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _ = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args } where (tidy_env', bndrs') = tidyBndrs tidy_env bndrs tidyUnfolding tidy_env unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) unf_from_rhs | isStableSource src = seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo -- This seqIt avoids a space leak: otherwise the uf_is_value, -- uf_is_conlike, ... fields may retain a reference to the -- pre-tidied expression forever (ToIface doesn't look at them) | otherwise = unf_from_rhs where seqIt unf = seqUnfolding unf `seq` unf tidyUnfolding _ unf _ = unf -- NoUnfolding or OtherCon {- Note [Tidy IdInfo] ~~~~~~~~~~~~~~~~~~ All nested Ids now have the same IdInfo, namely vanillaIdInfo, which should save some space; except that we preserve occurrence info for two reasons: (a) To make printing tidy core nicer (b) Because we tidy RULES and InlineRules, which may then propagate via --make into the compilation of the next module, and we want the benefit of that occurrence analysis when we use the rule or or inline the function. In particular, it's vital not to lose loop-breaker info, else we get an infinite inlining loop Note that tidyLetBndr puts more IdInfo back. Note [Preserve evaluatedness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T = MkT !Bool ....(case v of MkT y -> let z# = case y of True -> 1# False -> 2# in ...) The z# binding is ok because the RHS is ok-for-speculation, but Lint will complain unless it can *see* that. So we preserve the evaluated-ness on 'y' in tidyBndr. (Another alternative would be to tidy unboxed lets into cases, but that seems more indirect and surprising.) Note [Preserve OneShotInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ We keep the OneShotInfo because we want it to propagate into the interface. Not all OneShotInfo is determined by a compiler analysis; some is added by a call of GHC.Exts.oneShot, which is then discarded before the end of the optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we must preserve this info in inlinings. See Note [The oneShot function] in MkId. This applies to lambda binders only, hence it is stored in IfaceLamBndr. -} (=:) :: a -> (a -> b) -> b m =: k = m `seq` k m ghc-lib-parser-8.10.2.20200808/compiler/coreSyn/CoreUnfold.hs0000644000000000000000000020603513713635744021344 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1994-1998 Core-syntax unfoldings Unfoldings (which can travel across module boundaries) are in Core syntax (namely @CoreExpr@s). The type @Unfolding@ sits ``above'' simply-Core-expressions unfoldings, capturing ``higher-level'' things we know about a binding, usually things that the simplifier found out (e.g., ``it's a literal''). In the corner of a @CoreUnfolding@ unfolding, you will find, unsurprisingly, a Core expression. -} {-# LANGUAGE CPP #-} module CoreUnfold ( Unfolding, UnfoldingGuidance, -- Abstract types noUnfolding, mkImplicitUnfolding, mkUnfolding, mkCoreUnfolding, mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding, mkInlineUnfolding, mkInlineUnfoldingWithArity, mkInlinableUnfolding, mkWwInlineRule, mkCompulsoryUnfolding, mkDFunUnfolding, specUnfolding, ArgSummary(..), couldBeSmallEnoughToInline, inlineBoringOk, certainlyWillInline, smallEnoughToInline, callSiteInline, CallCtxt(..), -- Reexport from CoreSubst (it only live there so it can be used -- by the Very Simple Optimiser) exprIsConApp_maybe, exprIsLiteral_maybe ) where #include "GhclibHsVersions.h" import GhcPrelude import DynFlags import CoreSyn import OccurAnal ( occurAnalyseExpr_NoBinderSwap ) import CoreOpt import CoreArity ( manifestArity ) import CoreUtils import Id import Demand ( isBottomingSig ) import DataCon import Literal import PrimOp import IdInfo import BasicTypes ( Arity, InlineSpec(..), inlinePragmaSpec ) import Type import PrelNames import TysPrim ( realWorldStatePrimTy ) import Bag import Util import Outputable import ForeignCall import Name import qualified Data.ByteString as BS import Data.List {- ************************************************************************ * * \subsection{Making unfoldings} * * ************************************************************************ -} mkTopUnfolding :: DynFlags -> Bool -> CoreExpr -> Unfolding mkTopUnfolding dflags is_bottoming rhs = mkUnfolding dflags InlineRhs True is_bottoming rhs mkImplicitUnfolding :: DynFlags -> CoreExpr -> Unfolding -- For implicit Ids, do a tiny bit of optimising first mkImplicitUnfolding dflags expr = mkTopUnfolding dflags False (simpleOptExpr dflags expr) -- Note [Top-level flag on inline rules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Slight hack: note that mk_inline_rules conservatively sets the -- top-level flag to True. It gets set more accurately by the simplifier -- Simplify.simplUnfolding. mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding mkSimpleUnfolding dflags rhs = mkUnfolding dflags InlineRhs False False rhs mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding mkDFunUnfolding bndrs con ops = DFunUnfolding { df_bndrs = bndrs , df_con = con , df_args = map occurAnalyseExpr_NoBinderSwap ops } -- See Note [Occurrence analysis of unfoldings] mkWwInlineRule :: DynFlags -> CoreExpr -> Arity -> Unfolding mkWwInlineRule dflags expr arity = mkCoreUnfolding InlineStable True (simpleOptExpr dflags expr) (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk , ug_boring_ok = boringCxtNotOk }) mkCompulsoryUnfolding :: CoreExpr -> Unfolding mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded = mkCoreUnfolding InlineCompulsory True (simpleOptExpr unsafeGlobalDynFlags expr) (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding -- See Note [Worker-wrapper for INLINABLE functions] in WorkWrap mkWorkerUnfolding dflags work_fn (CoreUnfolding { uf_src = src, uf_tmpl = tmpl , uf_is_top = top_lvl }) | isStableSource src = mkCoreUnfolding src top_lvl new_tmpl guidance where new_tmpl = simpleOptExpr dflags (work_fn tmpl) guidance = calcUnfoldingGuidance dflags False new_tmpl mkWorkerUnfolding _ _ _ = noUnfolding -- | Make an unfolding that may be used unsaturated -- (ug_unsat_ok = unSaturatedOk) and that is reported as having its -- manifest arity (the number of outer lambdas applications will -- resolve before doing any work). mkInlineUnfolding :: CoreExpr -> Unfolding mkInlineUnfolding expr = mkCoreUnfolding InlineStable True -- Note [Top-level flag on inline rules] expr' guide where expr' = simpleOptExpr unsafeGlobalDynFlags expr guide = UnfWhen { ug_arity = manifestArity expr' , ug_unsat_ok = unSaturatedOk , ug_boring_ok = boring_ok } boring_ok = inlineBoringOk expr' -- | Make an unfolding that will be used once the RHS has been saturated -- to the given arity. mkInlineUnfoldingWithArity :: Arity -> CoreExpr -> Unfolding mkInlineUnfoldingWithArity arity expr = mkCoreUnfolding InlineStable True -- Note [Top-level flag on inline rules] expr' guide where expr' = simpleOptExpr unsafeGlobalDynFlags expr guide = UnfWhen { ug_arity = arity , ug_unsat_ok = needSaturated , ug_boring_ok = boring_ok } -- See Note [INLINE pragmas and boring contexts] as to why we need to look -- at the arity here. boring_ok | arity == 0 = True | otherwise = inlineBoringOk expr' mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding mkInlinableUnfolding dflags expr = mkUnfolding dflags InlineStable False False expr' where expr' = simpleOptExpr dflags expr specUnfolding :: DynFlags -> [Var] -> (CoreExpr -> CoreExpr) -> [CoreArg] -- LHS arguments in the RULE -> Unfolding -> Unfolding -- See Note [Specialising unfoldings] -- specUnfolding spec_bndrs spec_args unf -- = \spec_bndrs. unf spec_args -- specUnfolding dflags spec_bndrs spec_app rule_lhs_args df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args }) = ASSERT2( rule_lhs_args `equalLength` old_bndrs , ppr df $$ ppr rule_lhs_args ) -- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise mkDFunUnfolding spec_bndrs con (map spec_arg args) -- For DFunUnfoldings we transform -- \obs. MkD ... -- to -- \sbs. MkD ((\obs. ) spec_args) ... ditto where spec_arg arg = simpleOptExpr dflags $ spec_app (mkLams old_bndrs arg) -- The beta-redexes created by spec_app will be -- simplified away by simplOptExpr specUnfolding dflags spec_bndrs spec_app rule_lhs_args (CoreUnfolding { uf_src = src, uf_tmpl = tmpl , uf_is_top = top_lvl , uf_guidance = old_guidance }) | isStableSource src -- See Note [Specialising unfoldings] , UnfWhen { ug_arity = old_arity } <- old_guidance = mkCoreUnfolding src top_lvl new_tmpl (old_guidance { ug_arity = old_arity - arity_decrease }) where new_tmpl = simpleOptExpr dflags $ mkLams spec_bndrs $ spec_app tmpl -- The beta-redexes created by spec_app -- will besimplified away by simplOptExpr arity_decrease = count isValArg rule_lhs_args - count isId spec_bndrs specUnfolding _ _ _ _ _ = noUnfolding {- Note [Specialising unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we specialise a function for some given type-class arguments, we use specUnfolding to specialise its unfolding. Some important points: * If the original function has a DFunUnfolding, the specialised one must do so too! Otherwise we lose the magic rules that make it interact with ClassOps * There is a bit of hack for INLINABLE functions: f :: Ord a => .... f = {- INLINABLE f #-} Now if we specialise f, should the specialised version still have an INLINABLE pragma? If it does, we'll capture a specialised copy of as its unfolding, and that probaby won't inline. But if we don't, the specialised version of might be small enough to inline at a call site. This happens with Control.Monad.liftM3, and can cause a lot more allocation as a result (nofib n-body shows this). Moreover, keeping the INLINABLE thing isn't much help, because the specialised function (probaby) isn't overloaded any more. Conclusion: drop the INLINEALE pragma. In practice what this means is: if a stable unfolding has UnfoldingGuidance of UnfWhen, we keep it (so the specialised thing too will always inline) if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs (which arises from INLINABLE), we discard it Note [Honour INLINE on 0-ary bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider x = {-# INLINE x #-} f y = ...x... The semantics of an INLINE pragma is inline x at every call site, provided it is saturated; that is, applied to at least as many arguments as appear on the LHS of the Haskell source definition. (This soure-code-derived arity is stored in the `ug_arity` field of the `UnfoldingGuidance`.) In the example, x's ug_arity is 0, so we should inline it at every use site. It's rare to have such an INLINE pragma (usually INLINE Is on functions), but it's occasionally very important (#15578, #15519). In #15519 we had something like x = case (g a b) of I# r -> T r {-# INLINE x #-} f y = ...(h x).... where h is strict. So we got f y = ...(case g a b of I# r -> h (T r))... and that in turn allowed SpecConstr to ramp up performance. How do we deliver on this? By adjusting the ug_boring_ok flag in mkInlineUnfoldingWithArity; see Note [INLINE pragmas and boring contexts] NB: there is a real risk that full laziness will float it right back out again. Consider again x = factorial 200 {-# INLINE x #-} f y = ...x... After inlining we get f y = ...(factorial 200)... but it's entirely possible that full laziness will do lvl23 = factorial 200 f y = ...lvl23... That's a problem for another day. Note [INLINE pragmas and boring contexts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An INLINE pragma uses mkInlineUnfoldingWithArity to build the unfolding. That sets the ug_boring_ok flag to False if the function is not tiny (inlineBoringOK), so that even INLINE functions are not inlined in an utterly boring context. E.g. \x y. Just (f y x) Nothing is gained by inlining f here, even if it has an INLINE pragma. But for 0-ary bindings, we want to inline regardless; see Note [Honour INLINE on 0-ary bindings]. I'm a bit worried that it's possible for the same kind of problem to arise for non-0-ary functions too, but let's wait and see. -} mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr -> UnfoldingGuidance -> Unfolding -- Occurrence-analyses the expression before capturing it mkCoreUnfolding src top_lvl expr guidance = CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr, -- See Note [Occurrence analysis of unfoldings] uf_src = src, uf_is_top = top_lvl, uf_is_value = exprIsHNF expr, uf_is_conlike = exprIsConLike expr, uf_is_work_free = exprIsWorkFree expr, uf_expandable = exprIsExpandable expr, uf_guidance = guidance } mkUnfolding :: DynFlags -> UnfoldingSource -> Bool -- Is top-level -> Bool -- Definitely a bottoming binding -- (only relevant for top-level bindings) -> CoreExpr -> Unfolding -- Calculates unfolding guidance -- Occurrence-analyses the expression before capturing it mkUnfolding dflags src is_top_lvl is_bottoming expr = CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr, -- See Note [Occurrence analysis of unfoldings] uf_src = src, uf_is_top = is_top_lvl, uf_is_value = exprIsHNF expr, uf_is_conlike = exprIsConLike expr, uf_expandable = exprIsExpandable expr, uf_is_work_free = exprIsWorkFree expr, uf_guidance = guidance } where is_top_bottoming = is_top_lvl && is_bottoming guidance = calcUnfoldingGuidance dflags is_top_bottoming expr -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr_NoBinderSwap expr))! -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] {- Note [Occurrence analysis of unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We do occurrence-analysis of unfoldings once and for all, when the unfolding is built, rather than each time we inline them. But given this decision it's vital that we do *always* do it. Consider this unfolding \x -> letrec { f = ...g...; g* = f } in body where g* is (for some strange reason) the loop breaker. If we don't occ-anal it when reading it in, we won't mark g as a loop breaker, and we may inline g entirely in body, dropping its binding, and leaving the occurrence in f out of scope. This happened in #8892, where the unfolding in question was a DFun unfolding. But more generally, the simplifier is designed on the basis that it is looking at occurrence-analysed expressions, so better ensure that they acutally are. We use occurAnalyseExpr_NoBinderSwap instead of occurAnalyseExpr; see Note [No binder swap in unfoldings]. Note [No binder swap in unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The binder swap can temporarily violate Core Lint, by assinging a LocalId binding to a GlobalId. For example, if A.foo{r872} is a GlobalId with unique r872, then case A.foo{r872} of bar { K x -> ...(A.foo{r872})... } gets transformed to case A.foo{r872} of bar { K x -> let foo{r872} = bar in ...(A.foo{r872})... This is usually not a problem, because the simplifier will transform this to: case A.foo{r872} of bar { K x -> ...(bar)... However, after occurrence analysis but before simplification, this extra 'let' violates the Core Lint invariant that we do not have local 'let' bindings for GlobalIds. That seems (just) tolerable for the occurrence analysis that happens just before the Simplifier, but not for unfoldings, which are Linted independently. As a quick workaround, we disable binder swap in this module. See #16288 and #16296 for further plans. Note [Calculate unfolding guidance on the non-occ-anal'd expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Notice that we give the non-occur-analysed expression to calcUnfoldingGuidance. In some ways it'd be better to occur-analyse first; for example, sometimes during simplification, there's a large let-bound thing which has been substituted, and so is now dead; so 'expr' contains two copies of the thing while the occurrence-analysed expression doesn't. Nevertheless, we *don't* and *must not* occ-analyse before computing the size because a) The size computation bales out after a while, whereas occurrence analysis does not. b) Residency increases sharply if you occ-anal first. I'm not 100% sure why, but it's a large effect. Compiling Cabal went from residency of 534M to over 800M with this one change. This can occasionally mean that the guidance is very pessimistic; it gets fixed up next round. And it should be rare, because large let-bound things that are dead are usually caught by preInlineUnconditionally ************************************************************************ * * \subsection{The UnfoldingGuidance type} * * ************************************************************************ -} inlineBoringOk :: CoreExpr -> Bool -- See Note [INLINE for small functions] -- True => the result of inlining the expression is -- no bigger than the expression itself -- eg (\x y -> f y x) -- This is a quick and dirty version. It doesn't attempt -- to deal with (\x y z -> x (y z)) -- The really important one is (x `cast` c) inlineBoringOk e = go 0 e where go :: Int -> CoreExpr -> Bool go credit (Lam x e) | isId x = go (credit+1) e | otherwise = go credit e -- See Note [Count coercion arguments in boring contexts] go credit (App f (Type {})) = go credit f go credit (App f a) | credit > 0 , exprIsTrivial a = go (credit-1) f go credit (Tick _ e) = go credit e -- dubious go credit (Cast e _) = go credit e go _ (Var {}) = boringCxtOk go _ _ = boringCxtNotOk calcUnfoldingGuidance :: DynFlags -> Bool -- Definitely a top-level, bottoming binding -> CoreExpr -- Expression to look at -> UnfoldingGuidance calcUnfoldingGuidance dflags is_top_bottoming (Tick t expr) | not (tickishIsCode t) -- non-code ticks don't matter for unfolding = calcUnfoldingGuidance dflags is_top_bottoming expr calcUnfoldingGuidance dflags is_top_bottoming expr = case sizeExpr dflags bOMB_OUT_SIZE val_bndrs body of TooBig -> UnfNever SizeIs size cased_bndrs scrut_discount | uncondInline expr n_val_bndrs size -> UnfWhen { ug_unsat_ok = unSaturatedOk , ug_boring_ok = boringCxtOk , ug_arity = n_val_bndrs } -- Note [INLINE for small functions] | is_top_bottoming -> UnfNever -- See Note [Do not inline top-level bottoming functions] | otherwise -> UnfIfGoodArgs { ug_args = map (mk_discount cased_bndrs) val_bndrs , ug_size = size , ug_res = scrut_discount } where (bndrs, body) = collectBinders expr bOMB_OUT_SIZE = ufCreationThreshold dflags -- Bomb out if size gets bigger than this val_bndrs = filter isId bndrs n_val_bndrs = length val_bndrs mk_discount :: Bag (Id,Int) -> Id -> Int mk_discount cbs bndr = foldl' combine 0 cbs where combine acc (bndr', disc) | bndr == bndr' = acc `plus_disc` disc | otherwise = acc plus_disc :: Int -> Int -> Int plus_disc | isFunTy (idType bndr) = max | otherwise = (+) -- See Note [Function and non-function discounts] {- Note [Computing the size of an expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The basic idea of sizeExpr is obvious enough: count nodes. But getting the heuristics right has taken a long time. Here's the basic strategy: * Variables, literals: 0 (Exception for string literals, see litSize.) * Function applications (f e1 .. en): 1 + #value args * Constructor applications: 1, regardless of #args * Let(rec): 1 + size of components * Note, cast: 0 Examples Size Term -------------- 0 42# 0 x 0 True 2 f x 1 Just x 4 f (g x) Notice that 'x' counts 0, while (f x) counts 2. That's deliberate: there's a function call to account for. Notice also that constructor applications are very cheap, because exposing them to a caller is so valuable. [25/5/11] All sizes are now multiplied by 10, except for primops (which have sizes like 1 or 4. This makes primops look fantastically cheap, and seems to be almost unversally beneficial. Done partly as a result of #4978. Note [Do not inline top-level bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The FloatOut pass has gone to some trouble to float out calls to 'error' and similar friends. See Note [Bottoming floats] in SetLevels. Do not re-inline them! But we *do* still inline if they are very small (the uncondInline stuff). Note [INLINE for small functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider {-# INLINE f #-} f x = Just x g y = f y Then f's RHS is no larger than its LHS, so we should inline it into even the most boring context. In general, f the function is sufficiently small that its body is as small as the call itself, the inline unconditionally, regardless of how boring the context is. Things to note: (1) We inline *unconditionally* if inlined thing is smaller (using sizeExpr) than the thing it's replacing. Notice that (f x) --> (g 3) -- YES, unconditionally (f x) --> x : [] -- YES, *even though* there are two -- arguments to the cons x --> g 3 -- NO x --> Just v -- NO It's very important not to unconditionally replace a variable by a non-atomic term. (2) We do this even if the thing isn't saturated, else we end up with the silly situation that f x y = x ...map (f 3)... doesn't inline. Even in a boring context, inlining without being saturated will give a lambda instead of a PAP, and will be more efficient at runtime. (3) However, when the function's arity > 0, we do insist that it has at least one value argument at the call site. (This check is made in the UnfWhen case of callSiteInline.) Otherwise we find this: f = /\a \x:a. x d = /\b. MkD (f b) If we inline f here we get d = /\b. MkD (\x:b. x) and then prepareRhs floats out the argument, abstracting the type variables, so we end up with the original again! (4) We must be much more cautious about arity-zero things. Consider let x = y +# z in ... In *size* terms primops look very small, because the generate a single instruction, but we do not want to unconditionally replace every occurrence of x with (y +# z). So we only do the unconditional-inline thing for *trivial* expressions. NB: you might think that PostInlineUnconditionally would do this but it doesn't fire for top-level things; see SimplUtils Note [Top level and postInlineUnconditionally] Note [Count coercion arguments in boring contexts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In inlineBoringOK, we ignore type arguments when deciding whether an expression is okay to inline into boring contexts. This is good, since if we have a definition like let y = x @Int in f y y there’s no reason not to inline y at both use sites — no work is actually duplicated. It may seem like the same reasoning applies to coercion arguments, and indeed, in #17182 we changed inlineBoringOK to treat coercions the same way. However, this isn’t a good idea: unlike type arguments, which have no runtime representation, coercion arguments *do* have a runtime representation (albeit the zero-width VoidRep, see Note [Coercion tokens] in CoreToStg.hs). This caused trouble in #17787 for DataCon wrappers for nullary GADT constructors: the wrappers would be inlined and each use of the constructor would lead to a separate allocation instead of just sharing the wrapper closure. The solution: don’t ignore coercion arguments after all. -} uncondInline :: CoreExpr -> Arity -> Int -> Bool -- Inline unconditionally if there no size increase -- Size of call is arity (+1 for the function) -- See Note [INLINE for small functions] uncondInline rhs arity size | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1) | otherwise = exprIsTrivial rhs -- See Note [INLINE for small functions] (4) sizeExpr :: DynFlags -> Int -- Bomb out if it gets bigger than this -> [Id] -- Arguments; we're interested in which of these -- get case'd -> CoreExpr -> ExprSize -- Note [Computing the size of an expression] sizeExpr dflags bOMB_OUT_SIZE top_args expr = size_up expr where size_up (Cast e _) = size_up e size_up (Tick _ e) = size_up e size_up (Type _) = sizeZero -- Types cost nothing size_up (Coercion _) = sizeZero size_up (Lit lit) = sizeN (litSize lit) size_up (Var f) | isRealWorldId f = sizeZero -- Make sure we get constructor discounts even -- on nullary constructors | otherwise = size_up_call f [] 0 size_up (App fun arg) | isTyCoArg arg = size_up fun | otherwise = size_up arg `addSizeNSD` size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0) size_up (Lam b e) | isId b && not (isRealWorldId b) = lamScrutDiscount dflags (size_up e `addSizeN` 10) | otherwise = size_up e size_up (Let (NonRec binder rhs) body) = size_up_rhs (binder, rhs) `addSizeNSD` size_up body `addSizeN` size_up_alloc binder size_up (Let (Rec pairs) body) = foldr (addSizeNSD . size_up_rhs) (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs)) pairs size_up (Case e _ _ alts) | null alts = size_up e -- case e of {} never returns, so take size of scrutinee size_up (Case e _ _ alts) -- Now alts is non-empty | Just v <- is_top_arg e -- We are scrutinising an argument variable = let alt_sizes = map size_up_alt alts -- alts_size tries to compute a good discount for -- the case when we are scrutinising an argument variable alts_size (SizeIs tot tot_disc tot_scrut) -- Size of all alternatives (SizeIs max _ _) -- Size of biggest alternative = SizeIs tot (unitBag (v, 20 + tot - max) `unionBags` tot_disc) tot_scrut -- If the variable is known, we produce a -- discount that will take us back to 'max', -- the size of the largest alternative The -- 1+ is a little discount for reduced -- allocation in the caller -- -- Notice though, that we return tot_disc, -- the total discount from all branches. I -- think that's right. alts_size tot_size _ = tot_size in alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty (foldr1 maxSize alt_sizes) -- Good to inline if an arg is scrutinised, because -- that may eliminate allocation in the caller -- And it eliminates the case itself where is_top_arg (Var v) | v `elem` top_args = Just v is_top_arg (Cast e _) = is_top_arg e is_top_arg _ = Nothing size_up (Case e _ _ alts) = size_up e `addSizeNSD` foldr (addAltSize . size_up_alt) case_size alts where case_size | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10) | otherwise = sizeZero -- Normally we don't charge for the case itself, but -- we charge one per alternative (see size_up_alt, -- below) to account for the cost of the info table -- and comparisons. -- -- However, in certain cases (see is_inline_scrut -- below), no code is generated for the case unless -- there are multiple alts. In these cases we -- subtract one, making the first alt free. -- e.g. case x# +# y# of _ -> ... should cost 1 -- case touch# x# of _ -> ... should cost 0 -- (see #4978) -- -- I would like to not have the "lengthAtMost alts 1" -- condition above, but without that some programs got worse -- (spectral/hartel/event and spectral/para). I don't fully -- understand why. (SDM 24/5/11) -- unboxed variables, inline primops and unsafe foreign calls -- are all "inline" things: is_inline_scrut (Var v) = isUnliftedType (idType v) is_inline_scrut scrut | (Var f, _) <- collectArgs scrut = case idDetails f of FCallId fc -> not (isSafeForeignCall fc) PrimOpId op -> not (primOpOutOfLine op) _other -> False | otherwise = False size_up_rhs (bndr, rhs) | Just join_arity <- isJoinId_maybe bndr -- Skip arguments to join point , (_bndrs, body) <- collectNBinders join_arity rhs = size_up body | otherwise = size_up rhs ------------ -- size_up_app is used when there's ONE OR MORE value args size_up_app (App fun arg) args voids | isTyCoArg arg = size_up_app fun args voids | isRealWorldExpr arg = size_up_app fun (arg:args) (voids + 1) | otherwise = size_up arg `addSizeNSD` size_up_app fun (arg:args) voids size_up_app (Var fun) args voids = size_up_call fun args voids size_up_app (Tick _ expr) args voids = size_up_app expr args voids size_up_app (Cast expr _) args voids = size_up_app expr args voids size_up_app other args voids = size_up other `addSizeN` callSize (length args) voids -- if the lhs is not an App or a Var, or an invisible thing like a -- Tick or Cast, then we should charge for a complete call plus the -- size of the lhs itself. ------------ size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize size_up_call fun val_args voids = case idDetails fun of FCallId _ -> sizeN (callSize (length val_args) voids) DataConWorkId dc -> conSize dc (length val_args) PrimOpId op -> primOpSize op (length val_args) ClassOpId _ -> classOpSize dflags top_args val_args _ -> funSize dflags top_args fun (length val_args) voids ------------ size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10 -- Don't charge for args, so that wrappers look cheap -- (See comments about wrappers with Case) -- -- IMPORTANT: *do* charge 1 for the alternative, else we -- find that giant case nests are treated as practically free -- A good example is Foreign.C.Error.errnoToIOError ------------ -- Cost to allocate binding with given binder size_up_alloc bndr | isTyVar bndr -- Doesn't exist at runtime || isJoinId bndr -- Not allocated at all || isUnliftedType (idType bndr) -- Doesn't live in heap = 0 | otherwise = 10 ------------ -- These addSize things have to be here because -- I don't want to give them bOMB_OUT_SIZE as an argument addSizeN TooBig _ = TooBig addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n + m) xs d -- addAltSize is used to add the sizes of case alternatives addAltSize TooBig _ = TooBig addAltSize _ TooBig = TooBig addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) = mkSizeIs bOMB_OUT_SIZE (n1 + n2) (xs `unionBags` ys) (d1 + d2) -- Note [addAltSize result discounts] -- This variant ignores the result discount from its LEFT argument -- It's used when the second argument isn't part of the result addSizeNSD TooBig _ = TooBig addSizeNSD _ TooBig = TooBig addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2) = mkSizeIs bOMB_OUT_SIZE (n1 + n2) (xs `unionBags` ys) d2 -- Ignore d1 isRealWorldId id = idType id `eqType` realWorldStatePrimTy -- an expression of type State# RealWorld must be a variable isRealWorldExpr (Var id) = isRealWorldId id isRealWorldExpr (Tick _ e) = isRealWorldExpr e isRealWorldExpr _ = False -- | Finds a nominal size of a string literal. litSize :: Literal -> Int -- Used by CoreUnfold.sizeExpr litSize (LitNumber LitNumInteger _ _) = 100 -- Note [Size of literal integers] litSize (LitNumber LitNumNatural _ _) = 100 litSize (LitString str) = 10 + 10 * ((BS.length str + 3) `div` 4) -- If size could be 0 then @f "x"@ might be too small -- [Sept03: make literal strings a bit bigger to avoid fruitless -- duplication of little strings] litSize _other = 0 -- Must match size of nullary constructors -- Key point: if x |-> 4, then x must inline unconditionally -- (eg via case binding) classOpSize :: DynFlags -> [Id] -> [CoreExpr] -> ExprSize -- See Note [Conlike is interesting] classOpSize _ _ [] = sizeZero classOpSize dflags top_args (arg1 : other_args) = SizeIs size arg_discount 0 where size = 20 + (10 * length other_args) -- If the class op is scrutinising a lambda bound dictionary then -- give it a discount, to encourage the inlining of this function -- The actual discount is rather arbitrarily chosen arg_discount = case arg1 of Var dict | dict `elem` top_args -> unitBag (dict, ufDictDiscount dflags) _other -> emptyBag -- | The size of a function call callSize :: Int -- ^ number of value args -> Int -- ^ number of value args that are void -> Int callSize n_val_args voids = 10 * (1 + n_val_args - voids) -- The 1+ is for the function itself -- Add 1 for each non-trivial arg; -- the allocation cost, as in let(rec) -- | The size of a jump to a join point jumpSize :: Int -- ^ number of value args -> Int -- ^ number of value args that are void -> Int jumpSize n_val_args voids = 2 * (1 + n_val_args - voids) -- A jump is 20% the size of a function call. Making jumps free reopens -- bug #6048, but making them any more expensive loses a 21% improvement in -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a -- better solution? funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize -- Size for functions that are not constructors or primops -- Note [Function applications] funSize dflags top_args fun n_val_args voids | fun `hasKey` buildIdKey = buildSize | fun `hasKey` augmentIdKey = augmentSize | otherwise = SizeIs size arg_discount res_discount where some_val_args = n_val_args > 0 is_join = isJoinId fun size | is_join = jumpSize n_val_args voids | not some_val_args = 0 | otherwise = callSize n_val_args voids -- DISCOUNTS -- See Note [Function and non-function discounts] arg_discount | some_val_args && fun `elem` top_args = unitBag (fun, ufFunAppDiscount dflags) | otherwise = emptyBag -- If the function is an argument and is applied -- to some values, give it an arg-discount res_discount | idArity fun > n_val_args = ufFunAppDiscount dflags | otherwise = 0 -- If the function is partially applied, show a result discount -- XXX maybe behave like ConSize for eval'd variable conSize :: DataCon -> Int -> ExprSize conSize dc n_val_args | n_val_args == 0 = SizeIs 0 emptyBag 10 -- Like variables -- See Note [Unboxed tuple size and result discount] | isUnboxedTupleCon dc = SizeIs 0 emptyBag (10 * (1 + n_val_args)) -- See Note [Constructor size and result discount] | otherwise = SizeIs 10 emptyBag (10 * (1 + n_val_args)) -- XXX still looks to large to me {- Note [Constructor size and result discount] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Treat a constructors application as size 10, regardless of how many arguments it has; we are keen to expose them (and we charge separately for their args). We can't treat them as size zero, else we find that (Just x) has size 0, which is the same as a lone variable; and hence 'v' will always be replaced by (Just x), where v is bound to Just x. The "result discount" is applied if the result of the call is scrutinised (say by a case). For a constructor application that will mean the constructor application will disappear, so we don't need to charge it to the function. So the discount should at least match the cost of the constructor application, namely 10. But to give a bit of extra incentive we give a discount of 10*(1 + n_val_args). Simon M tried a MUCH bigger discount: (10 * (10 + n_val_args)), and said it was an "unambiguous win", but its terribly dangerous because a function with many many case branches, each finishing with a constructor, can have an arbitrarily large discount. This led to terrible code bloat: see #6099. Note [Unboxed tuple size and result discount] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ However, unboxed tuples count as size zero. I found occasions where we had f x y z = case op# x y z of { s -> (# s, () #) } and f wasn't getting inlined. I tried giving unboxed tuples a *result discount* of zero (see the commented-out line). Why? When returned as a result they do not allocate, so maybe we don't want to charge so much for them If you have a non-zero discount here, we find that workers often get inlined back into wrappers, because it look like f x = case $wf x of (# a,b #) -> (a,b) and we are keener because of the case. However while this change shrank binary sizes by 0.5% it also made spectral/boyer allocate 5% more. All other changes were very small. So it's not a big deal but I didn't adopt the idea. Note [Function and non-function discounts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want a discount if the function is applied. A good example is monadic combinators with continuation arguments, where inlining is quite important. But we don't want a big discount when a function is called many times (see the detailed comments with #6048) because if the function is big it won't be inlined at its many call sites and no benefit results. Indeed, we can get exponentially big inlinings this way; that is what #6048 is about. On the other hand, for data-valued arguments, if there are lots of case expressions in the body, each one will get smaller if we apply the function to a constructor application, so we *want* a big discount if the argument is scrutinised by many case expressions. Conclusion: - For functions, take the max of the discounts - For data values, take the sum of the discounts Note [Literal integer size] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Literal integers *can* be big (mkInteger [...coefficients...]), but need not be (S# n). We just use an arbitrary big-ish constant here so that, in particular, we don't inline top-level defns like n = S# 5 There's no point in doing so -- any optimisations will see the S# through n's unfolding. Nor will a big size inhibit unfoldings functions that mention a literal Integer, because the float-out pass will float all those constants to top level. -} primOpSize :: PrimOp -> Int -> ExprSize primOpSize op n_val_args = if primOpOutOfLine op then sizeN (op_size + n_val_args) else sizeN op_size where op_size = primOpCodeSize op buildSize :: ExprSize buildSize = SizeIs 0 emptyBag 40 -- We really want to inline applications of build -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later) -- Indeed, we should add a result_discount because build is -- very like a constructor. We don't bother to check that the -- build is saturated (it usually is). The "-2" discounts for the \c n, -- The "4" is rather arbitrary. augmentSize :: ExprSize augmentSize = SizeIs 0 emptyBag 40 -- Ditto (augment t (\cn -> e) ys) should cost only the cost of -- e plus ys. The -2 accounts for the \cn -- When we return a lambda, give a discount if it's used (applied) lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (ufFunAppDiscount dflags) lamScrutDiscount _ TooBig = TooBig {- Note [addAltSize result discounts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When adding the size of alternatives, we *add* the result discounts too, rather than take the *maximum*. For a multi-branch case, this gives a discount for each branch that returns a constructor, making us keener to inline. I did try using 'max' instead, but it makes nofib 'rewrite' and 'puzzle' allocate significantly more, and didn't make binary sizes shrink significantly either. Note [Discounts and thresholds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Constants for discounts and thesholds are defined in main/DynFlags, all of form ufXxxx. They are: ufCreationThreshold At a definition site, if the unfolding is bigger than this, we may discard it altogether ufUseThreshold At a call site, if the unfolding, less discounts, is smaller than this, then it's small enough inline ufKeenessFactor Factor by which the discounts are multiplied before subtracting from size ufDictDiscount The discount for each occurrence of a dictionary argument as an argument of a class method. Should be pretty small else big functions may get inlined ufFunAppDiscount Discount for a function argument that is applied. Quite large, because if we inline we avoid the higher-order call. ufDearOp The size of a foreign call or not-dupable PrimOp ufVeryAggressive If True, the compiler ignores all the thresholds and inlines very aggressively. It still adheres to arity, simplifier phase control and loop breakers. Note [Function applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In a function application (f a b) - If 'f' is an argument to the function being analysed, and there's at least one value arg, record a FunAppDiscount for f - If the application if a PAP (arity > 2 in this example) record a *result* discount (because inlining with "extra" args in the call may mean that we now get a saturated application) Code for manipulating sizes -} -- | The size of a candidate expression for unfolding data ExprSize = TooBig | SizeIs { _es_size_is :: {-# UNPACK #-} !Int -- ^ Size found , _es_args :: !(Bag (Id,Int)) -- ^ Arguments cased herein, and discount for each such , _es_discount :: {-# UNPACK #-} !Int -- ^ Size to subtract if result is scrutinised by a case -- expression } instance Outputable ExprSize where ppr TooBig = text "TooBig" ppr (SizeIs a _ c) = brackets (int a <+> int c) -- subtract the discount before deciding whether to bale out. eg. we -- want to inline a large constructor application into a selector: -- tup = (a_1, ..., a_99) -- x = case tup of ... -- mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize mkSizeIs max n xs d | (n - d) > max = TooBig | otherwise = SizeIs n xs d maxSize :: ExprSize -> ExprSize -> ExprSize maxSize TooBig _ = TooBig maxSize _ TooBig = TooBig maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 > n2 = s1 | otherwise = s2 sizeZero :: ExprSize sizeN :: Int -> ExprSize sizeZero = SizeIs 0 emptyBag 0 sizeN n = SizeIs n emptyBag 0 {- ************************************************************************ * * \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} * * ************************************************************************ We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that we ``couldn't possibly use'' on the other side. Can be overridden w/ flaggery. Just the same as smallEnoughToInline, except that it has no actual arguments. -} couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool couldBeSmallEnoughToInline dflags threshold rhs = case sizeExpr dflags threshold [] body of TooBig -> False _ -> True where (_, body) = collectBinders rhs ---------------- smallEnoughToInline :: DynFlags -> Unfolding -> Bool smallEnoughToInline dflags (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}}) = size <= ufUseThreshold dflags smallEnoughToInline _ _ = False ---------------- certainlyWillInline :: DynFlags -> IdInfo -> Maybe Unfolding -- ^ Sees if the unfolding is pretty certain to inline. -- If so, return a *stable* unfolding for it, that will always inline. certainlyWillInline dflags fn_info = case unfoldingInfo fn_info of CoreUnfolding { uf_tmpl = e, uf_guidance = g } | loop_breaker -> Nothing -- Won't inline, so try w/w | noinline -> Nothing -- See Note [Worker-wrapper for NOINLINE functions] | otherwise -> do_cunf e g -- Depends on size, so look at that DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense -- to do so, and even if it is currently a -- loop breaker, it may not be later _other_unf -> Nothing where loop_breaker = isStrongLoopBreaker (occInfo fn_info) noinline = inlinePragmaSpec (inlinePragInfo fn_info) == NoInline fn_unf = unfoldingInfo fn_info do_cunf :: CoreExpr -> UnfoldingGuidance -> Maybe Unfolding do_cunf _ UnfNever = Nothing do_cunf _ (UnfWhen {}) = Just (fn_unf { uf_src = InlineStable }) -- INLINE functions have UnfWhen -- The UnfIfGoodArgs case seems important. If we w/w small functions -- binary sizes go up by 10%! (This is with SplitObjs.) -- I'm not totally sure why. -- INLINABLE functions come via this path -- See Note [certainlyWillInline: INLINABLE] do_cunf expr (UnfIfGoodArgs { ug_size = size, ug_args = args }) | arityInfo fn_info > 0 -- See Note [certainlyWillInline: be careful of thunks] , not (isBottomingSig (strictnessInfo fn_info)) -- Do not unconditionally inline a bottoming functions even if -- it seems smallish. We've carefully lifted it out to top level, -- so we don't want to re-inline it. , let unf_arity = length args , size - (10 * (unf_arity + 1)) <= ufUseThreshold dflags = Just (fn_unf { uf_src = InlineStable , uf_guidance = UnfWhen { ug_arity = unf_arity , ug_unsat_ok = unSaturatedOk , ug_boring_ok = inlineBoringOk expr } }) -- Note the "unsaturatedOk". A function like f = \ab. a -- will certainly inline, even if partially applied (f e), so we'd -- better make sure that the transformed inlining has the same property | otherwise = Nothing {- Note [certainlyWillInline: be careful of thunks] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Don't claim that thunks will certainly inline, because that risks work duplication. Even if the work duplication is not great (eg is_cheap holds), it can make a big difference in an inner loop In #5623 we found that the WorkWrap phase thought that y = case x of F# v -> F# (v +# v) was certainlyWillInline, so the addition got duplicated. Note that we check arityInfo instead of the arity of the unfolding to detect this case. This is so that we don't accidentally fail to inline small partial applications, like `f = g 42` (where `g` recurses into `f`) where g has arity 2 (say). Here there is no risk of work duplication, and the RHS is tiny, so certainlyWillInline should return True. But `unf_arity` is zero! However f's arity, gotten from `arityInfo fn_info`, is 1. Failing to say that `f` will inline forces W/W to generate a potentially huge worker for f that will immediately cancel with `g`'s wrapper anyway, causing unnecessary churn in the Simplifier while arriving at the same result. Note [certainlyWillInline: INLINABLE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ certainlyWillInline /must/ return Nothing for a large INLINABLE thing, even though we have a stable inlining, so that strictness w/w takes place. It makes a big difference to efficiency, and the w/w pass knows how to transfer the INLINABLE info to the worker; see WorkWrap Note [Worker-wrapper for INLINABLE functions] ************************************************************************ * * \subsection{callSiteInline} * * ************************************************************************ This is the key function. It decides whether to inline a variable at a call site callSiteInline is used at call sites, so it is a bit more generous. It's a very important function that embodies lots of heuristics. A non-WHNF can be inlined if it doesn't occur inside a lambda, and occurs exactly once or occurs once in each branch of a case and is small If the thing is in WHNF, there's no danger of duplicating work, so we can inline if it occurs once, or is small NOTE: we don't want to inline top-level functions that always diverge. It just makes the code bigger. Tt turns out that the convenient way to prevent them inlining is to give them a NOINLINE pragma, which we do in StrictAnal.addStrictnessInfoToTopId -} callSiteInline :: DynFlags -> Id -- The Id -> Bool -- True <=> unfolding is active -> Bool -- True if there are no arguments at all (incl type args) -> [ArgSummary] -- One for each value arg; True if it is interesting -> CallCtxt -- True <=> continuation is interesting -> Maybe CoreExpr -- Unfolding, if any data ArgSummary = TrivArg -- Nothing interesting | NonTrivArg -- Arg has structure | ValueArg -- Arg is a con-app or PAP -- ..or con-like. Note [Conlike is interesting] instance Outputable ArgSummary where ppr TrivArg = text "TrivArg" ppr NonTrivArg = text "NonTrivArg" ppr ValueArg = text "ValueArg" nonTriv :: ArgSummary -> Bool nonTriv TrivArg = False nonTriv _ = True data CallCtxt = BoringCtxt | RhsCtxt -- Rhs of a let-binding; see Note [RHS of lets] | DiscArgCtxt -- Argument of a function with non-zero arg discount | RuleArgCtxt -- We are somewhere in the argument of a function with rules | ValAppCtxt -- We're applied to at least one value arg -- This arises when we have ((f x |> co) y) -- Then the (f x) has argument 'x' but in a ValAppCtxt | CaseCtxt -- We're the scrutinee of a case -- that decomposes its scrutinee instance Outputable CallCtxt where ppr CaseCtxt = text "CaseCtxt" ppr ValAppCtxt = text "ValAppCtxt" ppr BoringCtxt = text "BoringCtxt" ppr RhsCtxt = text "RhsCtxt" ppr DiscArgCtxt = text "DiscArgCtxt" ppr RuleArgCtxt = text "RuleArgCtxt" callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info = case idUnfolding id of -- idUnfolding checks for loop-breakers, returning NoUnfolding -- Things with an INLINE pragma may have an unfolding *and* -- be a loop breaker (maybe the knot is not yet untied) CoreUnfolding { uf_tmpl = unf_template , uf_is_work_free = is_wf , uf_guidance = guidance, uf_expandable = is_exp } | active_unfolding -> tryUnfolding dflags id lone_variable arg_infos cont_info unf_template is_wf is_exp guidance | otherwise -> traceInline dflags id "Inactive unfolding:" (ppr id) Nothing NoUnfolding -> Nothing BootUnfolding -> Nothing OtherCon {} -> Nothing DFunUnfolding {} -> Nothing -- Never unfold a DFun traceInline :: DynFlags -> Id -> String -> SDoc -> a -> a traceInline dflags inline_id str doc result | Just prefix <- inlineCheck dflags = if prefix `isPrefixOf` occNameString (getOccName inline_id) then pprTrace str doc result else result | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags = pprTrace str doc result | otherwise = result -- | This is an awful but temporary workaround for #17615, where the -- case analysis from the 'ufVeryAggressive' selector causes the entire -- 'DynFlags' to be unpacked into local bindings (due to binder swap). This -- results in a tremendous amount of stack spillage, severely bloating the code -- generated for 'callSiteInline'. -- -- The right solution here is likely to fix binder swap to avoid this terrible -- behavior (since there are likely other instances of this as well) but this -- case was serious enough that it showed up in a CPU profile and consequently -- I wanted to fix it for 8.10. very_aggressive :: DynFlags -> Bool very_aggressive = ufVeryAggressive {-# NOINLINE very_aggressive #-} tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance -> Maybe CoreExpr tryUnfolding dflags id lone_variable arg_infos cont_info unf_template is_wf is_exp guidance = case guidance of UnfNever -> traceInline dflags id str (text "UnfNever") Nothing UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } | enough_args && (boring_ok || some_benefit || very_aggressive dflags) -- See Note [INLINE for small functions (3)] -> traceInline dflags id str (mk_doc some_benefit empty True) (Just unf_template) | otherwise -> traceInline dflags id str (mk_doc some_benefit empty False) Nothing where some_benefit = calc_some_benefit uf_arity enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0) UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } | very_aggressive dflags -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) | is_wf && some_benefit && small_enough -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) | otherwise -> traceInline dflags id str (mk_doc some_benefit extra_doc False) Nothing where some_benefit = calc_some_benefit (length arg_discounts) extra_doc = text "discounted size =" <+> int discounted_size discounted_size = size - discount small_enough = discounted_size <= ufUseThreshold dflags discount = computeDiscount dflags arg_discounts res_discount arg_infos cont_info where mk_doc some_benefit extra_doc yes_or_no = vcat [ text "arg infos" <+> ppr arg_infos , text "interesting continuation" <+> ppr cont_info , text "some_benefit" <+> ppr some_benefit , text "is exp:" <+> ppr is_exp , text "is work-free:" <+> ppr is_wf , text "guidance" <+> ppr guidance , extra_doc , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] str = "Considering inlining: " ++ showSDocDump dflags (ppr id) n_val_args = length arg_infos -- some_benefit is used when the RHS is small enough -- and the call has enough (or too many) value -- arguments (ie n_val_args >= arity). But there must -- be *something* interesting about some argument, or the -- result context, to make it worth inlining calc_some_benefit :: Arity -> Bool -- The Arity is the number of args -- expected by the unfolding calc_some_benefit uf_arity | not saturated = interesting_args -- Under-saturated -- Note [Unsaturated applications] | otherwise = interesting_args -- Saturated or over-saturated || interesting_call where saturated = n_val_args >= uf_arity over_saturated = n_val_args > uf_arity interesting_args = any nonTriv arg_infos -- NB: (any nonTriv arg_infos) looks at the -- over-saturated args too which is "wrong"; -- but if over-saturated we inline anyway. interesting_call | over_saturated = True | otherwise = case cont_info of CaseCtxt -> not (lone_variable && is_exp) -- Note [Lone variables] ValAppCtxt -> True -- Note [Cast then apply] RuleArgCtxt -> uf_arity > 0 -- See Note [Unfold info lazy contexts] DiscArgCtxt -> uf_arity > 0 -- Note [Inlining in ArgCtxt] RhsCtxt -> uf_arity > 0 -- _other -> False -- See Note [Nested functions] {- Note [Unfold into lazy contexts], Note [RHS of lets] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When the call is the argument of a function with a RULE, or the RHS of a let, we are a little bit keener to inline. For example f y = (y,y,y) g y = let x = f y in ...(case x of (a,b,c) -> ...) ... We'd inline 'f' if the call was in a case context, and it kind-of-is, only we can't see it. Also x = f v could be expensive whereas x = case v of (a,b) -> a is patently cheap and may allow more eta expansion. So we treat the RHS of a let as not-totally-boring. Note [Unsaturated applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When a call is not saturated, we *still* inline if one of the arguments has interesting structure. That's sometimes very important. A good example is the Ord instance for Bool in Base: Rec { $fOrdBool =GHC.Classes.D:Ord @ Bool ... $cmin_ajX $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool } But the defn of GHC.Classes.$dmmin is: $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a {- Arity: 3, HasNoCafRefs, Strictness: SLL, Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a -> case @ a GHC.Classes.<= @ a $dOrd x y of wild { GHC.Types.False -> y GHC.Types.True -> x }) -} We *really* want to inline $dmmin, even though it has arity 3, in order to unravel the recursion. Note [Things to watch] ~~~~~~~~~~~~~~~~~~~~~~ * { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... } Assume x is exported, so not inlined unconditionally. Then we want x to inline unconditionally; no reason for it not to, and doing so avoids an indirection. * { x = I# 3; ....f x.... } Make sure that x does not inline unconditionally! Lest we get extra allocation. Note [Inlining an InlineRule] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An InlineRules is used for (a) programmer INLINE pragmas (b) inlinings from worker/wrapper For (a) the RHS may be large, and our contract is that we *only* inline when the function is applied to all the arguments on the LHS of the source-code defn. (The uf_arity in the rule.) However for worker/wrapper it may be worth inlining even if the arity is not satisfied (as we do in the CoreUnfolding case) so we don't require saturation. Note [Nested functions] ~~~~~~~~~~~~~~~~~~~~~~~ At one time we treated a call of a non-top-level function as "interesting" (regardless of how boring the context) in the hope that inlining it would eliminate the binding, and its allocation. Specifically, in the default case of interesting_call we had _other -> not is_top && uf_arity > 0 But actually postInlineUnconditionally does some of this and overall it makes virtually no difference to nofib. So I simplified away this special case Note [Cast then apply] ~~~~~~~~~~~~~~~~~~~~~~ Consider myIndex = __inline_me ( (/\a. ) |> co ) co :: (forall a. a -> a) ~ (forall a. T a) ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ... We need to inline myIndex to unravel this; but the actual call (myIndex a) has no value arguments. The ValAppCtxt gives it enough incentive to inline. Note [Inlining in ArgCtxt] ~~~~~~~~~~~~~~~~~~~~~~~~~~ The condition (arity > 0) here is very important, because otherwise we end up inlining top-level stuff into useless places; eg x = I# 3# f = \y. g x This can make a very big difference: it adds 16% to nofib 'integer' allocs, and 20% to 'power'. At one stage I replaced this condition by 'True' (leading to the above slow-down). The motivation was test eyeball/inline1.hs; but that seems to work ok now. NOTE: arguably, we should inline in ArgCtxt only if the result of the call is at least CONLIKE. At least for the cases where we use ArgCtxt for the RHS of a 'let', we only profit from the inlining if we get a CONLIKE thing (modulo lets). Note [Lone variables] See also Note [Interaction of exprIsWorkFree and lone variables] ~~~~~~~~~~~~~~~~~~~~~ which appears below The "lone-variable" case is important. I spent ages messing about with unsatisfactory variants, but this is nice. The idea is that if a variable appears all alone as an arg of lazy fn, or rhs BoringCtxt as scrutinee of a case CaseCtxt as arg of a fn ArgCtxt AND it is bound to a cheap expression then we should not inline it (unless there is some other reason, e.g. it is the sole occurrence). That is what is happening at the use of 'lone_variable' in 'interesting_call'. Why? At least in the case-scrutinee situation, turning let x = (a,b) in case x of y -> ... into let x = (a,b) in case (a,b) of y -> ... and thence to let x = (a,b) in let y = (a,b) in ... is bad if the binding for x will remain. Another example: I discovered that strings were getting inlined straight back into applications of 'error' because the latter is strict. s = "foo" f = \x -> ...(error s)... Fundamentally such contexts should not encourage inlining because, provided the RHS is "expandable" (see Note [exprIsExpandable] in CoreUtils) the context can ``see'' the unfolding of the variable (e.g. case or a RULE) so there's no gain. However, watch out: * Consider this: foo = _inline_ (\n. [n]) bar = _inline_ (foo 20) baz = \n. case bar of { (m:_) -> m + n } Here we really want to inline 'bar' so that we can inline 'foo' and the whole thing unravels as it should obviously do. This is important: in the NDP project, 'bar' generates a closure data structure rather than a list. So the non-inlining of lone_variables should only apply if the unfolding is regarded as cheap; because that is when exprIsConApp_maybe looks through the unfolding. Hence the "&& is_wf" in the InlineRule branch. * Even a type application or coercion isn't a lone variable. Consider case $fMonadST @ RealWorld of { :DMonad a b c -> c } We had better inline that sucker! The case won't see through it. For now, I'm treating treating a variable applied to types in a *lazy* context "lone". The motivating example was f = /\a. \x. BIG g = /\a. \y. h (f a) There's no advantage in inlining f here, and perhaps a significant disadvantage. Hence some_val_args in the Stop case Note [Interaction of exprIsWorkFree and lone variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The lone-variable test says "don't inline if a case expression scrutinises a lone variable whose unfolding is cheap". It's very important that, under these circumstances, exprIsConApp_maybe can spot a constructor application. So, for example, we don't consider let x = e in (x,x) to be cheap, and that's good because exprIsConApp_maybe doesn't think that expression is a constructor application. In the 'not (lone_variable && is_wf)' test, I used to test is_value rather than is_wf, which was utterly wrong, because the above expression responds True to exprIsHNF, which is what sets is_value. This kind of thing can occur if you have {-# INLINE foo #-} foo = let x = e in (x,x) which Roman did. -} computeDiscount :: DynFlags -> [Int] -> Int -> [ArgSummary] -> CallCtxt -> Int computeDiscount dflags arg_discounts res_discount arg_infos cont_info -- We multiple the raw discounts (args_discount and result_discount) -- ty opt_UnfoldingKeenessFactor because the former have to do with -- *size* whereas the discounts imply that there's some extra -- *efficiency* to be gained (e.g. beta reductions, case reductions) -- by inlining. = 10 -- Discount of 10 because the result replaces the call -- so we count 10 for the function itself + 10 * length actual_arg_discounts -- Discount of 10 for each arg supplied, -- because the result replaces the call + round (ufKeenessFactor dflags * fromIntegral (total_arg_discount + res_discount')) where actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos total_arg_discount = sum actual_arg_discounts mk_arg_discount _ TrivArg = 0 mk_arg_discount _ NonTrivArg = 10 mk_arg_discount discount ValueArg = discount res_discount' | LT <- arg_discounts `compareLength` arg_infos = res_discount -- Over-saturated | otherwise = case cont_info of BoringCtxt -> 0 CaseCtxt -> res_discount -- Presumably a constructor ValAppCtxt -> res_discount -- Presumably a function _ -> 40 `min` res_discount -- ToDo: this 40 `min` res_discount doesn't seem right -- for DiscArgCtxt it shouldn't matter because the function will -- get the arg discount for any non-triv arg -- for RuleArgCtxt we do want to be keener to inline; but not only -- constructor results -- for RhsCtxt I suppose that exposing a data con is good in general -- And 40 seems very arbitrary -- -- res_discount can be very large when a function returns -- constructors; but we only want to invoke that large discount -- when there's a case continuation. -- Otherwise we, rather arbitrarily, threshold it. Yuk. -- But we want to aovid inlining large functions that return -- constructors into contexts that are simply "interesting" ghc-lib-parser-8.10.2.20200808/compiler/coreSyn/CoreUtils.hs0000644000000000000000000031504113713635744021213 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 Utility functions on @Core@ syntax -} {-# LANGUAGE CPP #-} -- | Commonly useful utilites for manipulating the Core language module CoreUtils ( -- * Constructing expressions mkCast, mkTick, mkTicks, mkTickNoHNF, tickHNFArgs, bindNonRec, needsCaseBinding, mkAltExpr, mkDefaultCase, mkSingleAltCase, -- * Taking expressions apart findDefault, addDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs, filterAlts, combineIdenticalAlts, refineDefaultAlt, -- * Properties of expressions exprType, coreAltType, coreAltsType, isExprLevPoly, exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom, getIdFromTrivialExpr_maybe, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree, exprIsBig, exprIsConLike, rhsIsStatic, isCheapApp, isExpandableApp, exprIsTickedString, exprIsTickedString_maybe, exprIsTopLevelBindable, altsAreExhaustive, -- * Equality cheapEqExpr, cheapEqExpr', eqExpr, diffExpr, diffBinds, -- * Eta reduction tryEtaReduce, -- * Manipulating data constructors and types exprToType, exprToCoercion_maybe, applyTypeToArgs, applyTypeToArg, dataConRepInstPat, dataConRepFSInstPat, isEmptyTy, -- * Working with ticks stripTicksTop, stripTicksTopE, stripTicksTopT, stripTicksE, stripTicksT, -- * StaticPtr collectMakeStaticArgs, -- * Join points isJoinBind ) where #include "GhclibHsVersions.h" import GhcPrelude import CoreSyn import PrelNames ( makeStaticName ) import PprCore import CoreFVs( exprFreeVars ) import Var import SrcLoc import VarEnv import VarSet import Name import Literal import DataCon import PrimOp import Id import IdInfo import PrelNames( absentErrorIdKey ) import Type import Predicate import TyCoRep( TyCoBinder(..), TyBinder ) import Coercion import TyCon import Unique import Outputable import TysPrim import DynFlags import FastString import Maybes import ListSetOps ( minusList ) import BasicTypes ( Arity, isConLike ) import GHC.Platform import Util import Pair import Data.ByteString ( ByteString ) import Data.Function ( on ) import Data.List import Data.Ord ( comparing ) import OrdList import qualified Data.Set as Set import UniqSet {- ************************************************************************ * * \subsection{Find the type of a Core atom/expression} * * ************************************************************************ -} exprType :: CoreExpr -> Type -- ^ Recover the type of a well-typed Core expression. Fails when -- applied to the actual 'CoreSyn.Type' expression as it cannot -- really be said to have a type exprType (Var var) = idType var exprType (Lit lit) = literalType lit exprType (Coercion co) = coercionType co exprType (Let bind body) | NonRec tv rhs <- bind -- See Note [Type bindings] , Type ty <- rhs = substTyWithUnchecked [tv] [ty] (exprType body) | otherwise = exprType body exprType (Case _ _ ty _) = ty exprType (Cast _ co) = pSnd (coercionKind co) exprType (Tick _ e) = exprType e exprType (Lam binder expr) = mkLamType binder (exprType expr) exprType e@(App _ _) = case collectArgs e of (fun, args) -> applyTypeToArgs e (exprType fun) args exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy coreAltType :: CoreAlt -> Type -- ^ Returns the type of the alternatives right hand side coreAltType alt@(_,bs,rhs) = case occCheckExpand bs rhs_ty of -- Note [Existential variables and silly type synonyms] Just ty -> ty Nothing -> pprPanic "coreAltType" (pprCoreAlt alt $$ ppr rhs_ty) where rhs_ty = exprType rhs coreAltsType :: [CoreAlt] -> Type -- ^ Returns the type of the first alternative, which should be the same as for all alternatives coreAltsType (alt:_) = coreAltType alt coreAltsType [] = panic "corAltsType" -- | Is this expression levity polymorphic? This should be the -- same as saying (isKindLevPoly . typeKind . exprType) but -- much faster. isExprLevPoly :: CoreExpr -> Bool isExprLevPoly = go where go (Var _) = False -- no levity-polymorphic binders go (Lit _) = False -- no levity-polymorphic literals go e@(App f _) | not (go_app f) = False | otherwise = check_type e go (Lam _ _) = False go (Let _ e) = go e go e@(Case {}) = check_type e -- checking type is fast go e@(Cast {}) = check_type e go (Tick _ e) = go e go e@(Type {}) = pprPanic "isExprLevPoly ty" (ppr e) go (Coercion {}) = False -- this case can happen in SetLevels check_type = isTypeLevPoly . exprType -- slow approach -- if the function is a variable (common case), check its -- levityInfo. This might mean we don't need to look up and compute -- on the type. Spec of these functions: return False if there is -- no possibility, ever, of this expression becoming levity polymorphic, -- no matter what it's applied to; return True otherwise. -- returning True is always safe. See also Note [Levity info] in -- IdInfo go_app (Var id) = not (isNeverLevPolyId id) go_app (Lit _) = False go_app (App f _) = go_app f go_app (Lam _ e) = go_app e go_app (Let _ e) = go_app e go_app (Case _ _ ty _) = resultIsLevPoly ty go_app (Cast _ co) = resultIsLevPoly (pSnd $ coercionKind co) go_app (Tick _ e) = go_app e go_app e@(Type {}) = pprPanic "isExprLevPoly app ty" (ppr e) go_app e@(Coercion {}) = pprPanic "isExprLevPoly app co" (ppr e) {- Note [Type bindings] ~~~~~~~~~~~~~~~~~~~~ Core does allow type bindings, although such bindings are not much used, except in the output of the desugarer. Example: let a = Int in (\x:a. x) Given this, exprType must be careful to substitute 'a' in the result type (#8522). Note [Existential variables and silly type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T = forall a. T (Funny a) type Funny a = Bool f :: T -> Bool f (T x) = x Now, the type of 'x' is (Funny a), where 'a' is existentially quantified. That means that 'exprType' and 'coreAltsType' may give a result that *appears* to mention an out-of-scope type variable. See #3409 for a more real-world example. Various possibilities suggest themselves: - Ignore the problem, and make Lint not complain about such variables - Expand all type synonyms (or at least all those that discard arguments) This is tricky, because at least for top-level things we want to retain the type the user originally specified. - Expand synonyms on the fly, when the problem arises. That is what we are doing here. It's not too expensive, I think. Note that there might be existentially quantified coercion variables, too. -} -- Not defined with applyTypeToArg because you can't print from CoreSyn. applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type -- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. -- The first argument is just for debugging, and gives some context applyTypeToArgs e op_ty args = go op_ty args where go op_ty [] = op_ty go op_ty (Type ty : args) = go_ty_args op_ty [ty] args go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args go op_ty (_ : args) | Just (_, res_ty) <- splitFunTy_maybe op_ty = go res_ty args go _ _ = pprPanic "applyTypeToArgs" panic_msg -- go_ty_args: accumulate type arguments so we can -- instantiate all at once with piResultTys go_ty_args op_ty rev_tys (Type ty : args) = go_ty_args op_ty (ty:rev_tys) args go_ty_args op_ty rev_tys (Coercion co : args) = go_ty_args op_ty (mkCoercionTy co : rev_tys) args go_ty_args op_ty rev_tys args = go (piResultTys op_ty (reverse rev_tys)) args panic_msg = vcat [ text "Expression:" <+> pprCoreExpr e , text "Type:" <+> ppr op_ty , text "Args:" <+> ppr args ] {- ************************************************************************ * * \subsection{Attaching notes} * * ************************************************************************ -} -- | Wrap the given expression in the coercion safely, dropping -- identity coercions and coalescing nested coercions mkCast :: CoreExpr -> CoercionR -> CoreExpr mkCast e co | ASSERT2( coercionRole co == Representational , text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast") <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) ) isReflCo co = e mkCast (Coercion e_co) co | isCoVarType (pSnd (coercionKind co)) -- The guard here checks that g has a (~#) on both sides, -- otherwise decomposeCo fails. Can in principle happen -- with unsafeCoerce = Coercion (mkCoCast e_co co) mkCast (Cast expr co2) co = WARN(let { Pair from_ty _to_ty = coercionKind co; Pair _from_ty2 to_ty2 = coercionKind co2} in not (from_ty `eqType` to_ty2), vcat ([ text "expr:" <+> ppr expr , text "co2:" <+> ppr co2 , text "co:" <+> ppr co ]) ) mkCast expr (mkTransCo co2 co) mkCast (Tick t expr) co = Tick t (mkCast expr co) mkCast expr co = let Pair from_ty _to_ty = coercionKind co in WARN( not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionType co) ) (Cast expr co) -- | Wraps the given expression in the source annotation, dropping the -- annotation if possible. mkTick :: Tickish Id -> CoreExpr -> CoreExpr mkTick t orig_expr = mkTick' id id orig_expr where -- Some ticks (cost-centres) can be split in two, with the -- non-counting part having laxer placement properties. canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t mkTick' :: (CoreExpr -> CoreExpr) -- ^ apply after adding tick (float through) -> (CoreExpr -> CoreExpr) -- ^ apply before adding tick (float with) -> CoreExpr -- ^ current expression -> CoreExpr mkTick' top rest expr = case expr of -- Cost centre ticks should never be reordered relative to each -- other. Therefore we can stop whenever two collide. Tick t2 e | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr -- Otherwise we assume that ticks of different placements float -- through each other. | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e -- For annotations this is where we make sure to not introduce -- redundant ticks. | tickishContains t t2 -> mkTick' top rest e | tickishContains t2 t -> orig_expr | otherwise -> mkTick' top (rest . Tick t2) e -- Ticks don't care about types, so we just float all ticks -- through them. Note that it's not enough to check for these -- cases top-level. While mkTick will never produce Core with type -- expressions below ticks, such constructs can be the result of -- unfoldings. We therefore make an effort to put everything into -- the right place no matter what we start with. Cast e co -> mkTick' (top . flip Cast co) rest e Coercion co -> Coercion co Lam x e -- Always float through type lambdas. Even for non-type lambdas, -- floating is allowed for all but the most strict placement rule. | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime -> mkTick' (top . Lam x) rest e -- If it is both counting and scoped, we split the tick into its -- two components, often allowing us to keep the counting tick on -- the outside of the lambda and push the scoped tick inside. -- The point of this is that the counting tick can probably be -- floated, and the lambda may then be in a position to be -- beta-reduced. | canSplit -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e App f arg -- Always float through type applications. | not (isRuntimeArg arg) -> mkTick' (top . flip App arg) rest f -- We can also float through constructor applications, placement -- permitting. Again we can split. | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) -> if tickishPlace t == PlaceCostCentre then top $ rest $ tickHNFArgs t expr else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr Var x | notFunction && tickishPlace t == PlaceCostCentre -> orig_expr | notFunction && canSplit -> top $ Tick (mkNoScope t) $ rest expr where -- SCCs can be eliminated on variables provided the variable -- is not a function. In these cases the SCC makes no difference: -- the cost of evaluating the variable will be attributed to its -- definition site. When the variable refers to a function, however, -- an SCC annotation on the variable affects the cost-centre stack -- when the function is called, so we must retain those. notFunction = not (isFunTy (idType x)) Lit{} | tickishPlace t == PlaceCostCentre -> orig_expr -- Catch-all: Annotate where we stand _any -> top $ Tick t $ rest expr mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr mkTicks ticks expr = foldr mkTick expr ticks isSaturatedConApp :: CoreExpr -> Bool isSaturatedConApp e = go e [] where go (App f a) as = go f (a:as) go (Var fun) args = isConLikeId fun && idArity fun == valArgCount args go (Cast f _) as = go f as go _ _ = False mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr mkTickNoHNF t e | exprIsHNF e = tickHNFArgs t e | otherwise = mkTick t e -- push a tick into the arguments of a HNF (call or constructor app) tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr tickHNFArgs t e = push t e where push t (App f (Type u)) = App (push t f) (Type u) push t (App f arg) = App (push t f) (mkTick t arg) push _t e = e -- | Strip ticks satisfying a predicate from top of an expression stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b) stripTicksTop p = go [] where go ts (Tick t e) | p t = go (t:ts) e go ts other = (reverse ts, other) -- | Strip ticks satisfying a predicate from top of an expression, -- returning the remaining expression stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b stripTicksTopE p = go where go (Tick t e) | p t = go e go other = other -- | Strip ticks satisfying a predicate from top of an expression, -- returning the ticks stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] stripTicksTopT p = go [] where go ts (Tick t e) | p t = go (t:ts) e go ts _ = ts -- | Completely strip ticks satisfying a predicate from an -- expression. Note this is O(n) in the size of the expression! stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b stripTicksE p expr = go expr where go (App e a) = App (go e) (go a) go (Lam b e) = Lam b (go e) go (Let b e) = Let (go_bs b) (go e) go (Case e b t as) = Case (go e) b t (map go_a as) go (Cast e c) = Cast (go e) c go (Tick t e) | p t = go e | otherwise = Tick t (go e) go other = other go_bs (NonRec b e) = NonRec b (go e) go_bs (Rec bs) = Rec (map go_b bs) go_b (b, e) = (b, go e) go_a (c,bs,e) = (c,bs, go e) stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] stripTicksT p expr = fromOL $ go expr where go (App e a) = go e `appOL` go a go (Lam _ e) = go e go (Let b e) = go_bs b `appOL` go e go (Case e _ _ as) = go e `appOL` concatOL (map go_a as) go (Cast e _) = go e go (Tick t e) | p t = t `consOL` go e | otherwise = go e go _ = nilOL go_bs (NonRec _ e) = go e go_bs (Rec bs) = concatOL (map go_b bs) go_b (_, e) = go e go_a (_, _, e) = go e {- ************************************************************************ * * \subsection{Other expression construction} * * ************************************************************************ -} bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr -- ^ @bindNonRec x r b@ produces either: -- -- > let x = r in b -- -- or: -- -- > case r of x { _DEFAULT_ -> b } -- -- depending on whether we have to use a @case@ or @let@ -- binding for the expression (see 'needsCaseBinding'). -- It's used by the desugarer to avoid building bindings -- that give Core Lint a heart attack, although actually -- the simplifier deals with them perfectly well. See -- also 'MkCore.mkCoreLet' bindNonRec bndr rhs body | isTyVar bndr = let_bind | isCoVar bndr = if isCoArg rhs then let_bind {- See Note [Binding coercions] -} else case_bind | isJoinId bndr = let_bind | needsCaseBinding (idType bndr) rhs = case_bind | otherwise = let_bind where case_bind = mkDefaultCase rhs bndr body let_bind = Let (NonRec bndr rhs) body -- | Tests whether we have to use a @case@ rather than @let@ binding for this expression -- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant" needsCaseBinding :: Type -> CoreExpr -> Bool needsCaseBinding ty rhs = isUnliftedType ty && not (exprOkForSpeculation rhs) -- Make a case expression instead of a let -- These can arise either from the desugarer, -- or from beta reductions: (\x.e) (x +# y) mkAltExpr :: AltCon -- ^ Case alternative constructor -> [CoreBndr] -- ^ Things bound by the pattern match -> [Type] -- ^ The type arguments to the case alternative -> CoreExpr -- ^ This guy constructs the value that the scrutinee must have -- given that you are in one particular branch of a case mkAltExpr (DataAlt con) args inst_tys = mkConApp con (map Type inst_tys ++ varsToCoreExprs args) mkAltExpr (LitAlt lit) [] [] = Lit lit mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr -- Make (case x of y { DEFAULT -> e } mkDefaultCase scrut case_bndr body = Case scrut case_bndr (exprType body) [(DEFAULT, [], body)] mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr -- Use this function if possible, when building a case, -- because it ensures that the type on the Case itself -- doesn't mention variables bound by the case -- See Note [Care with the type of a case expression] mkSingleAltCase scrut case_bndr con bndrs body = Case scrut case_bndr case_ty [(con,bndrs,body)] where body_ty = exprType body case_ty -- See Note [Care with the type of a case expression] | Just body_ty' <- occCheckExpand bndrs body_ty = body_ty' | otherwise = pprPanic "mkSingleAltCase" (ppr scrut $$ ppr bndrs $$ ppr body_ty) {- Note [Care with the type of a case expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a phantom type synonym type S a = Int and we want to form the case expression case x of K (a::*) -> (e :: S a) We must not make the type field of the case-expression (S a) because 'a' isn't in scope. Hence the call to occCheckExpand. This caused issue #17056. NB: this situation can only arise with type synonyms, which can falsely "mention" type variables that aren't "really there", and which can be eliminated by expanding the synonym. Note [Binding coercions] ~~~~~~~~~~~~~~~~~~~~~~~~ Consider binding a CoVar, c = e. Then, we must atisfy Note [CoreSyn type and coercion invariant] in CoreSyn, which allows only (Coercion co) on the RHS. ************************************************************************ * * Operations oer case alternatives * * ************************************************************************ The default alternative must be first, if it exists at all. This makes it easy to find, though it makes matching marginally harder. -} -- | Extract the default case alternative findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b) findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs) findDefault alts = (alts, Nothing) addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)] addDefault alts Nothing = alts addDefault alts (Just rhs) = (DEFAULT, [], rhs) : alts isDefaultAlt :: (AltCon, a, b) -> Bool isDefaultAlt (DEFAULT, _, _) = True isDefaultAlt _ = False -- | Find the case alternative corresponding to a particular -- constructor: panics if no such constructor exists findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b) -- A "Nothing" result *is* legitimate -- See Note [Unreachable code] findAlt con alts = case alts of (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt) _ -> go alts Nothing where go [] deflt = deflt go (alt@(con1,_,_) : alts) deflt = case con `cmpAltCon` con1 of LT -> deflt -- Missed it already; the alts are in increasing order EQ -> Just alt GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt {- Note [Unreachable code] ~~~~~~~~~~~~~~~~~~~~~~~~~~ It is possible (although unusual) for GHC to find a case expression that cannot match. For example: data Col = Red | Green | Blue x = Red f v = case x of Red -> ... _ -> ...(case x of { Green -> e1; Blue -> e2 })... Suppose that for some silly reason, x isn't substituted in the case expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff gets in the way; cf #3118.) Then the full-lazines pass might produce this x = Red lvl = case x of { Green -> e1; Blue -> e2 }) f v = case x of Red -> ... _ -> ...lvl... Now if x gets inlined, we won't be able to find a matching alternative for 'Red'. That's because 'lvl' is unreachable. So rather than crashing we generate (error "Inaccessible alternative"). Similar things can happen (augmented by GADTs) when the Simplifier filters down the matching alternatives in Simplify.rebuildCase. -} --------------------------------- mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)] -- ^ Merge alternatives preserving order; alternatives in -- the first argument shadow ones in the second mergeAlts [] as2 = as2 mergeAlts as1 [] = as1 mergeAlts (a1:as1) (a2:as2) = case a1 `cmpAlt` a2 of LT -> a1 : mergeAlts as1 (a2:as2) EQ -> a1 : mergeAlts as1 as2 -- Discard a2 GT -> a2 : mergeAlts (a1:as1) as2 --------------------------------- trimConArgs :: AltCon -> [CoreArg] -> [CoreArg] -- ^ Given: -- -- > case (C a b x y) of -- > C b x y -> ... -- -- We want to drop the leading type argument of the scrutinee -- leaving the arguments to match against the pattern trimConArgs DEFAULT args = ASSERT( null args ) [] trimConArgs (LitAlt _) args = ASSERT( null args ) [] trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities) -> [Type] -- ^ And its type arguments -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee -> [(AltCon, [Var], a)] -- ^ Alternatives -> ([AltCon], [(AltCon, [Var], a)]) -- Returns: -- 1. Constructors that will never be encountered by the -- *default* case (if any). A superset of imposs_cons -- 2. The new alternatives, trimmed by -- a) remove imposs_cons -- b) remove constructors which can't match because of GADTs -- -- NB: the final list of alternatives may be empty: -- This is a tricky corner case. If the data type has no constructors, -- which GHC allows, or if the imposs_cons covers all constructors (after taking -- account of GADTs), then no alternatives can match. -- -- If callers need to preserve the invariant that there is always at least one branch -- in a "case" statement then they will need to manually add a dummy case branch that just -- calls "error" or similar. filterAlts _tycon inst_tys imposs_cons alts = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt) where (alts_wo_default, maybe_deflt) = findDefault alts alt_cons = [con | (con,_,_) <- alts_wo_default] trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default imposs_cons_set = Set.fromList imposs_cons imposs_deflt_cons = imposs_cons ++ filterOut (`Set.member` imposs_cons_set) alt_cons -- "imposs_deflt_cons" are handled -- EITHER by the context, -- OR by a non-DEFAULT branch in this case expression. impossible_alt :: [Type] -> (AltCon, a, b) -> Bool impossible_alt _ (con, _, _) | con `Set.member` imposs_cons_set = True impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con impossible_alt _ _ = False -- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so. -- See Note [Refine Default Alts] refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders -> TyCon -- ^ Type constructor of scrutinee's type -> [Type] -- ^ Type arguments of scrutinee's type -> [AltCon] -- ^ Constructors that cannot match the DEFAULT (if any) -> [CoreAlt] -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt' refineDefaultAlt us tycon tys imposs_deflt_cons all_alts | (DEFAULT,_,rhs) : rest_alts <- all_alts , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: -- case x of { DEFAULT -> e } -- and we don't want to fill in a default for them! , Just all_cons <- tyConDataCons_maybe tycon , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons] -- We now know it's a data type, so we can use -- UniqSet rather than Set (more efficient) impossible con = con `elementOfUniqSet` imposs_data_cons || dataConCannotMatch tys con = case filterOut impossible all_cons of -- Eliminate the default alternative -- altogether if it can't match: [] -> (False, rest_alts) -- It matches exactly one constructor, so fill it in: [con] -> (True, mergeAlts rest_alts [(DataAlt con, ex_tvs ++ arg_ids, rhs)]) -- We need the mergeAlts to keep the alternatives in the right order where (ex_tvs, arg_ids) = dataConRepInstPat us con tys -- It matches more than one, so do nothing _ -> (False, all_alts) | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon) , not (isFamilyTyCon tycon || isAbstractTyCon tycon) -- Check for no data constructors -- This can legitimately happen for abstract types and type families, -- so don't report that = (False, all_alts) | otherwise -- The common case = (False, all_alts) {- Note [Refine Default Alts] refineDefaultAlt replaces the DEFAULT alt with a constructor if there is one possible value it could be. The simplest example being foo :: () -> () foo x = case x of !_ -> () rewrites to foo :: () -> () foo x = case x of () -> () There are two reasons in general why this is desirable. 1. We can simplify inner expressions In this example we can eliminate the inner case by refining the outer case. If we don't refine it, we are left with both case expressions. ``` {-# LANGUAGE BangPatterns #-} module Test where mid x = x {-# NOINLINE mid #-} data Foo = Foo1 () test :: Foo -> () test x = case x of !_ -> mid (case x of Foo1 x1 -> x1) ``` refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then x becomes bound to `Foo ip1` so is inlined into the other case which causes the KnownBranch optimisation to kick in. 2. combineIdenticalAlts does a better job Simon Jakobi also points out that that combineIdenticalAlts will do a better job if we refine the DEFAULT first. ``` data D = C0 | C1 | C2 case e of DEFAULT -> e0 C0 -> e1 C1 -> e1 ``` When we apply combineIdenticalAlts to this expression, it can't combine the alts for C0 and C1, as we already have a default case. If we apply refineDefaultAlt first, we get ``` case e of C0 -> e1 C1 -> e1 C2 -> e0 ``` and combineIdenticalAlts can turn that into ``` case e of DEFAULT -> e1 C2 -> e0 ``` It isn't obvious that refineDefaultAlt does this but if you look at its one call site in SimplUtils then the `imposs_deflt_cons` argument is populated with constructors which are matched elsewhere. -} {- Note [Combine identical alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If several alternatives are identical, merge them into a single DEFAULT alternative. I've occasionally seen this making a big difference: case e of =====> case e of C _ -> f x D v -> ....v.... D v -> ....v.... DEFAULT -> f x DEFAULT -> f x The point is that we merge common RHSs, at least for the DEFAULT case. [One could do something more elaborate but I've never seen it needed.] To avoid an expensive test, we just merge branches equal to the *first* alternative; this picks up the common cases a) all branches equal b) some branches equal to the DEFAULT (which occurs first) The case where Combine Identical Alternatives transformation showed up was like this (base/Foreign/C/Err/Error.hs): x | p `is` 1 -> e1 | p `is` 2 -> e2 ...etc... where @is@ was something like p `is` n = p /= (-1) && p == n This gave rise to a horrible sequence of cases case p of (-1) -> $j p 1 -> e1 DEFAULT -> $j p and similarly in cascade for all the join points! NB: it's important that all this is done in [InAlt], *before* we work on the alternatives themselves, because Simplify.simplAlt may zap the occurrence info on the binders in the alternatives, which in turn defeats combineIdenticalAlts (see #7360). Note [Care with impossible-constructors when combining alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have (#10538) data T = A | B | C | D case x::T of (Imposs-default-cons {A,B}) DEFAULT -> e1 A -> e2 B -> e1 When calling combineIdentialAlts, we'll have computed that the "impossible constructors" for the DEFAULT alt is {A,B}, since if x is A or B we'll take the other alternatives. But suppose we combine B into the DEFAULT, to get case x::T of (Imposs-default-cons {A}) DEFAULT -> e1 A -> e2 Then we must be careful to trim the impossible constructors to just {A}, else we risk compiling 'e1' wrong! Not only that, but we take care when there is no DEFAULT beforehand, because we are introducing one. Consider case x of (Imposs-default-cons {A,B,C}) A -> e1 B -> e2 C -> e1 Then when combining the A and C alternatives we get case x of (Imposs-default-cons {B}) DEFAULT -> e1 B -> e2 Note that we have a new DEFAULT branch that we didn't have before. So we need delete from the "impossible-default-constructors" all the known-con alternatives that we have eliminated. (In #11172 we missed the first one.) -} combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT -> [CoreAlt] -> (Bool, -- True <=> something happened [AltCon], -- New constructors that cannot match DEFAULT [CoreAlt]) -- New alternatives -- See Note [Combine identical alternatives] -- True <=> we did some combining, result is a single DEFAULT alternative combineIdenticalAlts imposs_deflt_cons ((con1,bndrs1,rhs1) : rest_alts) | all isDeadBinder bndrs1 -- Remember the default , not (null elim_rest) -- alternative comes first = (True, imposs_deflt_cons', deflt_alt : filtered_rest) where (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1) -- See Note [Care with impossible-constructors when combining alternatives] imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons elim_cons = elim_con1 ++ map fstOf3 elim_rest elim_con1 = case con1 of -- Don't forget con1! DEFAULT -> [] -- See Note [ _ -> [con1] cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 identical_to_alt1 (_con,bndrs,rhs) = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 tickss = map (stripTicksT tickishFloatable . thdOf3) elim_rest combineIdenticalAlts imposs_cons alts = (False, imposs_cons, alts) {- ********************************************************************* * * exprIsTrivial * * ************************************************************************ Note [exprIsTrivial] ~~~~~~~~~~~~~~~~~~~~ @exprIsTrivial@ is true of expressions we are unconditionally happy to duplicate; simple variables and constants, and type applications. Note that primop Ids aren't considered trivial unless Note [Variables are trivial] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There used to be a gruesome test for (hasNoBinding v) in the Var case: exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0 The idea here is that a constructor worker, like \$wJust, is really short for (\x -> \$wJust x), because \$wJust has no binding. So it should be treated like a lambda. Ditto unsaturated primops. But now constructor workers are not "have-no-binding" Ids. And completely un-applied primops and foreign-call Ids are sufficiently rare that I plan to allow them to be duplicated and put up with saturating them. Note [Tick trivial] ~~~~~~~~~~~~~~~~~~~ Ticks are only trivial if they are pure annotations. If we treat "tick x" as trivial, it will be inlined inside lambdas and the entry count will be skewed, for example. Furthermore "scc x" will turn into just "x" in mkTick. Note [Empty case is trivial] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The expression (case (x::Int) Bool of {}) is just a type-changing case used when we are sure that 'x' will not return. See Note [Empty case alternatives] in CoreSyn. If the scrutinee is trivial, then so is the whole expression; and the CoreToSTG pass in fact drops the case expression leaving only the scrutinee. Having more trivial expressions is good. Moreover, if we don't treat it as trivial we may land up with let-bindings like let v = case x of {} in ... and after CoreToSTG that gives let v = x in ... and that confuses the code generator (#11155). So best to kill it off at source. -} exprIsTrivial :: CoreExpr -> Bool -- If you modify this function, you may also -- need to modify getIdFromTrivialExpr exprIsTrivial (Var _) = True -- See Note [Variables are trivial] exprIsTrivial (Type _) = True exprIsTrivial (Coercion _) = True exprIsTrivial (Lit lit) = litIsTrivial lit exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e exprIsTrivial (Lam b e) = not (isRuntimeVar b) && exprIsTrivial e exprIsTrivial (Tick t e) = not (tickishIsCode t) && exprIsTrivial e -- See Note [Tick trivial] exprIsTrivial (Cast e _) = exprIsTrivial e exprIsTrivial (Case e _ _ []) = exprIsTrivial e -- See Note [Empty case is trivial] exprIsTrivial _ = False {- Note [getIdFromTrivialExpr] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ When substituting in a breakpoint we need to strip away the type cruft from a trivial expression and get back to the Id. The invariant is that the expression we're substituting was originally trivial according to exprIsTrivial, AND the expression is not a literal. See Note [substTickish] for how breakpoint substitution preserves this extra invariant. We also need this functionality in CorePrep to extract out Id of a function which we are saturating. However, in this case we don't know if the variable actually refers to a literal; thus we use 'getIdFromTrivialExpr_maybe' to handle this case. See test T12076lit for an example where this matters. -} getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id getIdFromTrivialExpr e = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e)) (getIdFromTrivialExpr_maybe e) getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id -- See Note [getIdFromTrivialExpr] -- Th equations for this should line up with those for exprIsTrivial getIdFromTrivialExpr_maybe e = go e where go (App f t) | not (isRuntimeArg t) = go f go (Tick t e) | not (tickishIsCode t) = go e go (Cast e _) = go e go (Lam b e) | not (isRuntimeVar b) = go e go (Case e _ _ []) = go e go (Var v) = Just v go _ = Nothing {- exprIsBottom is a very cheap and cheerful function; it may return False for bottoming expressions, but it never costs much to ask. See also CoreArity.exprBotStrictness_maybe, but that's a bit more expensive. -} exprIsBottom :: CoreExpr -> Bool -- See Note [Bottoming expressions] exprIsBottom e | isEmptyTy (exprType e) = True | otherwise = go 0 e where go n (Var v) = isBottomingId v && n >= idArity v go n (App e a) | isTypeArg a = go n e | otherwise = go (n+1) e go n (Tick _ e) = go n e go n (Cast e _) = go n e go n (Let _ e) = go n e go n (Lam v e) | isTyVar v = go n e go _ (Case _ _ _ alts) = null alts -- See Note [Empty case alternatives] in CoreSyn go _ _ = False {- Note [Bottoming expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A bottoming expression is guaranteed to diverge, or raise an exception. We can test for it in two different ways, and exprIsBottom checks for both of these situations: * Visibly-bottom computations. For example (error Int "Hello") is visibly bottom. The strictness analyser also finds out if a function diverges or raises an exception, and puts that info in its strictness signature. * Empty types. If a type is empty, its only inhabitant is bottom. For example: data T f :: T -> Bool f = \(x:t). case x of Bool {} Since T has no data constructors, the case alternatives are of course empty. However note that 'x' is not bound to a visibly-bottom value; it's the *type* that tells us it's going to diverge. A GADT may also be empty even though it has constructors: data T a where T1 :: a -> T Bool T2 :: T Int ...(case (x::T Char) of {})... Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool), which is likewise uninhabited. ************************************************************************ * * exprIsDupable * * ************************************************************************ Note [exprIsDupable] ~~~~~~~~~~~~~~~~~~~~ @exprIsDupable@ is true of expressions that can be duplicated at a modest cost in code size. This will only happen in different case branches, so there's no issue about duplicating work. That is, exprIsDupable returns True of (f x) even if f is very very expensive to call. Its only purpose is to avoid fruitless let-binding and then inlining of case join points -} exprIsDupable :: DynFlags -> CoreExpr -> Bool exprIsDupable dflags e = isJust (go dupAppSize e) where go :: Int -> CoreExpr -> Maybe Int go n (Type {}) = Just n go n (Coercion {}) = Just n go n (Var {}) = decrement n go n (Tick _ e) = go n e go n (Cast e _) = go n e go n (App f a) | Just n' <- go n a = go n' f go n (Lit lit) | litIsDupable dflags lit = decrement n go _ _ = Nothing decrement :: Int -> Maybe Int decrement 0 = Nothing decrement n = Just (n-1) dupAppSize :: Int dupAppSize = 8 -- Size of term we are prepared to duplicate -- This is *just* big enough to make test MethSharing -- inline enough join points. Really it should be -- smaller, and could be if we fixed #4960. {- ************************************************************************ * * exprIsCheap, exprIsExpandable * * ************************************************************************ Note [exprIsWorkFree] ~~~~~~~~~~~~~~~~~~~~~ exprIsWorkFree is used when deciding whether to inline something; we don't inline it if doing so might duplicate work, by peeling off a complete copy of the expression. Here we do not want even to duplicate a primop (#5623): eg let x = a #+ b in x +# x we do not want to inline/duplicate x Previously we were a bit more liberal, which led to the primop-duplicating problem. However, being more conservative did lead to a big regression in one nofib benchmark, wheel-sieve1. The situation looks like this: let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs -> case GHC.Prim.<=# x_aRs 2 of _ { GHC.Types.False -> notDivBy ps_adM qs_adN; GHC.Types.True -> lvl_r2Eb }} go = \x. ...(noFactor (I# y))....(go x')... The function 'noFactor' is heap-allocated and then called. Turns out that 'notDivBy' is strict in its THIRD arg, but that is invisible to the caller of noFactor, which therefore cannot do w/w and heap-allocates noFactor's argument. At the moment (May 12) we are just going to put up with this, because the previous more aggressive inlining (which treated 'noFactor' as work-free) was duplicating primops, which in turn was making inner loops of array calculations runs slow (#5623) Note [Case expressions are work-free] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Are case-expressions work-free? Consider let v = case x of (p,q) -> p go = \y -> ...case v of ... Should we inline 'v' at its use site inside the loop? At the moment we do. I experimented with saying that case are *not* work-free, but that increased allocation slightly. It's a fairly small effect, and at the moment we go for the slightly more aggressive version which treats (case x of ....) as work-free if the alternatives are. Moreover it improves arities of overloaded functions where there is only dictionary selection (no construction) involved Note [exprIsCheap] See also Note [Interaction of exprIsCheap and lone variables] ~~~~~~~~~~~~~~~~~~ in CoreUnfold.hs @exprIsCheap@ looks at a Core expression and returns \tr{True} if it is obviously in weak head normal form, or is cheap to get to WHNF. [Note that that's not the same as exprIsDupable; an expression might be big, and hence not dupable, but still cheap.] By ``cheap'' we mean a computation we're willing to: push inside a lambda, or inline at more than one place That might mean it gets evaluated more than once, instead of being shared. The main examples of things which aren't WHNF but are ``cheap'' are: * case e of pi -> ei (where e, and all the ei are cheap) * let x = e in b (where e and b are cheap) * op x1 ... xn (where op is a cheap primitive operator) * error "foo" (because we are happy to substitute it inside a lambda) Notice that a variable is considered 'cheap': we can push it inside a lambda, because sharing will make sure it is only evaluated once. Note [exprIsCheap and exprIsHNF] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that exprIsHNF does not imply exprIsCheap. Eg let x = fac 20 in Just x This responds True to exprIsHNF (you can discard a seq), but False to exprIsCheap. Note [Arguments and let-bindings exprIsCheapX] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What predicate should we apply to the argument of an application, or the RHS of a let-binding? We used to say "exprIsTrivial arg" due to concerns about duplicating nested constructor applications, but see #4978. So now we just recursively use exprIsCheapX. We definitely want to treat let and app the same. The principle here is that let x = blah in f x should behave equivalently to f blah This in turn means that the 'letrec g' does not prevent eta expansion in this (which it previously was): f = \x. let v = case x of True -> letrec g = \w. blah in g False -> \x. x in \w. v True -} -------------------- exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree] exprIsWorkFree = exprIsCheapX isWorkFreeApp exprIsCheap :: CoreExpr -> Bool exprIsCheap = exprIsCheapX isCheapApp exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool exprIsCheapX ok_app e = ok e where ok e = go 0 e -- n is the number of value arguments go n (Var v) = ok_app v n go _ (Lit {}) = True go _ (Type {}) = True go _ (Coercion {}) = True go n (Cast e _) = go n e go n (Case scrut _ _ alts) = ok scrut && and [ go n rhs | (_,_,rhs) <- alts ] go n (Tick t e) | tickishCounts t = False | otherwise = go n e go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e | otherwise = go n e go n (App f e) | isRuntimeArg e = go (n+1) f && ok e | otherwise = go n f go n (Let (NonRec _ r) e) = go n e && ok r go n (Let (Rec prs) e) = go n e && all (ok . snd) prs -- Case: see Note [Case expressions are work-free] -- App, Let: see Note [Arguments and let-bindings exprIsCheapX] {- Note [exprIsExpandable] ~~~~~~~~~~~~~~~~~~~~~~~~~~ An expression is "expandable" if we are willing to duplicate it, if doing so might make a RULE or case-of-constructor fire. Consider let x = (a,b) y = build g in ....(case x of (p,q) -> rhs)....(foldr k z y).... We don't inline 'x' or 'y' (see Note [Lone variables] in CoreUnfold), but we do want * the case-expression to simplify (via exprIsConApp_maybe, exprIsLiteral_maybe) * the foldr/build RULE to fire (by expanding the unfolding during rule matching) So we classify the unfolding of a let-binding as "expandable" (via the uf_expandable field) if we want to do this kind of on-the-fly expansion. Specifically: * True of constructor applications (K a b) * True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in BasicTypes. (NB: exprIsCheap might not be true of this) * False of case-expressions. If we have let x = case ... in ...(case x of ...)... we won't simplify. We have to inline x. See #14688. * False of let-expressions (same reason); and in any case we float lets out of an RHS if doing so will reveal an expandable application (see SimplEnv.doFloatFromRhs). * Take care: exprIsExpandable should /not/ be true of primops. I found this in test T5623a: let q = /\a. Ptr a (a +# b) in case q @ Float of Ptr v -> ...q... q's inlining should not be expandable, else exprIsConApp_maybe will say that (q @ Float) expands to (Ptr a (a +# b)), and that will duplicate the (a +# b) primop, which we should not do lightly. (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) -} ------------------------------------- exprIsExpandable :: CoreExpr -> Bool -- See Note [exprIsExpandable] exprIsExpandable e = ok e where ok e = go 0 e -- n is the number of value arguments go n (Var v) = isExpandableApp v n go _ (Lit {}) = True go _ (Type {}) = True go _ (Coercion {}) = True go n (Cast e _) = go n e go n (Tick t e) | tickishCounts t = False | otherwise = go n e go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e | otherwise = go n e go n (App f e) | isRuntimeArg e = go (n+1) f && ok e | otherwise = go n f go _ (Case {}) = False go _ (Let {}) = False ------------------------------------- type CheapAppFun = Id -> Arity -> Bool -- Is an application of this function to n *value* args -- always cheap, assuming the arguments are cheap? -- True mainly of data constructors, partial applications; -- but with minor variations: -- isWorkFreeApp -- isCheapApp -- isExpandableApp isWorkFreeApp :: CheapAppFun isWorkFreeApp fn n_val_args | n_val_args == 0 -- No value args = True | n_val_args < idArity fn -- Partial application = True | otherwise = case idDetails fn of DataConWorkId {} -> True _ -> False isCheapApp :: CheapAppFun isCheapApp fn n_val_args | isWorkFreeApp fn n_val_args = True | isBottomingId fn = True -- See Note [isCheapApp: bottoming functions] | otherwise = case idDetails fn of DataConWorkId {} -> True -- Actually handled by isWorkFreeApp RecSelId {} -> n_val_args == 1 -- See Note [Record selection] ClassOpId {} -> n_val_args == 1 PrimOpId op -> primOpIsCheap op _ -> False -- In principle we should worry about primops -- that return a type variable, since the result -- might be applied to something, but I'm not going -- to bother to check the number of args isExpandableApp :: CheapAppFun isExpandableApp fn n_val_args | isWorkFreeApp fn n_val_args = True | otherwise = case idDetails fn of DataConWorkId {} -> True -- Actually handled by isWorkFreeApp RecSelId {} -> n_val_args == 1 -- See Note [Record selection] ClassOpId {} -> n_val_args == 1 PrimOpId {} -> False _ | isBottomingId fn -> False -- See Note [isExpandableApp: bottoming functions] | isConLike (idRuleMatchInfo fn) -> True | all_args_are_preds -> True | otherwise -> False where -- See if all the arguments are PredTys (implicit params or classes) -- If so we'll regard it as expandable; see Note [Expandable overloadings] all_args_are_preds = all_pred_args n_val_args (idType fn) all_pred_args n_val_args ty | n_val_args == 0 = True | Just (bndr, ty) <- splitPiTy_maybe ty = case bndr of Named {} -> all_pred_args n_val_args ty Anon InvisArg _ -> all_pred_args (n_val_args-1) ty Anon VisArg _ -> False | otherwise = False {- Note [isCheapApp: bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ I'm not sure why we have a special case for bottoming functions in isCheapApp. Maybe we don't need it. Note [isExpandableApp: bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's important that isExpandableApp does not respond True to bottoming functions. Recall undefined :: HasCallStack => a Suppose isExpandableApp responded True to (undefined d), and we had: x = undefined Then Simplify.prepareRhs would ANF the RHS: d = x = undefined d This is already bad: we gain nothing from having x bound to (undefined var), unlike the case for data constructors. Worse, we get the simplifier loop described in OccurAnal Note [Cascading inlines]. Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will certainly_inline; so we end up inlining d right back into x; but in the end x doesn't inline because it is bottom (preInlineUnconditionally); so the process repeats.. We could elaborate the certainly_inline logic some more, but it's better just to treat bottoming bindings as non-expandable, because ANFing them is a bad idea in the first place. Note [Record selection] ~~~~~~~~~~~~~~~~~~~~~~~~~~ I'm experimenting with making record selection look cheap, so we will substitute it inside a lambda. Particularly for dictionary field selection. BUT: Take care with (sel d x)! The (sel d) might be cheap, but there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) Note [Expandable overloadings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose the user wrote this {-# RULE forall x. foo (negate x) = h x #-} f x = ....(foo (negate x)).... He'd expect the rule to fire. But since negate is overloaded, we might get this: f = \d -> let n = negate d in \x -> ...foo (n x)... So we treat the application of a function (negate in this case) to a *dictionary* as expandable. In effect, every function is CONLIKE when it's applied only to dictionaries. ************************************************************************ * * exprOkForSpeculation * * ************************************************************************ -} ----------------------------- -- | 'exprOkForSpeculation' returns True of an expression that is: -- -- * Safe to evaluate even if normal order eval might not -- evaluate the expression at all, or -- -- * Safe /not/ to evaluate even if normal order would do so -- -- It is usually called on arguments of unlifted type, but not always -- In particular, Simplify.rebuildCase calls it on lifted types -- when a 'case' is a plain 'seq'. See the example in -- Note [exprOkForSpeculation: case expressions] below -- -- Precisely, it returns @True@ iff: -- a) The expression guarantees to terminate, -- b) soon, -- c) without causing a write side effect (e.g. writing a mutable variable) -- d) without throwing a Haskell exception -- e) without risking an unchecked runtime exception (array out of bounds, -- divide by zero) -- -- For @exprOkForSideEffects@ the list is the same, but omitting (e). -- -- Note that -- exprIsHNF implies exprOkForSpeculation -- exprOkForSpeculation implies exprOkForSideEffects -- -- See Note [PrimOp can_fail and has_side_effects] in PrimOp -- and Note [Transformations affected by can_fail and has_side_effects] -- -- As an example of the considerations in this test, consider: -- -- > let x = case y# +# 1# of { r# -> I# r# } -- > in E -- -- being translated to: -- -- > case y# +# 1# of { r# -> -- > let x = I# r# -- > in E -- > } -- -- We can only do this if the @y + 1@ is ok for speculation: it has no -- side effects, and can't diverge or raise an exception. exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool exprOkForSpeculation = expr_ok primOpOkForSpeculation exprOkForSideEffects = expr_ok primOpOkForSideEffects expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool expr_ok _ (Lit _) = True expr_ok _ (Type _) = True expr_ok _ (Coercion _) = True expr_ok primop_ok (Var v) = app_ok primop_ok v [] expr_ok primop_ok (Cast e _) = expr_ok primop_ok e expr_ok primop_ok (Lam b e) | isTyVar b = expr_ok primop_ok e | otherwise = True -- Tick annotations that *tick* cannot be speculated, because these -- are meant to identify whether or not (and how often) the particular -- source expression was evaluated at runtime. expr_ok primop_ok (Tick tickish e) | tickishCounts tickish = False | otherwise = expr_ok primop_ok e expr_ok _ (Let {}) = False -- Lets can be stacked deeply, so just give up. -- In any case, the argument of exprOkForSpeculation is -- usually in a strict context, so any lets will have been -- floated away. expr_ok primop_ok (Case scrut bndr _ alts) = -- See Note [exprOkForSpeculation: case expressions] expr_ok primop_ok scrut && isUnliftedType (idType bndr) && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts && altsAreExhaustive alts expr_ok primop_ok other_expr | (expr, args) <- collectArgs other_expr = case stripTicksTopE (not . tickishCounts) expr of Var f -> app_ok primop_ok f args -- 'LitRubbish' is the only literal that can occur in the head of an -- application and will not be matched by the above case (Var /= Lit). Lit lit -> ASSERT( lit == rubbishLit ) True _ -> False ----------------------------- app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool app_ok primop_ok fun args = case idDetails fun of DFunId new_type -> not new_type -- DFuns terminate, unless the dict is implemented -- with a newtype in which case they may not DataConWorkId {} -> True -- The strictness of the constructor has already -- been expressed by its "wrapper", so we don't need -- to take the arguments into account PrimOpId op | isDivOp op , [arg1, Lit lit] <- args -> not (isZeroLit lit) && expr_ok primop_ok arg1 -- Special case for dividing operations that fail -- In general they are NOT ok-for-speculation -- (which primop_ok will catch), but they ARE OK -- if the divisor is definitely non-zero. -- Often there is a literal divisor, and this -- can get rid of a thunk in an inner loop | SeqOp <- op -- See Note [exprOkForSpeculation and SeqOp/DataToTagOp] -> False -- for the special cases for SeqOp and DataToTagOp | DataToTagOp <- op -> False | otherwise -> primop_ok op -- Check the primop itself && and (zipWith primop_arg_ok arg_tys args) -- Check the arguments _other -> isUnliftedType (idType fun) -- c.f. the Var case of exprIsHNF || idArity fun > n_val_args -- Partial apps -- NB: even in the nullary case, do /not/ check -- for evaluated-ness of the fun; -- see Note [exprOkForSpeculation and evaluated variables] where n_val_args = valArgCount args where (arg_tys, _) = splitPiTys (idType fun) primop_arg_ok :: TyBinder -> CoreExpr -> Bool primop_arg_ok (Named _) _ = True -- A type argument primop_arg_ok (Anon _ ty) arg -- A term argument | isUnliftedType ty = expr_ok primop_ok arg | otherwise = True -- See Note [Primops with lifted arguments] ----------------------------- altsAreExhaustive :: [Alt b] -> Bool -- True <=> the case alternatives are definiely exhaustive -- False <=> they may or may not be altsAreExhaustive [] = False -- Should not happen altsAreExhaustive ((con1,_,_) : alts) = case con1 of DEFAULT -> True LitAlt {} -> False DataAlt c -> alts `lengthIs` (tyConFamilySize (dataConTyCon c) - 1) -- It is possible to have an exhaustive case that does not -- enumerate all constructors, notably in a GADT match, but -- we behave conservatively here -- I don't think it's important -- enough to deserve special treatment -- | True of dyadic operators that can fail only if the second arg is zero! isDivOp :: PrimOp -> Bool -- This function probably belongs in PrimOp, or even in -- an automagically generated file.. but it's such a -- special case I thought I'd leave it here for now. isDivOp IntQuotOp = True isDivOp IntRemOp = True isDivOp WordQuotOp = True isDivOp WordRemOp = True isDivOp FloatDivOp = True isDivOp DoubleDivOp = True isDivOp _ = False {- Note [exprOkForSpeculation: case expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ exprOkForSpeculation accepts very special case expressions. Reason: (a ==# b) is ok-for-speculation, but the litEq rules in PrelRules convert it (a ==# 3#) to case a of { DEFAULT -> 0#; 3# -> 1# } for excellent reasons described in PrelRules Note [The litEq rule: converting equality to case]. So, annoyingly, we want that case expression to be ok-for-speculation too. Bother. But we restrict it sharply: * We restrict it to unlifted scrutinees. Consider this: case x of y { DEFAULT -> ... (let v::Int# = case y of { True -> e1 ; False -> e2 } in ...) ... Does the RHS of v satisfy the let/app invariant? Previously we said yes, on the grounds that y is evaluated. But the binder-swap done by SetLevels would transform the inner alternative to DEFAULT -> ... (let v::Int# = case x of { ... } in ...) .... which does /not/ satisfy the let/app invariant, because x is not evaluated. See Note [Binder-swap during float-out] in SetLevels. To avoid this awkwardness it seems simpler to stick to unlifted scrutinees where the issue does not arise. * We restrict it to exhaustive alternatives. A non-exhaustive case manifestly isn't ok-for-speculation. for example, this is a valid program (albeit a slightly dodgy one) let v = case x of { B -> ...; C -> ... } in case x of A -> ... _ -> ...v...v.... Should v be considered ok-for-speculation? Its scrutinee may be evaluated, but the alternatives are incomplete so we should not evaluate it strictly. Now, all this is for lifted types, but it'd be the same for any finite unlifted type. We don't have many of them, but we might add unlifted algebraic types in due course. ----- Historical note: #15696: -------- Previously SetLevels used exprOkForSpeculation to guide floating of single-alternative cases; it now uses exprIsHNF Note [Floating single-alternative cases]. But in those days, consider case e of x { DEAFULT -> ...(case x of y A -> ... _ -> ...(case (case x of { B -> p; C -> p }) of I# r -> blah)... If SetLevels considers the inner nested case as ok-for-speculation it can do case-floating (in SetLevels). So we'd float to: case e of x { DEAFULT -> case (case x of { B -> p; C -> p }) of I# r -> ...(case x of y A -> ... _ -> ...blah...)... which is utterly bogus (seg fault); see #5453. ----- Historical note: #3717: -------- foo :: Int -> Int foo 0 = 0 foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) In earlier GHCs, we got this: T.$wfoo = \ (ww :: GHC.Prim.Int#) -> case ww of ds { __DEFAULT -> case (case <# ds 5 of _ { GHC.Types.False -> lvl1; GHC.Types.True -> lvl}) of _ { __DEFAULT -> T.$wfoo (GHC.Prim.-# ds_XkE 1) }; 0 -> 0 } Before join-points etc we could only get rid of two cases (which are redundant) by recognising that the (case <# ds 5 of { ... }) is ok-for-speculation, even though it has /lifted/ type. But now join points do the job nicely. ------- End of historical note ------------ Note [Primops with lifted arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Is this ok-for-speculation (see #13027)? reallyUnsafePtrEq# a b Well, yes. The primop accepts lifted arguments and does not evaluate them. Indeed, in general primops are, well, primitive and do not perform evaluation. Bottom line: * In exprOkForSpeculation we simply ignore all lifted arguments. * In the rare case of primops that /do/ evaluate their arguments, (namely DataToTagOp and SeqOp) return False; see Note [exprOkForSpeculation and evaluated variables] Note [exprOkForSpeculation and SeqOp/DataToTagOp] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Most primops with lifted arguments don't evaluate them (see Note [Primops with lifted arguments]), so we can ignore that argument entirely when doing exprOkForSpeculation. But DataToTagOp and SeqOp are exceptions to that rule. For reasons described in Note [exprOkForSpeculation and evaluated variables], we simply return False for them. Not doing this made #5129 go bad. Lots of discussion in #15696. Note [exprOkForSpeculation and evaluated variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Recall that seq# :: forall a s. a -> State# s -> (# State# s, a #) dataToTag# :: forall a. a -> Int# must always evaluate their first argument. Now consider these examples: * case x of y { DEFAULT -> ....y.... } Should 'y' (alone) be considered ok-for-speculation? * case x of y { DEFAULT -> ....f (dataToTag# y)... } Should (dataToTag# y) be considered ok-for-spec? You could argue 'yes', because in the case alternative we know that 'y' is evaluated. But the binder-swap transformation, which is extremely useful for float-out, changes these expressions to case x of y { DEFAULT -> ....x.... } case x of y { DEFAULT -> ....f (dataToTag# x)... } And now the expression does not obey the let/app invariant! Yikes! Moreover we really might float (f (dataToTag# x)) outside the case, and then it really, really doesn't obey the let/app invariant. The solution is simple: exprOkForSpeculation does not try to take advantage of the evaluated-ness of (lifted) variables. And it returns False (always) for DataToTagOp and SeqOp. Note that exprIsHNF /can/ and does take advantage of evaluated-ness; it doesn't have the trickiness of the let/app invariant to worry about. ************************************************************************ * * exprIsHNF, exprIsConLike * * ************************************************************************ -} -- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF] -- ~~~~~~~~~~~~~~~~ -- | exprIsHNF returns true for expressions that are certainly /already/ -- evaluated to /head/ normal form. This is used to decide whether it's ok -- to change: -- -- > case x of _ -> e -- -- into: -- -- > e -- -- and to decide whether it's safe to discard a 'seq'. -- -- So, it does /not/ treat variables as evaluated, unless they say they are. -- However, it /does/ treat partial applications and constructor applications -- as values, even if their arguments are non-trivial, provided the argument -- type is lifted. For example, both of these are values: -- -- > (:) (f x) (map f xs) -- > map (...redex...) -- -- because 'seq' on such things completes immediately. -- -- For unlifted argument types, we have to be careful: -- -- > C (f x :: Int#) -- -- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't -- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of -- unboxed type must be ok-for-speculation (or trivial). exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding -- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as -- data constructors. Conlike arguments are considered interesting by the -- inliner. exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding -- | Returns true for values or value-like expressions. These are lambdas, -- constructors / CONLIKE functions (as determined by the function argument) -- or PAPs. -- exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool exprIsHNFlike is_con is_con_unf = is_hnf_like where is_hnf_like (Var v) -- NB: There are no value args at this point = id_app_is_value v 0 -- Catches nullary constructors, -- so that [] and () are values, for example -- and (e.g.) primops that don't have unfoldings || is_con_unf (idUnfolding v) -- Check the thing's unfolding; it might be bound to a value -- or to a guaranteed-evaluated variable (isEvaldUnfolding) -- Contrast with Note [exprOkForSpeculation and evaluated variables] -- We don't look through loop breakers here, which is a bit conservative -- but otherwise I worry that if an Id's unfolding is just itself, -- we could get an infinite loop is_hnf_like (Lit _) = True is_hnf_like (Type _) = True -- Types are honorary Values; -- we don't mind copying them is_hnf_like (Coercion _) = True -- Same for coercions is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e is_hnf_like (Tick tickish e) = not (tickishCounts tickish) && is_hnf_like e -- See Note [exprIsHNF Tick] is_hnf_like (Cast e _) = is_hnf_like e is_hnf_like (App e a) | isValArg a = app_is_value e 1 | otherwise = is_hnf_like e is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us is_hnf_like _ = False -- 'n' is the number of value args to which the expression is applied -- And n>0: there is at least one value argument app_is_value :: CoreExpr -> Int -> Bool app_is_value (Var f) nva = id_app_is_value f nva app_is_value (Tick _ f) nva = app_is_value f nva app_is_value (Cast f _) nva = app_is_value f nva app_is_value (App f a) nva | isValArg a = app_is_value f (nva + 1) | otherwise = app_is_value f nva app_is_value _ _ = False id_app_is_value id n_val_args = is_con id || idArity id > n_val_args || id `hasKey` absentErrorIdKey -- See Note [aBSENT_ERROR_ID] in MkCore -- absentError behaves like an honorary data constructor {- Note [exprIsHNF Tick] We can discard source annotations on HNFs as long as they aren't tick-like: scc c (\x . e) => \x . e scc c (C x1..xn) => C x1..xn So we regard these as HNFs. Tick annotations that tick are not regarded as HNF if the expression they surround is HNF, because the tick is there to tell us that the expression was evaluated, so we don't want to discard a seq on it. -} -- | Can we bind this 'CoreExpr' at the top level? exprIsTopLevelBindable :: CoreExpr -> Type -> Bool -- See Note [CoreSyn top-level string literals] -- Precondition: exprType expr = ty -- Top-level literal strings can't even be wrapped in ticks -- see Note [CoreSyn top-level string literals] in CoreSyn exprIsTopLevelBindable expr ty = not (mightBeUnliftedType ty) -- Note that 'expr' may be levity polymorphic here consequently we must use -- 'mightBeUnliftedType' rather than 'isUnliftedType' as the latter would panic. || exprIsTickedString expr -- | Check if the expression is zero or more Ticks wrapped around a literal -- string. exprIsTickedString :: CoreExpr -> Bool exprIsTickedString = isJust . exprIsTickedString_maybe -- | Extract a literal string from an expression that is zero or more Ticks -- wrapped around a literal string. Returns Nothing if the expression has a -- different shape. -- Used to "look through" Ticks in places that need to handle literal strings. exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString exprIsTickedString_maybe (Lit (LitString bs)) = Just bs exprIsTickedString_maybe (Tick t e) -- we don't tick literals with CostCentre ticks, compare to mkTick | tickishPlace t == PlaceCostCentre = Nothing | otherwise = exprIsTickedString_maybe e exprIsTickedString_maybe _ = Nothing {- ************************************************************************ * * Instantiating data constructors * * ************************************************************************ These InstPat functions go here to avoid circularity between DataCon and Id -} dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id]) dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id]) dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv"))) dataConRepFSInstPat = dataConInstPat dataConInstPat :: [FastString] -- A long enough list of FSs to use for names -> [Unique] -- An equally long list of uniques, at least one for each binder -> DataCon -> [Type] -- Types to instantiate the universally quantified tyvars -> ([TyCoVar], [Id]) -- Return instantiated variables -- dataConInstPat arg_fun fss us con inst_tys returns a tuple -- (ex_tvs, arg_ids), -- -- ex_tvs are intended to be used as binders for existential type args -- -- arg_ids are indended to be used as binders for value arguments, -- and their types have been instantiated with inst_tys and ex_tys -- The arg_ids include both evidence and -- programmer-specified arguments (both after rep-ing) -- -- Example. -- The following constructor T1 -- -- data T a where -- T1 :: forall b. Int -> b -> T(a,b) -- ... -- -- has representation type -- forall a. forall a1. forall b. (a ~ (a1,b)) => -- Int -> b -> T a -- -- dataConInstPat fss us T1 (a1',b') will return -- -- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b'']) -- -- where the double-primed variables are created with the FastStrings and -- Uniques given as fss and us dataConInstPat fss uniqs con inst_tys = ASSERT( univ_tvs `equalLength` inst_tys ) (ex_bndrs, arg_ids) where univ_tvs = dataConUnivTyVars con ex_tvs = dataConExTyCoVars con arg_tys = dataConRepArgTys con arg_strs = dataConRepStrictness con -- 1-1 with arg_tys n_ex = length ex_tvs -- split the Uniques and FastStrings (ex_uniqs, id_uniqs) = splitAt n_ex uniqs (ex_fss, id_fss) = splitAt n_ex fss -- Make the instantiating substitution for universals univ_subst = zipTvSubst univ_tvs inst_tys -- Make existential type variables, applying and extending the substitution (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst (zip3 ex_tvs ex_fss ex_uniqs) mk_ex_var :: TCvSubst -> (TyCoVar, FastString, Unique) -> (TCvSubst, TyCoVar) mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv new_tv , new_tv) where new_tv | isTyVar tv = mkTyVar (mkSysTvName uniq fs) kind | otherwise = mkCoVar (mkSystemVarName uniq fs) kind kind = Type.substTyUnchecked subst (varType tv) -- Make value vars, instantiating types arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs mk_id_var uniq fs ty str = setCaseBndrEvald str $ -- See Note [Mark evaluated arguments] mkLocalIdOrCoVar name (Type.substTy full_subst ty) where name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan {- Note [Mark evaluated arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When pattern matching on a constructor with strict fields, the binder can have an 'evaldUnfolding'. Moreover, it *should* have one, so that when loading an interface file unfolding like: data T = MkT !Int f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1 in ... } we don't want Lint to complain. The 'y' is evaluated, so the case in the RHS of the binding for 'v' is fine. But only if we *know* that 'y' is evaluated. c.f. add_evals in Simplify.simplAlt ************************************************************************ * * Equality * * ************************************************************************ -} -- | A cheap equality test which bales out fast! -- If it returns @True@ the arguments are definitely equal, -- otherwise, they may or may not be equal. -- -- See also 'exprIsBig' cheapEqExpr :: Expr b -> Expr b -> Bool cheapEqExpr = cheapEqExpr' (const False) -- | Cheap expression equality test, can ignore ticks by type. cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool cheapEqExpr' ignoreTick = go_s where go_s = go `on` stripTicksTopE ignoreTick go (Var v1) (Var v2) = v1 == v2 go (Lit lit1) (Lit lit2) = lit1 == lit2 go (Type t1) (Type t2) = t1 `eqType` t2 go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2 go (App f1 a1) (App f2 a2) = f1 `go_s` f2 && a1 `go_s` a2 go (Cast e1 t1) (Cast e2 t2) = e1 `go_s` e2 && t1 `eqCoercion` t2 go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && e1 `go_s` e2 go _ _ = False {-# INLINE go #-} {-# INLINE cheapEqExpr' #-} exprIsBig :: Expr b -> Bool -- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr' exprIsBig (Lit _) = False exprIsBig (Var _) = False exprIsBig (Type _) = False exprIsBig (Coercion _) = False exprIsBig (Lam _ e) = exprIsBig e exprIsBig (App f a) = exprIsBig f || exprIsBig a exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big! exprIsBig (Tick _ e) = exprIsBig e exprIsBig _ = True eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool -- Compares for equality, modulo alpha eqExpr in_scope e1 e2 = go (mkRnEnv2 in_scope) e1 e2 where go env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = True go _ (Lit lit1) (Lit lit2) = lit1 == lit2 go env (Type t1) (Type t2) = eqTypeX env t1 t2 go env (Coercion co1) (Coercion co2) = eqCoercionX env co1 co2 go env (Cast e1 co1) (Cast e2 co2) = eqCoercionX env co1 co2 && go env e1 e2 go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2 go env (Tick n1 e1) (Tick n2 e2) = eqTickish env n1 n2 && go env e1 e2 go env (Lam b1 e1) (Lam b2 e2) = eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination && go (rnBndr2 env b1 b2) e1 e2 go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) = go env r1 r2 -- No need to check binder types, since RHSs match && go (rnBndr2 env v1 v2) e1 e2 go env (Let (Rec ps1) e1) (Let (Rec ps2) e2) = equalLength ps1 ps2 && all2 (go env') rs1 rs2 && go env' e1 e2 where (bs1,rs1) = unzip ps1 (bs2,rs2) = unzip ps2 env' = rnBndrs2 env bs1 bs2 go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) | null a1 -- See Note [Empty case alternatives] in TrieMap = null a2 && go env e1 e2 && eqTypeX env t1 t2 | otherwise = go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 go _ _ _ = False ----------- go_alt env (c1, bs1, e1) (c2, bs2, e2) = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool eqTickish env (Breakpoint lid lids) (Breakpoint rid rids) = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids eqTickish _ l r = l == r -- | Finds differences between core expressions, modulo alpha and -- renaming. Setting @top@ means that the @IdInfo@ of bindings will be -- checked for differences as well. diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc] diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = [] diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = [] diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = [] diffExpr _ env (Coercion co1) (Coercion co2) | eqCoercionX env co1 co2 = [] diffExpr top env (Cast e1 co1) (Cast e2 co2) | eqCoercionX env co1 co2 = diffExpr top env e1 e2 diffExpr top env (Tick n1 e1) e2 | not (tickishIsCode n1) = diffExpr top env e1 e2 diffExpr top env e1 (Tick n2 e2) | not (tickishIsCode n2) = diffExpr top env e1 e2 diffExpr top env (Tick n1 e1) (Tick n2 e2) | eqTickish env n1 n2 = diffExpr top env e1 e2 -- The error message of failed pattern matches will contain -- generated names, which are allowed to differ. diffExpr _ _ (App (App (Var absent) _) _) (App (App (Var absent2) _) _) | isBottomingId absent && isBottomingId absent2 = [] diffExpr top env (App f1 a1) (App f2 a2) = diffExpr top env f1 f2 ++ diffExpr top env a1 a2 diffExpr top env (Lam b1 e1) (Lam b2 e2) | eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination = diffExpr top (rnBndr2 env b1 b2) e1 e2 diffExpr top env (Let bs1 e1) (Let bs2 e2) = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2]) in ds ++ diffExpr top env' e1 e2 diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2 -- See Note [Empty case alternatives] in TrieMap = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) where env' = rnBndr2 env b1 b2 diffAlt (c1, bs1, e1) (c2, bs2, e2) | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 diffExpr _ _ e1 e2 = [fsep [ppr e1, text "/=", ppr e2]] -- | Finds differences between core bindings, see @diffExpr@. -- -- The main problem here is that while we expect the binds to have the -- same order in both lists, this is not guaranteed. To do this -- properly we'd either have to do some sort of unification or check -- all possible mappings, which would be seriously expensive. So -- instead we simply match single bindings as far as we can. This -- leaves us just with mutually recursive and/or mismatching bindings, -- which we then speculatively match by ordering them. It's by no means -- perfect, but gets the job done well enough. diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] -> ([SDoc], RnEnv2) diffBinds top env binds1 = go (length binds1) env binds1 where go _ env [] [] = ([], env) go fuel env binds1 binds2 -- No binds left to compare? Bail out early. | null binds1 || null binds2 = (warn env binds1 binds2, env) -- Iterated over all binds without finding a match? Then -- try speculatively matching binders by order. | fuel == 0 = if not $ env `inRnEnvL` fst (head binds1) then let env' = uncurry (rnBndrs2 env) $ unzip $ zip (sort $ map fst binds1) (sort $ map fst binds2) in go (length binds1) env' binds1 binds2 -- If we have already tried that, give up else (warn env binds1 binds2, env) go fuel env ((bndr1,expr1):binds1) binds2 | let matchExpr (bndr,expr) = (not top || null (diffIdInfo env bndr bndr1)) && null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr) , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2 = go (length binds1) (rnBndr2 env bndr1 bndr2) binds1 (binds2l ++ binds2r) | otherwise -- No match, so push back (FIXME O(n^2)) = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2 go _ _ _ _ = panic "diffBinds: impossible" -- GHC isn't smart enough -- We have tried everything, but couldn't find a good match. So -- now we just return the comparison results when we pair up -- the binds in a pseudo-random order. warn env binds1 binds2 = concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++ unmatched "unmatched left-hand:" (drop l binds1') ++ unmatched "unmatched right-hand:" (drop l binds2') where binds1' = sortBy (comparing fst) binds1 binds2' = sortBy (comparing fst) binds2 l = min (length binds1') (length binds2') unmatched _ [] = [] unmatched txt bs = [text txt $$ ppr (Rec bs)] diffBind env (bndr1,expr1) (bndr2,expr2) | ds@(_:_) <- diffExpr top env expr1 expr2 = locBind "in binding" bndr1 bndr2 ds | otherwise = diffIdInfo env bndr1 bndr2 -- | Find differences in @IdInfo@. We will especially check whether -- the unfoldings match, if present (see @diffUnfold@). diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc] diffIdInfo env bndr1 bndr2 | arityInfo info1 == arityInfo info2 && cafInfo info1 == cafInfo info2 && oneShotInfo info1 == oneShotInfo info2 && inlinePragInfo info1 == inlinePragInfo info2 && occInfo info1 == occInfo info2 && demandInfo info1 == demandInfo info2 && callArityInfo info1 == callArityInfo info2 && levityInfo info1 == levityInfo info2 = locBind "in unfolding of" bndr1 bndr2 $ diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2) | otherwise = locBind "in Id info of" bndr1 bndr2 [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]] where info1 = idInfo bndr1; info2 = idInfo bndr2 -- | Find differences in unfoldings. Note that we will not check for -- differences of @IdInfo@ in unfoldings, as this is generally -- redundant, and can lead to an exponential blow-up in complexity. diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc] diffUnfold _ NoUnfolding NoUnfolding = [] diffUnfold _ BootUnfolding BootUnfolding = [] diffUnfold _ (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = [] diffUnfold env (DFunUnfolding bs1 c1 a1) (DFunUnfolding bs2 c2 a2) | c1 == c2 && equalLength bs1 bs2 = concatMap (uncurry (diffExpr False env')) (zip a1 a2) where env' = rnBndrs2 env bs1 bs2 diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1) (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2) | v1 == v2 && cl1 == cl2 && wf1 == wf2 && x1 == x2 && g1 == g2 = diffExpr False env t1 t2 diffUnfold _ uf1 uf2 = [fsep [ppr uf1, text "/=", ppr uf2]] -- | Add location information to diff messages locBind :: String -> Var -> Var -> [SDoc] -> [SDoc] locBind loc b1 b2 diffs = map addLoc diffs where addLoc d = d $$ nest 2 (parens (text loc <+> bindLoc)) bindLoc | b1 == b2 = ppr b1 | otherwise = ppr b1 <> char '/' <> ppr b2 {- ************************************************************************ * * Eta reduction * * ************************************************************************ Note [Eta reduction conditions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We try for eta reduction here, but *only* if we get all the way to an trivial expression. We don't want to remove extra lambdas unless we are going to avoid allocating this thing altogether. There are some particularly delicate points here: * We want to eta-reduce if doing so leaves a trivial expression, *including* a cast. For example \x. f |> co --> f |> co (provided co doesn't mention x) * Eta reduction is not valid in general: \x. bot /= bot This matters, partly for old-fashioned correctness reasons but, worse, getting it wrong can yield a seg fault. Consider f = \x.f x h y = case (case y of { True -> f `seq` True; False -> False }) of True -> ...; False -> ... If we (unsoundly) eta-reduce f to get f=f, the strictness analyser says f=bottom, and replaces the (f `seq` True) with just (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands the definition again, so that it does not termninate after all. Result: seg-fault because the boolean case actually gets a function value. See #1947. So it's important to do the right thing. * Note [Arity care]: we need to be careful if we just look at f's arity. Currently (Dec07), f's arity is visible in its own RHS (see Note [Arity robustness] in SimplEnv) so we must *not* trust the arity when checking that 'f' is a value. Otherwise we will eta-reduce f = \x. f x to f = f Which might change a terminating program (think (f `seq` e)) to a non-terminating one. So we check for being a loop breaker first. However for GlobalIds we can look at the arity; and for primops we must, since they have no unfolding. * Regardless of whether 'f' is a value, we always want to reduce (/\a -> f a) to f This came up in a RULE: foldr (build (/\a -> g a)) did not match foldr (build (/\b -> ...something complex...)) The type checker can insert these eta-expanded versions, with both type and dictionary lambdas; hence the slightly ad-hoc isDictId * Never *reduce* arity. For example f = \xy. g x y Then if h has arity 1 we don't want to eta-reduce because then f's arity would decrease, and that is bad These delicacies are why we don't use exprIsTrivial and exprIsHNF here. Alas. Note [Eta reduction with casted arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (\(x:t3). f (x |> g)) :: t3 -> t2 where f :: t1 -> t2 g :: t3 ~ t1 This should be eta-reduced to f |> (sym g -> t2) So we need to accumulate a coercion, pushing it inward (past variable arguments only) thus: f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x f (x:t) |> co --> (f |> (t -> co)) x f @ a |> co --> (f |> (forall a.co)) @ a f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2) These are the equations for ok_arg. It's true that we could also hope to eta reduce these: (\xy. (f x |> g) y) (\xy. (f x y) |> g) But the simplifier pushes those casts outwards, so we don't need to address that here. -} -- When updating this function, make sure to update -- CorePrep.tryEtaReducePrep as well! tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr tryEtaReduce bndrs body = go (reverse bndrs) body (mkRepReflCo (exprType body)) where incoming_arity = count isId bndrs go :: [Var] -- Binders, innermost first, types [a3,a2,a1] -> CoreExpr -- Of type tr -> Coercion -- Of type tr ~ ts -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts -- See Note [Eta reduction with casted arguments] -- for why we have an accumulating coercion go [] fun co | ok_fun fun , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co , not (any (`elemVarSet` used_vars) bndrs) = Just (mkCast fun co) -- Check for any of the binders free in the result -- including the accumulated coercion go bs (Tick t e) co | tickishFloatable t = fmap (Tick t) $ go bs e co -- Float app ticks: \x -> Tick t (e x) ==> Tick t e go (b : bs) (App fun arg) co | Just (co', ticks) <- ok_arg b arg co = fmap (flip (foldr mkTick) ticks) $ go bs fun co' -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e go _ _ _ = Nothing -- Failure! --------------- -- Note [Eta reduction conditions] ok_fun (App fun (Type {})) = ok_fun fun ok_fun (Cast fun _) = ok_fun fun ok_fun (Tick _ expr) = ok_fun expr ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs ok_fun _fun = False --------------- ok_fun_id fun = fun_arity fun >= incoming_arity --------------- fun_arity fun -- See Note [Arity care] | isLocalId fun , isStrongLoopBreaker (idOccInfo fun) = 0 | arity > 0 = arity | isEvaldUnfolding (idUnfolding fun) = 1 -- See Note [Eta reduction of an eval'd function] | otherwise = 0 where arity = idArity fun --------------- ok_lam v = isTyVar v || isEvVar v --------------- ok_arg :: Var -- Of type bndr_t -> CoreExpr -- Of type arg_t -> Coercion -- Of kind (t1~t2) -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) -- (and similarly for tyvars, coercion args) , [Tickish Var]) -- See Note [Eta reduction with casted arguments] ok_arg bndr (Type ty) co | Just tv <- getTyVar_maybe ty , bndr == tv = Just (mkHomoForAllCos [tv] co, []) ok_arg bndr (Var v) co | bndr == v = let reflCo = mkRepReflCo (idType bndr) in Just (mkFunCo Representational reflCo co, []) ok_arg bndr (Cast e co_arg) co | (ticks, Var v) <- stripTicksTop tickishFloatable e , bndr == v = Just (mkFunCo Representational (mkSymCo co_arg) co, ticks) -- The simplifier combines multiple casts into one, -- so we can have a simple-minded pattern match here ok_arg bndr (Tick t arg) co | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co = Just (co', t:ticks) ok_arg _ _ _ = Nothing {- Note [Eta reduction of an eval'd function] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In Haskell it is not true that f = \x. f x because f might be bottom, and 'seq' can distinguish them. But it *is* true that f = f `seq` \x. f x and we'd like to simplify the latter to the former. This amounts to the rule that * when there is just *one* value argument, * f is not bottom we can eta-reduce \x. f x ===> f This turned up in #7542. ************************************************************************ * * \subsection{Determining non-updatable right-hand-sides} * * ************************************************************************ Top-level constructor applications can usually be allocated statically, but they can't if the constructor, or any of the arguments, come from another DLL (because we can't refer to static labels in other DLLs). If this happens we simply make the RHS into an updatable thunk, and 'execute' it rather than allocating it statically. -} -- | This function is called only on *top-level* right-hand sides. -- Returns @True@ if the RHS can be allocated statically in the output, -- with no thunks involved at all. rhsIsStatic :: Platform -> (Name -> Bool) -- Which names are dynamic -> (LitNumType -> Integer -> Maybe CoreExpr) -- Desugaring for some literals (disgusting) -- C.f. Note [Disgusting computation of CafRefs] in TidyPgm -> CoreExpr -> Bool -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or -- refers to, CAFs; (ii) in CoreToStg to decide whether to put an -- update flag on it and (iii) in DsExpr to decide how to expand -- list literals -- -- The basic idea is that rhsIsStatic returns True only if the RHS is -- (a) a value lambda -- (b) a saturated constructor application with static args -- -- BUT watch out for -- (i) Any cross-DLL references kill static-ness completely -- because they must be 'executed' not statically allocated -- ("DLL" here really only refers to Windows DLLs, on other platforms, -- this is not necessary) -- -- (ii) We treat partial applications as redexes, because in fact we -- make a thunk for them that runs and builds a PAP -- at run-time. The only applications that are treated as -- static are *saturated* applications of constructors. -- We used to try to be clever with nested structures like this: -- ys = (:) w ((:) w []) -- on the grounds that CorePrep will flatten ANF-ise it later. -- But supporting this special case made the function much more -- complicated, because the special case only applies if there are no -- enclosing type lambdas: -- ys = /\ a -> Foo (Baz ([] a)) -- Here the nested (Baz []) won't float out to top level in CorePrep. -- -- But in fact, even without -O, nested structures at top level are -- flattened by the simplifier, so we don't need to be super-clever here. -- -- Examples -- -- f = \x::Int. x+7 TRUE -- p = (True,False) TRUE -- -- d = (fst p, False) FALSE because there's a redex inside -- (this particular one doesn't happen but...) -- -- h = D# (1.0## /## 2.0##) FALSE (redex again) -- n = /\a. Nil a TRUE -- -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex) -- -- -- This is a bit like CoreUtils.exprIsHNF, with the following differences: -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) -- -- b) (C x xs), where C is a constructor is updatable if the application is -- dynamic -- -- c) don't look through unfolding of f in (f x). rhsIsStatic platform is_dynamic_name cvt_literal rhs = is_static False rhs where is_static :: Bool -- True <=> in a constructor argument; must be atomic -> CoreExpr -> Bool is_static False (Lam b e) = isRuntimeVar b || is_static False e is_static in_arg (Tick n e) = not (tickishIsCode n) && is_static in_arg e is_static in_arg (Cast e _) = is_static in_arg e is_static _ (Coercion {}) = True -- Behaves just like a literal is_static in_arg (Lit (LitNumber nt i _)) = case cvt_literal nt i of Just e -> is_static in_arg e Nothing -> True is_static _ (Lit (LitLabel {})) = False is_static _ (Lit _) = True -- A LitLabel (foreign import "&foo") in an argument -- prevents a constructor application from being static. The -- reason is that it might give rise to unresolvable symbols -- in the object file: under Linux, references to "weak" -- symbols from the data segment give rise to "unresolvable -- relocation" errors at link time This might be due to a bug -- in the linker, but we'll work around it here anyway. -- SDM 24/2/2004 is_static in_arg other_expr = go other_expr 0 where go (Var f) n_val_args | (platformOS platform /= OSMinGW32) || not (is_dynamic_name (idName f)) = saturated_data_con f n_val_args || (in_arg && n_val_args == 0) -- A naked un-applied variable is *not* deemed a static RHS -- E.g. f = g -- Reason: better to update so that the indirection gets shorted -- out, and the true value will be seen -- NB: if you change this, you'll break the invariant that THUNK_STATICs -- are always updatable. If you do so, make sure that non-updatable -- ones have enough space for their static link field! go (App f a) n_val_args | isTypeArg a = go f n_val_args | not in_arg && is_static True a = go f (n_val_args + 1) -- The (not in_arg) checks that we aren't in a constructor argument; -- if we are, we don't allow (value) applications of any sort -- -- NB. In case you wonder, args are sometimes not atomic. eg. -- x = D# (1.0## /## 2.0##) -- can't float because /## can fail. go (Tick n f) n_val_args = not (tickishIsCode n) && go f n_val_args go (Cast e _) n_val_args = go e n_val_args go _ _ = False saturated_data_con f n_val_args = case isDataConWorkId_maybe f of Just dc -> n_val_args == dataConRepArity dc Nothing -> False {- ************************************************************************ * * \subsection{Type utilities} * * ************************************************************************ -} -- | True if the type has no non-bottom elements, e.g. when it is an empty -- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool. -- See Note [Bottoming expressions] -- -- See Note [No alternatives lint check] for another use of this function. isEmptyTy :: Type -> Bool isEmptyTy ty -- Data types where, given the particular type parameters, no data -- constructor matches, are empty. -- This includes data types with no constructors, e.g. Data.Void.Void. | Just (tc, inst_tys) <- splitTyConApp_maybe ty , Just dcs <- tyConDataCons_maybe tc , all (dataConCannotMatch inst_tys) dcs = True | otherwise = False {- ***************************************************** * * StaticPtr * ***************************************************** -} -- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields -- @Just (makeStatic, t, srcLoc, e)@. -- -- Returns @Nothing@ for every other expression. collectMakeStaticArgs :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr) collectMakeStaticArgs e | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e , idName b == makeStaticName = Just (fun, t, loc, arg) collectMakeStaticArgs _ = Nothing {- ************************************************************************ * * \subsection{Join points} * * ************************************************************************ -} -- | Does this binding bind a join point (or a recursive group of join points)? isJoinBind :: CoreBind -> Bool isJoinBind (NonRec b _) = isJoinId b isJoinBind (Rec ((b, _) : _)) = isJoinId b isJoinBind _ = False ghc-lib-parser-8.10.2.20200808/compiler/profiling/CostCentre.hs0000644000000000000000000002747013713635745021731 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module CostCentre ( CostCentre(..), CcName, CCFlavour(..), -- All abstract except to friend: ParseIface.y CostCentreStack, CollectedCCs, emptyCollectedCCs, collectCC, currentCCS, dontCareCCS, isCurrentCCS, maybeSingletonCCS, mkUserCC, mkAutoCC, mkAllCafsCC, mkSingletonCCS, isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule, pprCostCentreCore, costCentreUserName, costCentreUserNameFS, costCentreSrcSpan, cmpCostCentre -- used for removing dups in a list ) where import GhcPrelude import Binary import Var import Name import Module import Unique import Outputable import SrcLoc import FastString import Util import CostCentreState import Data.Data ----------------------------------------------------------------------------- -- Cost Centres -- | A Cost Centre is a single @{-# SCC #-}@ annotation. data CostCentre = NormalCC { cc_flavour :: CCFlavour, -- ^ Two cost centres may have the same name and -- module but different SrcSpans, so we need a way to -- distinguish them easily and give them different -- object-code labels. So every CostCentre has an -- associated flavour that indicates how it was -- generated, and flavours that allow multiple instances -- of the same name and module have a deterministic 0-based -- index. cc_name :: CcName, -- ^ Name of the cost centre itself cc_mod :: Module, -- ^ Name of module defining this CC. cc_loc :: SrcSpan } | AllCafsCC { cc_mod :: Module, -- Name of module defining this CC. cc_loc :: SrcSpan } deriving Data type CcName = FastString -- | The flavour of a cost centre. -- -- Index fields represent 0-based indices giving source-code ordering of -- centres with the same module, name, and flavour. data CCFlavour = CafCC -- ^ Auto-generated top-level thunk | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage deriving (Eq, Ord, Data) -- | Extract the index from a flavour flavourIndex :: CCFlavour -> Int flavourIndex CafCC = 0 flavourIndex (ExprCC x) = unCostCentreIndex x flavourIndex (DeclCC x) = unCostCentreIndex x flavourIndex (HpcCC x) = unCostCentreIndex x instance Eq CostCentre where c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } instance Ord CostCentre where compare = cmpCostCentre cmpCostCentre :: CostCentre -> CostCentre -> Ordering cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) = m1 `compare` m2 cmpCostCentre NormalCC {cc_flavour = f1, cc_mod = m1, cc_name = n1} NormalCC {cc_flavour = f2, cc_mod = m2, cc_name = n2} -- first key is module name, then centre name, then flavour = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2) cmpCostCentre other_1 other_2 = let tag1 = tag_CC other_1 tag2 = tag_CC other_2 in if tag1 < tag2 then LT else GT where tag_CC :: CostCentre -> Int tag_CC (NormalCC {}) = 0 tag_CC (AllCafsCC {}) = 1 ----------------------------------------------------------------------------- -- Predicates on CostCentre isCafCC :: CostCentre -> Bool isCafCC (AllCafsCC {}) = True isCafCC (NormalCC {cc_flavour = CafCC}) = True isCafCC _ = False -- | Is this a cost-centre which records scc counts isSccCountCC :: CostCentre -> Bool isSccCountCC cc | isCafCC cc = False | otherwise = True -- | Is this a cost-centre which can be sccd ? sccAbleCC :: CostCentre -> Bool sccAbleCC cc | isCafCC cc = False | otherwise = True ccFromThisModule :: CostCentre -> Module -> Bool ccFromThisModule cc m = cc_mod cc == m ----------------------------------------------------------------------------- -- Building cost centres mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre mkUserCC cc_name mod loc flavour = NormalCC { cc_name = cc_name, cc_mod = mod, cc_loc = loc, cc_flavour = flavour } mkAutoCC :: Id -> Module -> CostCentre mkAutoCC id mod = NormalCC { cc_name = str, cc_mod = mod, cc_loc = nameSrcSpan (getName id), cc_flavour = CafCC } where name = getName id -- beware: only external names are guaranteed to have unique -- Occnames. If the name is not external, we must append its -- Unique. -- See bug #249, tests prof001, prof002, also #2411 str | isExternalName name = occNameFS (getOccName id) | otherwise = occNameFS (getOccName id) `appendFS` mkFastString ('_' : show (getUnique name)) mkAllCafsCC :: Module -> SrcSpan -> CostCentre mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } ----------------------------------------------------------------------------- -- Cost Centre Stacks -- | A Cost Centre Stack is something that can be attached to a closure. -- This is either: -- -- * the current cost centre stack (CCCS) -- * a pre-defined cost centre stack (there are several -- pre-defined CCSs, see below). data CostCentreStack = CurrentCCS -- Pinned on a let(rec)-bound -- thunk/function/constructor, this says that the -- cost centre to be attached to the object, when it -- is allocated, is whatever is in the -- current-cost-centre-stack register. | DontCareCCS -- We need a CCS to stick in static closures -- (for data), but we *don't* expect them to -- accumulate any costs. But we still need -- the placeholder. This CCS is it. | SingletonCCS CostCentre deriving (Eq, Ord) -- needed for Ord on CLabel -- synonym for triple which describes the cost centre info in the generated -- code for a module. type CollectedCCs = ( [CostCentre] -- local cost-centres that need to be decl'd , [CostCentreStack] -- pre-defined "singleton" cost centre stacks ) emptyCollectedCCs :: CollectedCCs emptyCollectedCCs = ([], []) collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs collectCC cc ccs (c, cs) = (cc : c, ccs : cs) currentCCS, dontCareCCS :: CostCentreStack currentCCS = CurrentCCS dontCareCCS = DontCareCCS ----------------------------------------------------------------------------- -- Predicates on Cost-Centre Stacks isCurrentCCS :: CostCentreStack -> Bool isCurrentCCS CurrentCCS = True isCurrentCCS _ = False isCafCCS :: CostCentreStack -> Bool isCafCCS (SingletonCCS cc) = isCafCC cc isCafCCS _ = False maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre maybeSingletonCCS (SingletonCCS cc) = Just cc maybeSingletonCCS _ = Nothing mkSingletonCCS :: CostCentre -> CostCentreStack mkSingletonCCS cc = SingletonCCS cc ----------------------------------------------------------------------------- -- Printing Cost Centre Stacks. -- The outputable instance for CostCentreStack prints the CCS as a C -- expression. instance Outputable CostCentreStack where ppr CurrentCCS = text "CCCS" ppr DontCareCCS = text "CCS_DONT_CARE" ppr (SingletonCCS cc) = ppr cc <> text "_ccs" ----------------------------------------------------------------------------- -- Printing Cost Centres -- -- There are several different ways in which we might want to print a -- cost centre: -- -- - the name of the cost centre, for profiling output (a C string) -- - the label, i.e. C label for cost centre in .hc file. -- - the debugging name, for output in -ddump things -- - the interface name, for printing in _scc_ exprs in iface files. -- -- The last 3 are derived from costCentreStr below. The first is given -- by costCentreName. instance Outputable CostCentre where ppr cc = getPprStyle $ \ sty -> if codeStyle sty then ppCostCentreLbl cc else text (costCentreUserName cc) -- Printing in Core pprCostCentreCore :: CostCentre -> SDoc pprCostCentreCore (AllCafsCC {cc_mod = m}) = text "__sccC" <+> braces (ppr m) pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n, cc_mod = m, cc_loc = loc}) = text "__scc" <+> braces (hsep [ ppr m <> char '.' <> ftext n, pprFlavourCore flavour, whenPprDebug (ppr loc) ]) -- ^ Print a flavour in Core pprFlavourCore :: CCFlavour -> SDoc pprFlavourCore CafCC = text "__C" pprFlavourCore f = pprIdxCore $ flavourIndex f -- ^ Print a flavour's index in Core pprIdxCore :: Int -> SDoc pprIdxCore 0 = empty pprIdxCore idx = whenPprDebug $ ppr idx -- Printing as a C label ppCostCentreLbl :: CostCentre -> SDoc ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m}) = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> ppFlavourLblComponent f <> text "_cc" -- ^ Print the flavour component of a C label ppFlavourLblComponent :: CCFlavour -> SDoc ppFlavourLblComponent CafCC = text "CAF" ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i -- ^ Print the flavour index component of a C label ppIdxLblComponent :: CostCentreIndex -> SDoc ppIdxLblComponent n = case unCostCentreIndex n of 0 -> empty n -> ppr n -- This is the name to go in the user-displayed string, -- recorded in the cost centre declaration costCentreUserName :: CostCentre -> String costCentreUserName = unpackFS . costCentreUserNameFS costCentreUserNameFS :: CostCentre -> FastString costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF" costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf}) = case is_caf of CafCC -> mkFastString "CAF:" `appendFS` name _ -> name costCentreSrcSpan :: CostCentre -> SrcSpan costCentreSrcSpan = cc_loc instance Binary CCFlavour where put_ bh CafCC = do putByte bh 0 put_ bh (ExprCC i) = do putByte bh 1 put_ bh i put_ bh (DeclCC i) = do putByte bh 2 put_ bh i put_ bh (HpcCC i) = do putByte bh 3 put_ bh i get bh = do h <- getByte bh case h of 0 -> do return CafCC 1 -> ExprCC <$> get bh 2 -> DeclCC <$> get bh _ -> HpcCC <$> get bh instance Binary CostCentre where put_ bh (NormalCC aa ab ac _ad) = do putByte bh 0 put_ bh aa put_ bh ab put_ bh ac put_ bh (AllCafsCC ae _af) = do putByte bh 1 put_ bh ae get bh = do h <- getByte bh case h of 0 -> do aa <- get bh ab <- get bh ac <- get bh return (NormalCC aa ab ac noSrcSpan) _ -> do ae <- get bh return (AllCafsCC ae noSrcSpan) -- We ignore the SrcSpans in CostCentres when we serialise them, -- and set the SrcSpans to noSrcSpan when deserialising. This is -- ok, because we only need the SrcSpan when declaring the -- CostCentre in the original module, it is not used by importing -- modules. ghc-lib-parser-8.10.2.20200808/compiler/profiling/CostCentreState.hs0000644000000000000000000000220013713635745022712 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module CostCentreState ( CostCentreState, newCostCentreState , CostCentreIndex, unCostCentreIndex, getCCIndex ) where import GhcPrelude import FastString import FastStringEnv import Data.Data import Binary -- | Per-module state for tracking cost centre indices. -- -- See documentation of 'CostCentre.cc_flavour' for more details. newtype CostCentreState = CostCentreState (FastStringEnv Int) -- | Initialize cost centre state. newCostCentreState :: CostCentreState newCostCentreState = CostCentreState emptyFsEnv -- | An index into a given cost centre module,name,flavour set newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int } deriving (Eq, Ord, Data, Binary) -- | Get a new index for a given cost centre name. getCCIndex :: FastString -> CostCentreState -> (CostCentreIndex, CostCentreState) getCCIndex nm (CostCentreState m) = (CostCentreIndex idx, CostCentreState m') where m_idx = lookupFsEnv m nm idx = maybe 0 id m_idx m' = extendFsEnv m nm (idx + 1) ghc-lib-parser-8.10.2.20200808/compiler/parser/Ctype.hs0000644000000000000000000002040313713635745020234 0ustar0000000000000000-- Character classification {-# LANGUAGE CPP #-} module Ctype ( is_ident -- Char# -> Bool , is_symbol -- Char# -> Bool , is_any -- Char# -> Bool , is_space -- Char# -> Bool , is_lower -- Char# -> Bool , is_upper -- Char# -> Bool , is_digit -- Char# -> Bool , is_alphanum -- Char# -> Bool , is_decdigit, is_hexdigit, is_octdigit, is_bindigit , hexDigit, octDecDigit ) where #include "GhclibHsVersions.h" import GhcPrelude import Data.Bits ( Bits((.&.),(.|.)) ) import Data.Char ( ord, chr ) import Data.Word import Panic -- Bit masks cIdent, cSymbol, cAny, cSpace, cLower, cUpper, cDigit :: Word8 cIdent = 1 cSymbol = 2 cAny = 4 cSpace = 8 cLower = 16 cUpper = 32 cDigit = 64 -- | The predicates below look costly, but aren't, GHC+GCC do a great job -- at the big case below. {-# INLINABLE is_ctype #-} is_ctype :: Word8 -> Char -> Bool is_ctype mask c = (charType c .&. mask) /= 0 is_ident, is_symbol, is_any, is_space, is_lower, is_upper, is_digit, is_alphanum :: Char -> Bool is_ident = is_ctype cIdent is_symbol = is_ctype cSymbol is_any = is_ctype cAny is_space = is_ctype cSpace is_lower = is_ctype cLower is_upper = is_ctype cUpper is_digit = is_ctype cDigit is_alphanum = is_ctype (cLower+cUpper+cDigit) -- Utils hexDigit :: Char -> Int hexDigit c | is_decdigit c = ord c - ord '0' | otherwise = ord (to_lower c) - ord 'a' + 10 octDecDigit :: Char -> Int octDecDigit c = ord c - ord '0' is_decdigit :: Char -> Bool is_decdigit c = c >= '0' && c <= '9' is_hexdigit :: Char -> Bool is_hexdigit c = is_decdigit c || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F') is_octdigit :: Char -> Bool is_octdigit c = c >= '0' && c <= '7' is_bindigit :: Char -> Bool is_bindigit c = c == '0' || c == '1' to_lower :: Char -> Char to_lower c | c >= 'A' && c <= 'Z' = chr (ord c - (ord 'A' - ord 'a')) | otherwise = c charType :: Char -> Word8 charType c = case c of '\0' -> 0 -- \000 '\1' -> 0 -- \001 '\2' -> 0 -- \002 '\3' -> 0 -- \003 '\4' -> 0 -- \004 '\5' -> 0 -- \005 '\6' -> 0 -- \006 '\7' -> 0 -- \007 '\8' -> 0 -- \010 '\9' -> cSpace -- \t (not allowed in strings, so !cAny) '\10' -> cSpace -- \n (ditto) '\11' -> cSpace -- \v (ditto) '\12' -> cSpace -- \f (ditto) '\13' -> cSpace -- ^M (ditto) '\14' -> 0 -- \016 '\15' -> 0 -- \017 '\16' -> 0 -- \020 '\17' -> 0 -- \021 '\18' -> 0 -- \022 '\19' -> 0 -- \023 '\20' -> 0 -- \024 '\21' -> 0 -- \025 '\22' -> 0 -- \026 '\23' -> 0 -- \027 '\24' -> 0 -- \030 '\25' -> 0 -- \031 '\26' -> 0 -- \032 '\27' -> 0 -- \033 '\28' -> 0 -- \034 '\29' -> 0 -- \035 '\30' -> 0 -- \036 '\31' -> 0 -- \037 '\32' -> cAny .|. cSpace -- '\33' -> cAny .|. cSymbol -- ! '\34' -> cAny -- " '\35' -> cAny .|. cSymbol -- # '\36' -> cAny .|. cSymbol -- $ '\37' -> cAny .|. cSymbol -- % '\38' -> cAny .|. cSymbol -- & '\39' -> cAny .|. cIdent -- ' '\40' -> cAny -- ( '\41' -> cAny -- ) '\42' -> cAny .|. cSymbol -- * '\43' -> cAny .|. cSymbol -- + '\44' -> cAny -- , '\45' -> cAny .|. cSymbol -- - '\46' -> cAny .|. cSymbol -- . '\47' -> cAny .|. cSymbol -- / '\48' -> cAny .|. cIdent .|. cDigit -- 0 '\49' -> cAny .|. cIdent .|. cDigit -- 1 '\50' -> cAny .|. cIdent .|. cDigit -- 2 '\51' -> cAny .|. cIdent .|. cDigit -- 3 '\52' -> cAny .|. cIdent .|. cDigit -- 4 '\53' -> cAny .|. cIdent .|. cDigit -- 5 '\54' -> cAny .|. cIdent .|. cDigit -- 6 '\55' -> cAny .|. cIdent .|. cDigit -- 7 '\56' -> cAny .|. cIdent .|. cDigit -- 8 '\57' -> cAny .|. cIdent .|. cDigit -- 9 '\58' -> cAny .|. cSymbol -- : '\59' -> cAny -- ; '\60' -> cAny .|. cSymbol -- < '\61' -> cAny .|. cSymbol -- = '\62' -> cAny .|. cSymbol -- > '\63' -> cAny .|. cSymbol -- ? '\64' -> cAny .|. cSymbol -- @ '\65' -> cAny .|. cIdent .|. cUpper -- A '\66' -> cAny .|. cIdent .|. cUpper -- B '\67' -> cAny .|. cIdent .|. cUpper -- C '\68' -> cAny .|. cIdent .|. cUpper -- D '\69' -> cAny .|. cIdent .|. cUpper -- E '\70' -> cAny .|. cIdent .|. cUpper -- F '\71' -> cAny .|. cIdent .|. cUpper -- G '\72' -> cAny .|. cIdent .|. cUpper -- H '\73' -> cAny .|. cIdent .|. cUpper -- I '\74' -> cAny .|. cIdent .|. cUpper -- J '\75' -> cAny .|. cIdent .|. cUpper -- K '\76' -> cAny .|. cIdent .|. cUpper -- L '\77' -> cAny .|. cIdent .|. cUpper -- M '\78' -> cAny .|. cIdent .|. cUpper -- N '\79' -> cAny .|. cIdent .|. cUpper -- O '\80' -> cAny .|. cIdent .|. cUpper -- P '\81' -> cAny .|. cIdent .|. cUpper -- Q '\82' -> cAny .|. cIdent .|. cUpper -- R '\83' -> cAny .|. cIdent .|. cUpper -- S '\84' -> cAny .|. cIdent .|. cUpper -- T '\85' -> cAny .|. cIdent .|. cUpper -- U '\86' -> cAny .|. cIdent .|. cUpper -- V '\87' -> cAny .|. cIdent .|. cUpper -- W '\88' -> cAny .|. cIdent .|. cUpper -- X '\89' -> cAny .|. cIdent .|. cUpper -- Y '\90' -> cAny .|. cIdent .|. cUpper -- Z '\91' -> cAny -- [ '\92' -> cAny .|. cSymbol -- backslash '\93' -> cAny -- ] '\94' -> cAny .|. cSymbol -- ^ '\95' -> cAny .|. cIdent .|. cLower -- _ '\96' -> cAny -- ` '\97' -> cAny .|. cIdent .|. cLower -- a '\98' -> cAny .|. cIdent .|. cLower -- b '\99' -> cAny .|. cIdent .|. cLower -- c '\100' -> cAny .|. cIdent .|. cLower -- d '\101' -> cAny .|. cIdent .|. cLower -- e '\102' -> cAny .|. cIdent .|. cLower -- f '\103' -> cAny .|. cIdent .|. cLower -- g '\104' -> cAny .|. cIdent .|. cLower -- h '\105' -> cAny .|. cIdent .|. cLower -- i '\106' -> cAny .|. cIdent .|. cLower -- j '\107' -> cAny .|. cIdent .|. cLower -- k '\108' -> cAny .|. cIdent .|. cLower -- l '\109' -> cAny .|. cIdent .|. cLower -- m '\110' -> cAny .|. cIdent .|. cLower -- n '\111' -> cAny .|. cIdent .|. cLower -- o '\112' -> cAny .|. cIdent .|. cLower -- p '\113' -> cAny .|. cIdent .|. cLower -- q '\114' -> cAny .|. cIdent .|. cLower -- r '\115' -> cAny .|. cIdent .|. cLower -- s '\116' -> cAny .|. cIdent .|. cLower -- t '\117' -> cAny .|. cIdent .|. cLower -- u '\118' -> cAny .|. cIdent .|. cLower -- v '\119' -> cAny .|. cIdent .|. cLower -- w '\120' -> cAny .|. cIdent .|. cLower -- x '\121' -> cAny .|. cIdent .|. cLower -- y '\122' -> cAny .|. cIdent .|. cLower -- z '\123' -> cAny -- { '\124' -> cAny .|. cSymbol -- | '\125' -> cAny -- } '\126' -> cAny .|. cSymbol -- ~ '\127' -> 0 -- \177 _ -> panic ("charType: " ++ show c) ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/DataCon.hs0000644000000000000000000016656713713635744021320 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1998 \section[DataCon]{@DataCon@: Data Constructors} -} {-# LANGUAGE CPP, DeriveDataTypeable #-} module DataCon ( -- * Main data types DataCon, DataConRep(..), SrcStrictness(..), SrcUnpackedness(..), HsSrcBang(..), HsImplBang(..), StrictnessMark(..), ConTag, -- ** Equality specs EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType, eqSpecPair, eqSpecPreds, substEqSpec, filterEqSpec, -- ** Field labels FieldLbl(..), FieldLabel, FieldLabelString, -- ** Type construction mkDataCon, buildAlgTyCon, buildSynTyCon, fIRST_TAG, -- ** Type deconstruction dataConRepType, dataConSig, dataConInstSig, dataConFullSig, dataConName, dataConIdentity, dataConTag, dataConTagZ, dataConTyCon, dataConOrigTyCon, dataConUserType, dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars, dataConUserTyVars, dataConUserTyVarBinders, dataConEqSpec, dataConTheta, dataConStupidTheta, dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, dataConInstOrigArgTys, dataConRepArgTys, dataConFieldLabels, dataConFieldType, dataConFieldType_maybe, dataConSrcBangs, dataConSourceArity, dataConRepArity, dataConIsInfix, dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitTyThings, dataConRepStrictness, dataConImplBangs, dataConBoxer, splitDataProductType_maybe, -- ** Predicates on DataCons isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon, isUnboxedSumCon, isVanillaDataCon, classDataCon, dataConCannotMatch, dataConUserTyVarsArePermuted, isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked, specialPromotedDc, -- ** Promotion related functions promoteDataCon ) where #include "GhclibHsVersions.h" import GhcPrelude import {-# SOURCE #-} MkId( DataConBoxer ) import Type import ForeignCall ( CType ) import Coercion import Unify import TyCon import FieldLabel import Class import Name import PrelNames import Predicate import Var import VarSet( emptyVarSet ) import Outputable import Util import BasicTypes import FastString import Module import Binary import UniqSet import Unique( mkAlphaTyVarUnique ) import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Lazy as LBS import qualified Data.Data as Data import Data.Char import Data.List( find ) {- Data constructor representation ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following Haskell data type declaration data T = T !Int ![Int] Using the strictness annotations, GHC will represent this as data T = T Int# [Int] That is, the Int has been unboxed. Furthermore, the Haskell source construction T e1 e2 is translated to case e1 of { I# x -> case e2 of { r -> T x r }} That is, the first argument is unboxed, and the second is evaluated. Finally, pattern matching is translated too: case e of { T a b -> ... } becomes case e of { T a' b -> let a = I# a' in ... } To keep ourselves sane, we name the different versions of the data constructor differently, as follows. Note [Data Constructor Naming] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Each data constructor C has two, and possibly up to four, Names associated with it: OccName Name space Name of Notes --------------------------------------------------------------------------- The "data con itself" C DataName DataCon In dom( GlobalRdrEnv ) The "worker data con" C VarName Id The worker The "wrapper data con" $WC VarName Id The wrapper The "newtype coercion" :CoT TcClsName TyCon EVERY data constructor (incl for newtypes) has the former two (the data con itself, and its worker. But only some data constructors have a wrapper (see Note [The need for a wrapper]). Each of these three has a distinct Unique. The "data con itself" name appears in the output of the renamer, and names the Haskell-source data constructor. The type checker translates it into either the wrapper Id (if it exists) or worker Id (otherwise). The data con has one or two Ids associated with it: The "worker Id", is the actual data constructor. * Every data constructor (newtype or data type) has a worker * The worker is very like a primop, in that it has no binding. * For a *data* type, the worker *is* the data constructor; it has no unfolding * For a *newtype*, the worker has a compulsory unfolding which does a cast, e.g. newtype T = MkT Int The worker for MkT has unfolding \\(x:Int). x `cast` sym CoT Here CoT is the type constructor, witnessing the FC axiom axiom CoT : T = Int The "wrapper Id", \$WC, goes as follows * Its type is exactly what it looks like in the source program. * It is an ordinary function, and it gets a top-level binding like any other function. * The wrapper Id isn't generated for a data type if there is nothing for the wrapper to do. That is, if its defn would be \$wC = C Note [Data constructor workers and wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Algebraic data types - Always have a worker, with no unfolding - May or may not have a wrapper; see Note [The need for a wrapper] * Newtypes - Always have a worker, which has a compulsory unfolding (just a cast) - May or may not have a wrapper; see Note [The need for a wrapper] * INVARIANT: the dictionary constructor for a class never has a wrapper. * Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments * The wrapper (if it exists) takes dcOrigArgTys as its arguments The worker takes dataConRepArgTys as its arguments If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys * The 'NoDataConRep' case of DataConRep is important. Not only is it efficient, but it also ensures that the wrapper is replaced by the worker (because it *is* the worker) even when there are no args. E.g. in f (:) x the (:) *is* the worker. This is really important in rule matching, (We could match on the wrappers, but that makes it less likely that rules will match when we bring bits of unfoldings together.) Note [The need for a wrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Why might the wrapper have anything to do? The full story is in wrapper_reqd in MkId.mkDataConRep. * Unboxing strict fields (with -funbox-strict-fields) data T = MkT !(Int,Int) \$wMkT :: (Int,Int) -> T \$wMkT (x,y) = MkT x y Notice that the worker has two fields where the wapper has just one. That is, the worker has type MkT :: Int -> Int -> T * Equality constraints for GADTs data T a where { MkT :: a -> T [a] } The worker gets a type with explicit equality constraints, thus: MkT :: forall a b. (a=[b]) => b -> T a The wrapper has the programmer-specified type: \$wMkT :: a -> T [a] \$wMkT a x = MkT [a] a [a] x The third argument is a coercion [a] :: [a]~[a] * Data family instances may do a cast on the result * Type variables may be permuted; see MkId Note [Data con wrappers and GADT syntax] Note [The stupid context] ~~~~~~~~~~~~~~~~~~~~~~~~~ Data types can have a context: data (Eq a, Ord b) => T a b = T1 a b | T2 a and that makes the constructors have a context too (notice that T2's context is "thinned"): T1 :: (Eq a, Ord b) => a -> b -> T a b T2 :: (Eq a) => a -> T a b Furthermore, this context pops up when pattern matching (though GHC hasn't implemented this, but it is in H98, and I've fixed GHC so that it now does): f (T2 x) = x gets inferred type f :: Eq a => T a b -> a I say the context is "stupid" because the dictionaries passed are immediately discarded -- they do nothing and have no benefit. It's a flaw in the language. Up to now [March 2002] I have put this stupid context into the type of the "wrapper" constructors functions, T1 and T2, but that turned out to be jolly inconvenient for generics, and record update, and other functions that build values of type T (because they don't have suitable dictionaries available). So now I've taken the stupid context out. I simply deal with it separately in the type checker on occurrences of a constructor, either in an expression or in a pattern. [May 2003: actually I think this decision could easily be reversed now, and probably should be. Generics could be disabled for types with a stupid context; record updates now (H98) needs the context too; etc. It's an unforced change, so I'm leaving it for now --- but it does seem odd that the wrapper doesn't include the stupid context.] [July 04] With the advent of generalised data types, it's less obvious what the "stupid context" is. Consider C :: forall a. Ord a => a -> a -> T (Foo a) Does the C constructor in Core contain the Ord dictionary? Yes, it must: f :: T b -> Ordering f = /\b. \x:T b. case x of C a (d:Ord a) (p:a) (q:a) -> compare d p q Note that (Foo a) might not be an instance of Ord. ************************************************************************ * * \subsection{Data constructors} * * ************************************************************************ -} -- | A data constructor -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma' -- For details on above see note [Api annotations] in ApiAnnotation data DataCon = MkData { dcName :: Name, -- This is the name of the *source data con* -- (see "Note [Data Constructor Naming]" above) dcUnique :: Unique, -- Cached from Name dcTag :: ConTag, -- ^ Tag, used for ordering 'DataCon's -- Running example: -- -- *** As declared by the user -- data T a b c where -- MkT :: forall c y x b. (x~y,Ord x) => x -> y -> T (x,y) b c -- *** As represented internally -- data T a b c where -- MkT :: forall a b c. forall x y. (a~(x,y),x~y,Ord x) -- => x -> y -> T a b c -- -- The next six fields express the type of the constructor, in pieces -- e.g. -- -- dcUnivTyVars = [a,b,c] -- dcExTyCoVars = [x,y] -- dcUserTyVarBinders = [c,y,x,b] -- dcEqSpec = [a~(x,y)] -- dcOtherTheta = [x~y, Ord x] -- dcOrigArgTys = [x,y] -- dcRepTyCon = T -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE -- TYVARS FOR THE PARENT TyCon. (This is a change (Oct05): previously, -- vanilla datacons guaranteed to have the same type variables as their -- parent TyCon, but that seems ugly.) They can be different in the case -- where a GADT constructor uses different names for the universal -- tyvars than does the tycon. For example: -- -- data H a where -- MkH :: b -> H b -- -- Here, the tyConTyVars of H will be [a], but the dcUnivTyVars of MkH -- will be [b]. dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor -- Its type is of form -- forall a1..an . t1 -> ... tm -> T a1..an -- No existentials, no coercions, nothing. -- That is: dcExTyCoVars = dcEqSpec = dcOtherTheta = [] -- NB 1: newtypes always have a vanilla data con -- NB 2: a vanilla constructor can still be declared in GADT-style -- syntax, provided its type looks like the above. -- The declaration format is held in the TyCon (algTcGadtSyntax) -- Universally-quantified type vars [a,b,c] -- INVARIANT: length matches arity of the dcRepTyCon -- INVARIANT: result type of data con worker is exactly (T a b c) -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with -- the tyConTyVars of the parent TyCon dcUnivTyVars :: [TyVar], -- Existentially-quantified type and coercion vars [x,y] -- For an example involving coercion variables, -- Why tycovars? See Note [Existential coercion variables] dcExTyCoVars :: [TyCoVar], -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames -- Reason: less confusing, and easier to generate IfaceSyn -- The type/coercion vars in the order the user wrote them [c,y,x,b] -- INVARIANT: the set of tyvars in dcUserTyVarBinders is exactly the set -- of tyvars (*not* covars) of dcExTyCoVars unioned with the -- set of dcUnivTyVars whose tyvars do not appear in dcEqSpec -- See Note [DataCon user type variable binders] dcUserTyVarBinders :: [TyVarBinder], dcEqSpec :: [EqSpec], -- Equalities derived from the result type, -- _as written by the programmer_. -- Only non-dependent GADT equalities (dependent -- GADT equalities are in the covars of -- dcExTyCoVars). -- This field allows us to move conveniently between the two ways -- of representing a GADT constructor's type: -- MkT :: forall a b. (a ~ [b]) => b -> T a -- MkT :: forall b. b -> T [b] -- Each equality is of the form (a ~ ty), where 'a' is one of -- the universally quantified type variables -- The next two fields give the type context of the data constructor -- (aside from the GADT constraints, -- which are given by the dcExpSpec) -- In GADT form, this is *exactly* what the programmer writes, even if -- the context constrains only universally quantified variables -- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b dcOtherTheta :: ThetaType, -- The other constraints in the data con's type -- other than those in the dcEqSpec dcStupidTheta :: ThetaType, -- The context of the data type declaration -- data Eq a => T a = ... -- or, rather, a "thinned" version thereof -- "Thinned", because the Report says -- to eliminate any constraints that don't mention -- tyvars free in the arg types for this constructor -- -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon -- -- "Stupid", because the dictionaries aren't used for anything. -- Indeed, [as of March 02] they are no longer in the type of -- the wrapper Id, because that makes it harder to use the wrap-id -- to rebuild values after record selection or in generics. dcOrigArgTys :: [Type], -- Original argument types -- (before unboxing and flattening of strict fields) dcOrigResTy :: Type, -- Original result type, as seen by the user -- NB: for a data instance, the original user result type may -- differ from the DataCon's representation TyCon. Example -- data instance T [a] where MkT :: a -> T [a] -- The OrigResTy is T [a], but the dcRepTyCon might be :T123 -- Now the strictness annotations and field labels of the constructor dcSrcBangs :: [HsSrcBang], -- See Note [Bangs on data constructor arguments] -- -- The [HsSrcBang] as written by the programmer. -- -- Matches 1-1 with dcOrigArgTys -- Hence length = dataConSourceArity dataCon dcFields :: [FieldLabel], -- Field labels for this constructor, in the -- same order as the dcOrigArgTys; -- length = 0 (if not a record) or dataConSourceArity. -- The curried worker function that corresponds to the constructor: -- It doesn't have an unfolding; the code generator saturates these Ids -- and allocates a real constructor when it finds one. dcWorkId :: Id, -- Constructor representation dcRep :: DataConRep, -- Cached; see Note [DataCon arities] -- INVARIANT: dcRepArity == length dataConRepArgTys + count isCoVar (dcExTyCoVars) -- INVARIANT: dcSourceArity == length dcOrigArgTys dcRepArity :: Arity, dcSourceArity :: Arity, -- Result type of constructor is T t1..tn dcRepTyCon :: TyCon, -- Result tycon, T dcRepType :: Type, -- Type of the constructor -- forall a x y. (a~(x,y), x~y, Ord x) => -- x -> y -> T a -- (this is *not* of the constructor wrapper Id: -- see Note [Data con representation] below) -- Notice that the existential type parameters come *second*. -- Reason: in a case expression we may find: -- case (e :: T t) of -- MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ... -- It's convenient to apply the rep-type of MkT to 't', to get -- forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t -- and use that to check the pattern. Mind you, this is really only -- used in CoreLint. dcInfix :: Bool, -- True <=> declared infix -- Used for Template Haskell and 'deriving' only -- The actual fixity is stored elsewhere dcPromoted :: TyCon -- The promoted TyCon -- See Note [Promoted data constructors] in TyCon } {- Note [TyVarBinders in DataCons] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For the TyVarBinders in a DataCon and PatSyn: * Each argument flag is Inferred or Specified. None are Required. (A DataCon is a term-level function; see Note [No Required TyCoBinder in terms] in TyCoRep.) Why do we need the TyVarBinders, rather than just the TyVars? So that we can construct the right type for the DataCon with its foralls attributed the correct visibility. That in turn governs whether you can use visible type application at a call of the data constructor. See also [DataCon user type variable binders] for an extended discussion on the order in which TyVarBinders appear in a DataCon. Note [Existential coercion variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For now (Aug 2018) we can't write coercion quantifications in source Haskell, but we can in Core. Consider having: data T :: forall k. k -> k -> Constraint where MkT :: forall k (a::k) (b::k). forall k' (c::k') (co::k'~k). (b~(c|>co)) => T k a b dcUnivTyVars = [k,a,b] dcExTyCoVars = [k',c,co] dcUserTyVarBinders = [k,a,k',c] dcEqSpec = [b~(c|>co)] dcOtherTheta = [] dcOrigArgTys = [] dcRepTyCon = T Function call 'dataConKindEqSpec' returns [k'~k] Note [DataCon arities] ~~~~~~~~~~~~~~~~~~~~~~ dcSourceArity does not take constraints into account, but dcRepArity does. For example: MkT :: Ord a => a -> T a dcSourceArity = 1 dcRepArity = 2 Note [DataCon user type variable binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In System FC, data constructor type signatures always quantify over all of their universal type variables, followed by their existential type variables. Normally, this isn't a problem, as most datatypes naturally quantify their type variables in this order anyway. For example: data T a b = forall c. MkT b c Here, we have `MkT :: forall {k} (a :: k) (b :: *) (c :: *). b -> c -> T a b`, where k, a, and b are universal and c is existential. (The inferred variable k isn't available for TypeApplications, hence why it's in braces.) This is a perfectly reasonable order to use, as the syntax of H98-style datatypes (+ ExistentialQuantification) suggests it. Things become more complicated when GADT syntax enters the picture. Consider this example: data X a where MkX :: forall b a. b -> Proxy a -> X a If we adopt the earlier approach of quantifying all the universal variables followed by all the existential ones, GHC would come up with this type signature for MkX: MkX :: forall {k} (a :: k) (b :: *). b -> Proxy a -> X a But this is not what we want at all! After all, if a user were to use TypeApplications on MkX, they would expect to instantiate `b` before `a`, as that's the order in which they were written in the `forall`. (See #11721.) Instead, we'd like GHC to come up with this type signature: MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a In fact, even if we left off the explicit forall: data X a where MkX :: b -> Proxy a -> X a Then a user should still expect `b` to be quantified before `a`, since according to the rules of TypeApplications, in the absence of `forall` GHC performs a stable topological sort on the type variables in the user-written type signature, which would place `b` before `a`. But as noted above, enacting this behavior is not entirely trivial, as System FC demands the variables go in universal-then-existential order under the hood. Our solution is thus to equip DataCon with two different sets of type variables: * dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential type/coercion variables, respectively. Their order is irrelevant for the purposes of TypeApplications, and as a consequence, they do not come equipped with visibilities (that is, they are TyVars/TyCoVars instead of TyCoVarBinders). * dcUserTyVarBinders, for the type variables binders in the order in which they originally arose in the user-written type signature. Their order *does* matter for TypeApplications, so they are full TyVarBinders, complete with visibilities. This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders consists precisely of: * The set of tyvars in dcUnivTyVars whose type variables do not appear in dcEqSpec, unioned with: * The set of tyvars (*not* covars) in dcExTyCoVars No covars here because because they're not user-written The word "set" is used above because the order in which the tyvars appear in dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of (tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the ordering, they in fact share the same type variables (with the same Uniques). We sometimes refer to this as "the dcUserTyVarBinders invariant". dcUserTyVarBinders, as the name suggests, is the one that users will see most of the time. It's used when computing the type signature of a data constructor (see dataConUserType), and as a result, it's what matters from a TypeApplications perspective. -} -- | Data Constructor Representation -- See Note [Data constructor workers and wrappers] data DataConRep = -- NoDataConRep means that the data con has no wrapper NoDataConRep -- DCR means that the data con has a wrapper | DCR { dcr_wrap_id :: Id -- Takes src args, unboxes/flattens, -- and constructs the representation , dcr_boxer :: DataConBoxer , dcr_arg_tys :: [Type] -- Final, representation argument types, -- after unboxing and flattening, -- and *including* all evidence args , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys -- See also Note [Data-con worker strictness] in MkId.hs , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures) -- about the original arguments; 1-1 with orig_arg_tys -- See Note [Bangs on data constructor arguments] } ------------------------- -- | Haskell Source Bang -- -- Bangs on data constructor arguments as the user wrote them in the -- source code. -- -- @(HsSrcBang _ SrcUnpack SrcLazy)@ and -- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we -- emit a warning (in checkValidDataCon) and treat it like -- @(HsSrcBang _ NoSrcUnpack SrcLazy)@ data HsSrcBang = HsSrcBang SourceText -- Note [Pragma source text] in BasicTypes SrcUnpackedness SrcStrictness deriving Data.Data -- | Haskell Implementation Bang -- -- Bangs of data constructor arguments as generated by the compiler -- after consulting HsSrcBang, flags, etc. data HsImplBang = HsLazy -- ^ Lazy field, or one with an unlifted type | HsStrict -- ^ Strict but not unpacked field | HsUnpack (Maybe Coercion) -- ^ Strict and unpacked field -- co :: arg-ty ~ product-ty HsBang deriving Data.Data -- | Source Strictness -- -- What strictness annotation the user wrote data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' | SrcStrict -- ^ Strict, ie '!' | NoSrcStrict -- ^ no strictness annotation deriving (Eq, Data.Data) -- | Source Unpackedness -- -- What unpackedness the user requested data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified | NoSrcUnpack -- ^ no unpack pragma deriving (Eq, Data.Data) ------------------------- -- StrictnessMark is internal only, used to indicate strictness -- of the DataCon *worker* fields data StrictnessMark = MarkedStrict | NotMarkedStrict -- | An 'EqSpec' is a tyvar/type pair representing an equality made in -- rejigging a GADT constructor data EqSpec = EqSpec TyVar Type -- | Make a non-dependent 'EqSpec' mkEqSpec :: TyVar -> Type -> EqSpec mkEqSpec tv ty = EqSpec tv ty eqSpecTyVar :: EqSpec -> TyVar eqSpecTyVar (EqSpec tv _) = tv eqSpecType :: EqSpec -> Type eqSpecType (EqSpec _ ty) = ty eqSpecPair :: EqSpec -> (TyVar, Type) eqSpecPair (EqSpec tv ty) = (tv, ty) eqSpecPreds :: [EqSpec] -> ThetaType eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty | EqSpec tv ty <- spec ] -- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec -- is mapped in the substitution, it is mapped to a type variable, not -- a full type. substEqSpec :: TCvSubst -> EqSpec -> EqSpec substEqSpec subst (EqSpec tv ty) = EqSpec tv' (substTy subst ty) where tv' = getTyVar "substEqSpec" (substTyVar subst tv) -- | Filter out any 'TyVar's mentioned in an 'EqSpec'. filterEqSpec :: [EqSpec] -> [TyVar] -> [TyVar] filterEqSpec eq_spec = filter not_in_eq_spec where not_in_eq_spec var = all (not . (== var) . eqSpecTyVar) eq_spec instance Outputable EqSpec where ppr (EqSpec tv ty) = ppr (tv, ty) {- Note [Bangs on data constructor arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T = MkT !Int {-# UNPACK #-} !Int Bool When compiling the module, GHC will decide how to represent MkT, depending on the optimisation level, and settings of flags like -funbox-small-strict-fields. Terminology: * HsSrcBang: What the user wrote Constructors: HsSrcBang * HsImplBang: What GHC decided Constructors: HsLazy, HsStrict, HsUnpack * If T was defined in this module, MkT's dcSrcBangs field records the [HsSrcBang] of what the user wrote; in the example [ HsSrcBang _ NoSrcUnpack SrcStrict , HsSrcBang _ SrcUnpack SrcStrict , HsSrcBang _ NoSrcUnpack NoSrcStrictness] * However, if T was defined in an imported module, the importing module must follow the decisions made in the original module, regardless of the flag settings in the importing module. Also see Note [Bangs on imported data constructors] in MkId * The dcr_bangs field of the dcRep field records the [HsImplBang] If T was defined in this module, Without -O the dcr_bangs might be [HsStrict, HsStrict, HsLazy] With -O it might be [HsStrict, HsUnpack _, HsLazy] With -funbox-small-strict-fields it might be [HsUnpack, HsUnpack _, HsLazy] With -XStrictData it might be [HsStrict, HsUnpack _, HsStrict] Note [Data con representation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The dcRepType field contains the type of the representation of a constructor This may differ from the type of the constructor *Id* (built by MkId.mkDataConId) for two reasons: a) the constructor Id may be overloaded, but the dictionary isn't stored e.g. data Eq a => T a = MkT a a b) the constructor may store an unboxed version of a strict field. Here's an example illustrating both: data Ord a => T a = MkT Int! a Here T :: Ord a => Int -> a -> T a but the rep type is Trep :: Int# -> a -> T a Actually, the unboxed part isn't implemented yet! ************************************************************************ * * \subsection{Instances} * * ************************************************************************ -} instance Eq DataCon where a == b = getUnique a == getUnique b a /= b = getUnique a /= getUnique b instance Uniquable DataCon where getUnique = dcUnique instance NamedThing DataCon where getName = dcName instance Outputable DataCon where ppr con = ppr (dataConName con) instance OutputableBndr DataCon where pprInfixOcc con = pprInfixName (dataConName con) pprPrefixOcc con = pprPrefixName (dataConName con) instance Data.Data DataCon where -- don't traverse? toConstr _ = abstractConstr "DataCon" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "DataCon" instance Outputable HsSrcBang where ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark instance Outputable HsImplBang where ppr HsLazy = text "Lazy" ppr (HsUnpack Nothing) = text "Unpacked" ppr (HsUnpack (Just co)) = text "Unpacked" <> parens (ppr co) ppr HsStrict = text "StrictNotUnpacked" instance Outputable SrcStrictness where ppr SrcLazy = char '~' ppr SrcStrict = char '!' ppr NoSrcStrict = empty instance Outputable SrcUnpackedness where ppr SrcUnpack = text "{-# UNPACK #-}" ppr SrcNoUnpack = text "{-# NOUNPACK #-}" ppr NoSrcUnpack = empty instance Outputable StrictnessMark where ppr MarkedStrict = text "!" ppr NotMarkedStrict = empty instance Binary SrcStrictness where put_ bh SrcLazy = putByte bh 0 put_ bh SrcStrict = putByte bh 1 put_ bh NoSrcStrict = putByte bh 2 get bh = do h <- getByte bh case h of 0 -> return SrcLazy 1 -> return SrcStrict _ -> return NoSrcStrict instance Binary SrcUnpackedness where put_ bh SrcNoUnpack = putByte bh 0 put_ bh SrcUnpack = putByte bh 1 put_ bh NoSrcUnpack = putByte bh 2 get bh = do h <- getByte bh case h of 0 -> return SrcNoUnpack 1 -> return SrcUnpack _ -> return NoSrcUnpack -- | Compare strictness annotations eqHsBang :: HsImplBang -> HsImplBang -> Bool eqHsBang HsLazy HsLazy = True eqHsBang HsStrict HsStrict = True eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2) eqHsBang _ _ = False isBanged :: HsImplBang -> Bool isBanged (HsUnpack {}) = True isBanged (HsStrict {}) = True isBanged HsLazy = False isSrcStrict :: SrcStrictness -> Bool isSrcStrict SrcStrict = True isSrcStrict _ = False isSrcUnpacked :: SrcUnpackedness -> Bool isSrcUnpacked SrcUnpack = True isSrcUnpacked _ = False isMarkedStrict :: StrictnessMark -> Bool isMarkedStrict NotMarkedStrict = False isMarkedStrict _ = True -- All others are strict {- ********************************************************************* * * \subsection{Construction} * * ********************************************************************* -} -- | Build a new data constructor mkDataCon :: Name -> Bool -- ^ Is the constructor declared infix? -> TyConRepName -- ^ TyConRepName for the promoted TyCon -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user -> [FieldLabel] -- ^ Field labels for the constructor, -- if it is a record, otherwise empty -> [TyVar] -- ^ Universals. -> [TyCoVar] -- ^ Existentials. -> [TyVarBinder] -- ^ User-written 'TyVarBinder's. -- These must be Inferred/Specified. -- See @Note [TyVarBinders in DataCons]@ -> [EqSpec] -- ^ GADT equalities -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper -> [KnotTied Type] -- ^ Original argument types -> KnotTied Type -- ^ Original result type -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo' -> KnotTied TyCon -- ^ Representation type constructor -> ConTag -- ^ Constructor tag -> ThetaType -- ^ The "stupid theta", context of the data -- declaration e.g. @data Eq a => T a ...@ -> Id -- ^ Worker Id -> DataConRep -- ^ Representation -> DataCon -- Can get the tag from the TyCon mkDataCon name declared_infix prom_info arg_stricts -- Must match orig_arg_tys 1-1 fields univ_tvs ex_tvs user_tvbs eq_spec theta orig_arg_tys orig_res_ty rep_info rep_tycon tag stupid_theta work_id rep -- Warning: mkDataCon is not a good place to check certain invariants. -- If the programmer writes the wrong result type in the decl, thus: -- data T a where { MkT :: S } -- then it's possible that the univ_tvs may hit an assertion failure -- if you pull on univ_tvs. This case is checked by checkValidDataCon, -- so the error is detected properly... it's just that assertions here -- are a little dodgy. = con where is_vanilla = null ex_tvs && null eq_spec && null theta con = MkData {dcName = name, dcUnique = nameUnique name, dcVanilla = is_vanilla, dcInfix = declared_infix, dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs, dcUserTyVarBinders = user_tvbs, dcEqSpec = eq_spec, dcOtherTheta = theta, dcStupidTheta = stupid_theta, dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, dcRepTyCon = rep_tycon, dcSrcBangs = arg_stricts, dcFields = fields, dcTag = tag, dcRepType = rep_ty, dcWorkId = work_id, dcRep = rep, dcSourceArity = length orig_arg_tys, dcRepArity = length rep_arg_tys + count isCoVar ex_tvs, dcPromoted = promoted } -- The 'arg_stricts' passed to mkDataCon are simply those for the -- source-language arguments. We add extra ones for the -- dictionary arguments right here. rep_arg_tys = dataConRepArgTys con rep_ty = case rep of -- If the DataCon has no wrapper, then the worker's type *is* the -- user-facing type, so we can simply use dataConUserType. NoDataConRep -> dataConUserType con -- If the DataCon has a wrapper, then the worker's type is never seen -- by the user. The visibilities we pick do not matter here. DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ mkVisFunTys rep_arg_tys $ mkTyConApp rep_tycon (mkTyVarTys univ_tvs) -- See Note [Promoted data constructors] in TyCon prom_tv_bndrs = [ mkNamedTyConBinder vis tv | Bndr tv vis <- user_tvbs ] fresh_names = freshNames (map getName user_tvbs) -- fresh_names: make sure that the "anonymous" tyvars don't -- clash in name or unique with the universal/existential ones. -- Tiresome! And unnecessary because these tyvars are never looked at prom_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t) {- Invisible -} | (n,t) <- fresh_names `zip` theta ] prom_arg_bndrs = [ mkAnonTyConBinder VisArg (mkTyVar n t) {- Visible -} | (n,t) <- dropList theta fresh_names `zip` orig_arg_tys ] prom_bndrs = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs prom_res_kind = orig_res_ty promoted = mkPromotedDataCon con name prom_info prom_bndrs prom_res_kind roles rep_info roles = map (\tv -> if isTyVar tv then Nominal else Phantom) (univ_tvs ++ ex_tvs) ++ map (const Representational) (theta ++ orig_arg_tys) freshNames :: [Name] -> [Name] -- Make an infinite list of Names whose Uniques and OccNames -- differ from those in the 'avoid' list freshNames avoids = [ mkSystemName uniq occ | n <- [0..] , let uniq = mkAlphaTyVarUnique n occ = mkTyVarOccFS (mkFastString ('x' : show n)) , not (uniq `elementOfUniqSet` avoid_uniqs) , not (occ `elemOccSet` avoid_occs) ] where avoid_uniqs :: UniqSet Unique avoid_uniqs = mkUniqSet (map getUnique avoids) avoid_occs :: OccSet avoid_occs = mkOccSet (map getOccName avoids) -- | The 'Name' of the 'DataCon', giving it a unique, rooted identification dataConName :: DataCon -> Name dataConName = dcName -- | The tag used for ordering 'DataCon's dataConTag :: DataCon -> ConTag dataConTag = dcTag dataConTagZ :: DataCon -> ConTagZ dataConTagZ con = dataConTag con - fIRST_TAG -- | The type constructor that we are building via this data constructor dataConTyCon :: DataCon -> TyCon dataConTyCon = dcRepTyCon -- | The original type constructor used in the definition of this data -- constructor. In case of a data family instance, that will be the family -- type constructor. dataConOrigTyCon :: DataCon -> TyCon dataConOrigTyCon dc | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc | otherwise = dcRepTyCon dc -- | The representation type of the data constructor, i.e. the sort -- type that will represent values of this type at runtime dataConRepType :: DataCon -> Type dataConRepType = dcRepType -- | Should the 'DataCon' be presented infix? dataConIsInfix :: DataCon -> Bool dataConIsInfix = dcInfix -- | The universally-quantified type variables of the constructor dataConUnivTyVars :: DataCon -> [TyVar] dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = tvbs -- | The existentially-quantified type/coercion variables of the constructor -- including dependent (kind-) GADT equalities dataConExTyCoVars :: DataCon -> [TyCoVar] dataConExTyCoVars (MkData { dcExTyCoVars = tvbs }) = tvbs -- | Both the universal and existential type/coercion variables of the constructor dataConUnivAndExTyCoVars :: DataCon -> [TyCoVar] dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs }) = univ_tvs ++ ex_tvs -- See Note [DataCon user type variable binders] -- | The type variables of the constructor, in the order the user wrote them dataConUserTyVars :: DataCon -> [TyVar] dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs -- See Note [DataCon user type variable binders] -- | 'TyCoVarBinder's for the type variables of the constructor, in the order the -- user wrote them dataConUserTyVarBinders :: DataCon -> [TyVarBinder] dataConUserTyVarBinders = dcUserTyVarBinders -- | Equalities derived from the result type of the data constructor, as written -- by the programmer in any GADT declaration. This includes *all* GADT-like -- equalities, including those written in by hand by the programmer. dataConEqSpec :: DataCon -> [EqSpec] dataConEqSpec con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) = dataConKindEqSpec con ++ eq_spec ++ [ spec -- heterogeneous equality | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta , tc `hasKey` heqTyConKey , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of (Just tv1, _) -> [mkEqSpec tv1 ty2] (_, Just tv2) -> [mkEqSpec tv2 ty1] _ -> [] ] ++ [ spec -- homogeneous equality | Just (tc, [_k, ty1, ty2]) <- map splitTyConApp_maybe theta , tc `hasKey` eqTyConKey , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of (Just tv1, _) -> [mkEqSpec tv1 ty2] (_, Just tv2) -> [mkEqSpec tv2 ty1] _ -> [] ] -- | Dependent (kind-level) equalities in a constructor. -- There are extracted from the existential variables. -- See Note [Existential coercion variables] dataConKindEqSpec :: DataCon -> [EqSpec] dataConKindEqSpec (MkData {dcExTyCoVars = ex_tcvs}) -- It is used in 'dataConEqSpec' (maybe also 'dataConFullSig' in the future), -- which are frequently used functions. -- For now (Aug 2018) this function always return empty set as we don't really -- have coercion variables. -- In the future when we do, we might want to cache this information in DataCon -- so it won't be computed every time when aforementioned functions are called. = [ EqSpec tv ty | cv <- ex_tcvs , isCoVar cv , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv tv = getTyVar "dataConKindEqSpec" ty1 ] -- | The *full* constraints on the constructor type, including dependent GADT -- equalities. dataConTheta :: DataCon -> ThetaType dataConTheta con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) = eqSpecPreds (dataConKindEqSpec con ++ eq_spec) ++ theta -- | Get the Id of the 'DataCon' worker: a function that is the "actual" -- constructor and has no top level binding in the program. The type may -- be different from the obvious one written in the source program. Panics -- if there is no such 'Id' for this 'DataCon' dataConWorkId :: DataCon -> Id dataConWorkId dc = dcWorkId dc -- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual" -- constructor so it has the type visible in the source program: c.f. -- 'dataConWorkId'. -- Returns Nothing if there is no wrapper, which occurs for an algebraic data -- constructor and also for a newtype (whose constructor is inlined -- compulsorily) dataConWrapId_maybe :: DataCon -> Maybe Id dataConWrapId_maybe dc = case dcRep dc of NoDataConRep -> Nothing DCR { dcr_wrap_id = wrap_id } -> Just wrap_id -- | Returns an Id which looks like the Haskell-source constructor by using -- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to -- the worker (see 'dataConWorkId') dataConWrapId :: DataCon -> Id dataConWrapId dc = case dcRep dc of NoDataConRep-> dcWorkId dc -- worker=wrapper DCR { dcr_wrap_id = wrap_id } -> wrap_id -- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently, -- the union of the 'dataConWorkId' and the 'dataConWrapId' dataConImplicitTyThings :: DataCon -> [TyThing] dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep }) = [AnId work] ++ wrap_ids where wrap_ids = case rep of NoDataConRep -> [] DCR { dcr_wrap_id = wrap } -> [AnId wrap] -- | The labels for the fields of this particular 'DataCon' dataConFieldLabels :: DataCon -> [FieldLabel] dataConFieldLabels = dcFields -- | Extract the type for any given labelled field of the 'DataCon' dataConFieldType :: DataCon -> FieldLabelString -> Type dataConFieldType con label = case dataConFieldType_maybe con label of Just (_, ty) -> ty Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label) -- | Extract the label and type for any given labelled field of the -- 'DataCon', or return 'Nothing' if the field does not belong to it dataConFieldType_maybe :: DataCon -> FieldLabelString -> Maybe (FieldLabel, Type) dataConFieldType_maybe con label = find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con) -- | Strictness/unpack annotations, from user; or, for imported -- DataCons, from the interface file -- The list is in one-to-one correspondence with the arity of the 'DataCon' dataConSrcBangs :: DataCon -> [HsSrcBang] dataConSrcBangs = dcSrcBangs -- | Source-level arity of the data constructor dataConSourceArity :: DataCon -> Arity dataConSourceArity (MkData { dcSourceArity = arity }) = arity -- | Gives the number of actual fields in the /representation/ of the -- data constructor. This may be more than appear in the source code; -- the extra ones are the existentially quantified dictionaries dataConRepArity :: DataCon -> Arity dataConRepArity (MkData { dcRepArity = arity }) = arity -- | Return whether there are any argument types for this 'DataCon's original source type -- See Note [DataCon arities] isNullarySrcDataCon :: DataCon -> Bool isNullarySrcDataCon dc = dataConSourceArity dc == 0 -- | Return whether there are any argument types for this 'DataCon's runtime representation type -- See Note [DataCon arities] isNullaryRepDataCon :: DataCon -> Bool isNullaryRepDataCon dc = dataConRepArity dc == 0 dataConRepStrictness :: DataCon -> [StrictnessMark] -- ^ Give the demands on the arguments of a -- Core constructor application (Con dc args) dataConRepStrictness dc = case dcRep dc of NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc] DCR { dcr_stricts = strs } -> strs dataConImplBangs :: DataCon -> [HsImplBang] -- The implementation decisions about the strictness/unpack of each -- source program argument to the data constructor dataConImplBangs dc = case dcRep dc of NoDataConRep -> replicate (dcSourceArity dc) HsLazy DCR { dcr_bangs = bangs } -> bangs dataConBoxer :: DataCon -> Maybe DataConBoxer dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer dataConBoxer _ = Nothing -- | The \"signature\" of the 'DataCon' returns, in order: -- -- 1) The result of 'dataConUnivAndExTyCoVars', -- -- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary, -- implicit parameter - whatever), including dependent GADT equalities. -- Dependent GADT equalities are *also* listed in return value (1), so be -- careful! -- -- 3) The type arguments to the constructor -- -- 4) The /original/ result type of the 'DataCon' dataConSig :: DataCon -> ([TyCoVar], ThetaType, [Type], Type) dataConSig con@(MkData {dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) = (dataConUnivAndExTyCoVars con, dataConTheta con, arg_tys, res_ty) dataConInstSig :: DataCon -> [Type] -- Instantiate the *universal* tyvars with these types -> ([TyCoVar], ThetaType, [Type]) -- Return instantiated existentials -- theta and arg tys -- ^ Instantiate the universal tyvars of a data con, -- returning -- ( instantiated existentials -- , instantiated constraints including dependent GADT equalities -- which are *also* listed in the instantiated existentials -- , instantiated args) dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs , dcOrigArgTys = arg_tys }) univ_tys = ( ex_tvs' , substTheta subst (dataConTheta con) , substTys subst arg_tys) where univ_subst = zipTvSubst univ_tvs univ_tys (subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs -- | The \"full signature\" of the 'DataCon' returns, in order: -- -- 1) The result of 'dataConUnivTyVars' -- -- 2) The result of 'dataConExTyCoVars' -- -- 3) The non-dependent GADT equalities. -- Dependent GADT equalities are implied by coercion variables in -- return value (2). -- -- 4) The other constraints of the data constructor type, excluding GADT -- equalities -- -- 5) The original argument types to the 'DataCon' (i.e. before -- any change of the representation of the type) -- -- 6) The original result type of the 'DataCon' dataConFullSig :: DataCon -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) dataConOrigResTy :: DataCon -> Type dataConOrigResTy dc = dcOrigResTy dc -- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in: -- -- > data Eq a => T a = ... dataConStupidTheta :: DataCon -> ThetaType dataConStupidTheta dc = dcStupidTheta dc dataConUserType :: DataCon -> Type -- ^ The user-declared type of the data constructor -- in the nice-to-read form: -- -- > T :: forall a b. a -> b -> T [a] -- -- rather than: -- -- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c -- -- The type variables are quantified in the order that the user wrote them. -- See @Note [DataCon user type variable binders]@. -- -- NB: If the constructor is part of a data instance, the result type -- mentions the family tycon, not the internal one. dataConUserType (MkData { dcUserTyVarBinders = user_tvbs, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty }) = mkForAllTys user_tvbs $ mkInvisFunTys theta $ mkVisFunTys arg_tys $ res_ty -- | Finds the instantiated types of the arguments required to construct a -- 'DataCon' representation -- NB: these INCLUDE any dictionary args -- but EXCLUDE the data-declaration context, which is discarded -- It's all post-flattening etc; this is a representation type dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality constraints -- However, it can have a dcTheta (notably it can be a -- class dictionary, with superclasses) -> [Type] -- ^ Instantiated at these types -> [Type] dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs}) inst_tys = ASSERT2( univ_tvs `equalLength` inst_tys , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) ASSERT2( null ex_tvs, ppr dc ) map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc) -- | Returns just the instantiated /value/ argument types of a 'DataCon', -- (excluding dictionary args) dataConInstOrigArgTys :: DataCon -- Works for any DataCon -> [Type] -- Includes existential tyvar args, but NOT -- equality constraints or dicts -> [Type] -- For vanilla datacons, it's all quite straightforward -- But for the call in MatchCon, we really do want just the value args dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs}) inst_tys = ASSERT2( tyvars `equalLength` inst_tys , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) map (substTy subst) arg_tys where tyvars = univ_tvs ++ ex_tvs subst = zipTCvSubst tyvars inst_tys -- | Returns the argument types of the wrapper, excluding all dictionary arguments -- and without substituting for any type variables dataConOrigArgTys :: DataCon -> [Type] dataConOrigArgTys dc = dcOrigArgTys dc -- | Returns the arg types of the worker, including *all* non-dependent -- evidence, after any flattening has been done and without substituting for -- any type variables dataConRepArgTys :: DataCon -> [Type] dataConRepArgTys (MkData { dcRep = rep , dcEqSpec = eq_spec , dcOtherTheta = theta , dcOrigArgTys = orig_arg_tys }) = case rep of NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys DCR { dcr_arg_tys = arg_tys } -> arg_tys -- | The string @package:module.name@ identifying a constructor, which is attached -- to its info table and used by the GHCi debugger and the heap profiler dataConIdentity :: DataCon -> ByteString -- We want this string to be UTF-8, so we get the bytes directly from the FastStrings. dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat [ BSB.byteString $ bytesFS (unitIdFS (moduleUnitId mod)) , BSB.int8 $ fromIntegral (ord ':') , BSB.byteString $ bytesFS (moduleNameFS (moduleName mod)) , BSB.int8 $ fromIntegral (ord '.') , BSB.byteString $ bytesFS (occNameFS (nameOccName name)) ] where name = dataConName dc mod = ASSERT( isExternalName name ) nameModule name isTupleDataCon :: DataCon -> Bool isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc isUnboxedTupleCon :: DataCon -> Bool isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc isUnboxedSumCon :: DataCon -> Bool isUnboxedSumCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc -- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors isVanillaDataCon :: DataCon -> Bool isVanillaDataCon dc = dcVanilla dc -- | Should this DataCon be allowed in a type even without -XDataKinds? -- Currently, only Lifted & Unlifted specialPromotedDc :: DataCon -> Bool specialPromotedDc = isKindTyCon . dataConTyCon classDataCon :: Class -> DataCon classDataCon clas = case tyConDataCons (classTyCon clas) of (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr [] -> panic "classDataCon" dataConCannotMatch :: [Type] -> DataCon -> Bool -- Returns True iff the data con *definitely cannot* match a -- scrutinee of type (T tys) -- where T is the dcRepTyCon for the data con dataConCannotMatch tys con | null inst_theta = False -- Common | all isTyVarTy tys = False -- Also common | otherwise = typesCantMatch (concatMap predEqs inst_theta) where (_, inst_theta, _) = dataConInstSig con tys -- TODO: could gather equalities from superclasses too predEqs pred = case classifyPredType pred of EqPred NomEq ty1 ty2 -> [(ty1, ty2)] ClassPred eq args | eq `hasKey` eqTyConKey , [_, ty1, ty2] <- args -> [(ty1, ty2)] | eq `hasKey` heqTyConKey , [_, _, ty1, ty2] <- args -> [(ty1, ty2)] _ -> [] -- | Were the type variables of the data con written in a different order -- than the regular order (universal tyvars followed by existential tyvars)? -- -- This is not a cheap test, so we minimize its use in GHC as much as possible. -- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in -- "MkId", and so 'dataConUserTyVarsArePermuted' is only called at most once -- during a data constructor's lifetime. -- See Note [DataCon user type variable binders], as well as -- Note [Data con wrappers and GADT syntax] for an explanation of what -- mkDataConRep is doing with this function. dataConUserTyVarsArePermuted :: DataCon -> Bool dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec , dcUserTyVarBinders = user_tvbs }) = (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs {- %************************************************************************ %* * Promoting of data types to the kind level * * ************************************************************************ -} promoteDataCon :: DataCon -> TyCon promoteDataCon (MkData { dcPromoted = tc }) = tc {- ************************************************************************ * * \subsection{Splitting products} * * ************************************************************************ -} -- | Extract the type constructor, type argument, data constructor and it's -- /representation/ argument types from a type if it is a product type. -- -- Precisely, we return @Just@ for any type that is all of: -- -- * Concrete (i.e. constructors visible) -- -- * Single-constructor -- -- * Not existentially quantified -- -- Whether the type is a @data@ type or a @newtype@ splitDataProductType_maybe :: Type -- ^ A product type, perhaps -> Maybe (TyCon, -- The type constructor [Type], -- Type args of the tycon DataCon, -- The data constructor [Type]) -- Its /representation/ arg types -- Rejecting existentials is conservative. Maybe some things -- could be made to work with them, but I'm not going to sweat -- it through till someone finds it's important. splitDataProductType_maybe ty | Just (tycon, ty_args) <- splitTyConApp_maybe ty , Just con <- isDataProductTyCon_maybe tycon = Just (tycon, ty_args, con, dataConInstArgTys con ty_args) | otherwise = Nothing {- ************************************************************************ * * Building an algebraic data type * * ************************************************************************ buildAlgTyCon is here because it is called from TysWiredIn, which can depend on this module, but not on BuildTyCl. -} buildAlgTyCon :: Name -> [TyVar] -- ^ Kind variables and type variables -> [Role] -> Maybe CType -> ThetaType -- ^ Stupid theta -> AlgTyConRhs -> Bool -- ^ True <=> was declared in GADT syntax -> AlgTyConFlav -> TyCon buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs gadt_syn parent = mkAlgTyCon tc_name binders liftedTypeKind roles cType stupid_theta rhs parent gadt_syn where binders = mkTyConBindersPreferAnon ktvs emptyVarSet buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind -> [Role] -> KnotTied Type -> TyCon buildSynTyCon name binders res_kind roles rhs = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free where is_tau = isTauTy rhs is_fam_free = isFamFreeTy rhs ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/Demand.hs0000644000000000000000000023243113713635744021157 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[Demand]{@Demand@: A decoupled implementation of a demand domain} -} {-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-} module Demand ( StrDmd, UseDmd(..), Count, Demand, DmdShell, CleanDemand, getStrDmd, getUseDmd, mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, toCleanDmd, absDmd, topDmd, botDmd, seqDmd, lubDmd, bothDmd, lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, isTopDmd, isAbsDmd, isSeqDmd, peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, addCaseBndrDmd, DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType, nopDmdType, botDmdType, mkDmdType, addDemand, ensureArgs, BothDmdArg, mkBothDmdArg, toBothDmdArg, DmdEnv, emptyDmdEnv, peelFV, findIdDemand, DmdResult, CPRResult, isBotRes, isTopRes, topRes, botRes, cprProdRes, vanillaCprProdRes, cprSumRes, appIsBottom, isBottomingSig, pprIfaceStrictSig, trimCPRInfo, returnsCPR_maybe, StrictSig(..), mkStrictSigForArity, mkClosedStrictSig, nopSig, botSig, cprProdSig, isTopSig, hasDemandEnvSig, splitStrictSig, strictSigDmdEnv, increaseStrictSigArity, etaExpandStrictSig, seqDemand, seqDemandList, seqDmdType, seqStrictSig, evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, splitDmdTy, splitFVs, deferAfterIO, postProcessUnsat, postProcessDmdType, splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds, mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots, TypeShape(..), peelTsFuns, trimToType, useCount, isUsedOnce, reuseEnv, killUsageDemand, killUsageSig, zapUsageDemand, zapUsageEnvSig, zapUsedOnceDemand, zapUsedOnceSig, strictifyDictDmd, strictifyDmd ) where #include "GhclibHsVersions.h" import GhcPrelude import DynFlags import Outputable import Var ( Var ) import VarEnv import UniqFM import Util import BasicTypes import Binary import Maybes ( orElse ) import Type ( Type ) import TyCon ( isNewTyCon, isClassTyCon ) import DataCon ( splitDataProductType_maybe ) {- ************************************************************************ * * Joint domain for Strictness and Absence * * ************************************************************************ -} data JointDmd s u = JD { sd :: s, ud :: u } deriving ( Eq, Show ) getStrDmd :: JointDmd s u -> s getStrDmd = sd getUseDmd :: JointDmd s u -> u getUseDmd = ud -- Pretty-printing instance (Outputable s, Outputable u) => Outputable (JointDmd s u) where ppr (JD {sd = s, ud = u}) = angleBrackets (ppr s <> char ',' <> ppr u) -- Well-formedness preserving constructors for the joint domain mkJointDmd :: s -> u -> JointDmd s u mkJointDmd s u = JD { sd = s, ud = u } mkJointDmds :: [s] -> [u] -> [JointDmd s u] mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as {- ************************************************************************ * * Strictness domain * * ************************************************************************ Lazy | HeadStr / \ SCall SProd \ / HyperStr Note [Exceptions and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to smart about catching exceptions, but we aren't anymore. See #14998 for the way it's resolved at the moment. Here's a historic breakdown: Apparently, exception handling prim-ops didn't use to have any special strictness signatures, thus defaulting to topSig, which assumes they use their arguments lazily. Joachim was the first to realise that we could provide richer information. Thus, in 0558911f91c (Dec 13), he added signatures to primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call their argument, which is useful information for usage analysis. Still with a 'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine. In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a 'strictApply1Dmd' leads to substantial performance gains. That was at the cost of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in 28638dfe79e (Dec 15). Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712, Ben opened #11222. Simon made the demand analyser "understand catch" in 9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call its argument strictly, but also swallow any thrown exceptions in 'postProcessDmdResult'. This was realized by extending the 'Str' constructor of 'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and adding a 'ThrowsExn' constructor to the 'Termination' lattice as an element between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330, so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17). This left the other variants like 'catchRetry#' having 'catchArgDmd', which is where #14998 picked up. Item 1 was concerned with measuring the impact of also making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7 (Apr 18). There was a lot of dead code resulting from that change, that we removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and removed any code that was dealing with the peculiarities. Where did the speed-ups vanish to? In #14998, item 3 established that turning 'catch#' strict in its first argument didn't bring back any of the alleged performance benefits. Item 2 of that ticket finally found out that it was entirely due to 'catchException's new (since #11555) definition, which was simply catchException !io handler = catch io handler While 'catchException' is arguably the saner semantics for 'catch', it is an internal helper function in "GHC.IO". Its use in "GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences: Remove the bang and you find the regressions we originally wanted to avoid with 'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO". So history keeps telling us that the only possibly correct strictness annotation for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really is not strict in its argument: Just try this in GHCi :set -XScopedTypeVariables import Control.Exception catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this") Any analysis that assumes otherwise will be broken in some way or another (beyond `-fno-pendantic-bottoms`). -} -- | Vanilla strictness domain data StrDmd = HyperStr -- ^ Hyper-strict (bottom of the lattice). -- See Note [HyperStr and Use demands] | SCall StrDmd -- ^ Call demand -- Used only for values of function type | SProd [ArgStr] -- ^ Product -- Used only for values of product type -- Invariant: not all components are HyperStr (use HyperStr) -- not all components are Lazy (use HeadStr) | HeadStr -- ^ Head-Strict -- A polymorphic demand: used for values of all types, -- including a type variable deriving ( Eq, Show ) -- | Strictness of a function argument. type ArgStr = Str StrDmd -- | Strictness demand. data Str s = Lazy -- ^ Lazy (top of the lattice) | Str s -- ^ Strict deriving ( Eq, Show ) -- Well-formedness preserving constructors for the Strictness domain strBot, strTop :: ArgStr strBot = Str HyperStr strTop = Lazy mkSCall :: StrDmd -> StrDmd mkSCall HyperStr = HyperStr mkSCall s = SCall s mkSProd :: [ArgStr] -> StrDmd mkSProd sx | any isHyperStr sx = HyperStr | all isLazy sx = HeadStr | otherwise = SProd sx isLazy :: ArgStr -> Bool isLazy Lazy = True isLazy (Str {}) = False isHyperStr :: ArgStr -> Bool isHyperStr (Str HyperStr) = True isHyperStr _ = False -- Pretty-printing instance Outputable StrDmd where ppr HyperStr = char 'B' ppr (SCall s) = char 'C' <> parens (ppr s) ppr HeadStr = char 'S' ppr (SProd sx) = char 'S' <> parens (hcat (map ppr sx)) instance Outputable ArgStr where ppr (Str s) = ppr s ppr Lazy = char 'L' lubArgStr :: ArgStr -> ArgStr -> ArgStr lubArgStr Lazy _ = Lazy lubArgStr _ Lazy = Lazy lubArgStr (Str s1) (Str s2) = Str (s1 `lubStr` s2) lubStr :: StrDmd -> StrDmd -> StrDmd lubStr HyperStr s = s lubStr (SCall s1) HyperStr = SCall s1 lubStr (SCall _) HeadStr = HeadStr lubStr (SCall s1) (SCall s2) = SCall (s1 `lubStr` s2) lubStr (SCall _) (SProd _) = HeadStr lubStr (SProd sx) HyperStr = SProd sx lubStr (SProd _) HeadStr = HeadStr lubStr (SProd s1) (SProd s2) | s1 `equalLength` s2 = mkSProd (zipWith lubArgStr s1 s2) | otherwise = HeadStr lubStr (SProd _) (SCall _) = HeadStr lubStr HeadStr _ = HeadStr bothArgStr :: ArgStr -> ArgStr -> ArgStr bothArgStr Lazy s = s bothArgStr s Lazy = s bothArgStr (Str s1) (Str s2) = Str (s1 `bothStr` s2) bothStr :: StrDmd -> StrDmd -> StrDmd bothStr HyperStr _ = HyperStr bothStr HeadStr s = s bothStr (SCall _) HyperStr = HyperStr bothStr (SCall s1) HeadStr = SCall s1 bothStr (SCall s1) (SCall s2) = SCall (s1 `bothStr` s2) bothStr (SCall _) (SProd _) = HyperStr -- Weird bothStr (SProd _) HyperStr = HyperStr bothStr (SProd s1) HeadStr = SProd s1 bothStr (SProd s1) (SProd s2) | s1 `equalLength` s2 = mkSProd (zipWith bothArgStr s1 s2) | otherwise = HyperStr -- Weird bothStr (SProd _) (SCall _) = HyperStr -- utility functions to deal with memory leaks seqStrDmd :: StrDmd -> () seqStrDmd (SProd ds) = seqStrDmdList ds seqStrDmd (SCall s) = seqStrDmd s seqStrDmd _ = () seqStrDmdList :: [ArgStr] -> () seqStrDmdList [] = () seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds seqArgStr :: ArgStr -> () seqArgStr Lazy = () seqArgStr (Str s) = seqStrDmd s -- Splitting polymorphic demands splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr] splitArgStrProdDmd n Lazy = Just (replicate n Lazy) splitArgStrProdDmd n (Str s) = splitStrProdDmd n s splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr] splitStrProdDmd n HyperStr = Just (replicate n strBot) splitStrProdDmd n HeadStr = Just (replicate n strTop) splitStrProdDmd n (SProd ds) = WARN( not (ds `lengthIs` n), text "splitStrProdDmd" $$ ppr n $$ ppr ds ) Just ds splitStrProdDmd _ (SCall {}) = Nothing -- This can happen when the programmer uses unsafeCoerce, -- and we don't then want to crash the compiler (#9208) {- ************************************************************************ * * Absence domain * * ************************************************************************ Used / \ UCall UProd \ / UHead | Count x - | Abs -} -- | Domain for genuine usage data UseDmd = UCall Count UseDmd -- ^ Call demand for absence. -- Used only for values of function type | UProd [ArgUse] -- ^ Product. -- Used only for values of product type -- See Note [Don't optimise UProd(Used) to Used] -- -- Invariant: Not all components are Abs -- (in that case, use UHead) | UHead -- ^ May be used but its sub-components are -- definitely *not* used. For product types, UHead -- is equivalent to U(AAA); see mkUProd. -- -- UHead is needed only to express the demand -- of 'seq' and 'case' which are polymorphic; -- i.e. the scrutinised value is of type 'a' -- rather than a product type. That's why we -- can't use UProd [A,A,A] -- -- Since (UCall _ Abs) is ill-typed, UHead doesn't -- make sense for lambdas | Used -- ^ May be used and its sub-components may be used. -- (top of the lattice) deriving ( Eq, Show ) -- Extended usage demand for absence and counting type ArgUse = Use UseDmd data Use u = Abs -- Definitely unused -- Bottom of the lattice | Use Count u -- May be used with some cardinality deriving ( Eq, Show ) -- | Abstract counting of usages data Count = One | Many deriving ( Eq, Show ) -- Pretty-printing instance Outputable ArgUse where ppr Abs = char 'A' ppr (Use Many a) = ppr a ppr (Use One a) = char '1' <> char '*' <> ppr a instance Outputable UseDmd where ppr Used = char 'U' ppr (UCall c a) = char 'C' <> ppr c <> parens (ppr a) ppr UHead = char 'H' ppr (UProd as) = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as))) instance Outputable Count where ppr One = char '1' ppr Many = text "" useBot, useTop :: ArgUse useBot = Abs useTop = Use Many Used mkUCall :: Count -> UseDmd -> UseDmd --mkUCall c Used = Used c mkUCall c a = UCall c a mkUProd :: [ArgUse] -> UseDmd mkUProd ux | all (== Abs) ux = UHead | otherwise = UProd ux lubCount :: Count -> Count -> Count lubCount _ Many = Many lubCount Many _ = Many lubCount x _ = x lubArgUse :: ArgUse -> ArgUse -> ArgUse lubArgUse Abs x = x lubArgUse x Abs = x lubArgUse (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2) lubUse :: UseDmd -> UseDmd -> UseDmd lubUse UHead u = u lubUse (UCall c u) UHead = UCall c u lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2) lubUse (UCall _ _) _ = Used lubUse (UProd ux) UHead = UProd ux lubUse (UProd ux1) (UProd ux2) | ux1 `equalLength` ux2 = UProd $ zipWith lubArgUse ux1 ux2 | otherwise = Used lubUse (UProd {}) (UCall {}) = Used -- lubUse (UProd {}) Used = Used lubUse (UProd ux) Used = UProd (map (`lubArgUse` useTop) ux) lubUse Used (UProd ux) = UProd (map (`lubArgUse` useTop) ux) lubUse Used _ = Used -- Note [Used should win] -- `both` is different from `lub` in its treatment of counting; if -- `both` is computed for two used, the result always has -- cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain). -- Also, x `bothUse` x /= x (for anything but Abs). bothArgUse :: ArgUse -> ArgUse -> ArgUse bothArgUse Abs x = x bothArgUse x Abs = x bothArgUse (Use _ a1) (Use _ a2) = Use Many (bothUse a1 a2) bothUse :: UseDmd -> UseDmd -> UseDmd bothUse UHead u = u bothUse (UCall c u) UHead = UCall c u -- Exciting special treatment of inner demand for call demands: -- use `lubUse` instead of `bothUse`! bothUse (UCall _ u1) (UCall _ u2) = UCall Many (u1 `lubUse` u2) bothUse (UCall {}) _ = Used bothUse (UProd ux) UHead = UProd ux bothUse (UProd ux1) (UProd ux2) | ux1 `equalLength` ux2 = UProd $ zipWith bothArgUse ux1 ux2 | otherwise = Used bothUse (UProd {}) (UCall {}) = Used -- bothUse (UProd {}) Used = Used -- Note [Used should win] bothUse Used (UProd ux) = UProd (map (`bothArgUse` useTop) ux) bothUse (UProd ux) Used = UProd (map (`bothArgUse` useTop) ux) bothUse Used _ = Used -- Note [Used should win] peelUseCall :: UseDmd -> Maybe (Count, UseDmd) peelUseCall (UCall c u) = Just (c,u) peelUseCall _ = Nothing addCaseBndrDmd :: Demand -- On the case binder -> [Demand] -- On the components of the constructor -> [Demand] -- Final demands for the components of the constructor -- See Note [Demand on case-alternative binders] addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds = case mu of Abs -> alt_dmds Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us) where Just ss = splitArgStrProdDmd arity ms -- Guaranteed not to be a call Just us = splitUseProdDmd arity u -- Ditto where arity = length alt_dmds {- Note [Demand on case-alternative binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The demand on a binder in a case alternative comes (a) From the demand on the binder itself (b) From the demand on the case binder Forgetting (b) led directly to #10148. Example. Source code: f x@(p,_) = if p then foo x else True foo (p,True) = True foo (p,q) = foo (q,p) After strictness analysis: f = \ (x_an1 [Dmd=] :: (Bool, Bool)) -> case x_an1 of wild_X7 [Dmd=] { (p_an2 [Dmd=], ds_dnz [Dmd=]) -> case p_an2 of _ { False -> GHC.Types.True; True -> foo wild_X7 } It's true that ds_dnz is *itself* absent, but the use of wild_X7 means that it is very much alive and demanded. See #10148 for how the consequences play out. This is needed even for non-product types, in case the case-binder is used but the components of the case alternative are not. Note [Don't optimise UProd(Used) to Used] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ These two UseDmds: UProd [Used, Used] and Used are semantically equivalent, but we do not turn the former into the latter, for a regrettable-subtle reason. Suppose we did. then f (x,y) = (y,x) would get StrDmd = Str = SProd [Lazy, Lazy] UseDmd = Used = UProd [Used, Used] But with the joint demand of doesn't convey any clue that there is a product involved, and so the worthSplittingFun will not fire. (We'd need to use the type as well to make it fire.) Moreover, consider g h p@(_,_) = h p This too would get , but this time there really isn't any point in w/w since the components of the pair are not used at all. So the solution is: don't aggressively collapse UProd [Used,Used] to Used; intead leave it as-is. In effect we are using the UseDmd to do a little bit of boxity analysis. Not very nice. Note [Used should win] ~~~~~~~~~~~~~~~~~~~~~~ Both in lubUse and bothUse we want (Used `both` UProd us) to be Used. Why? Because Used carries the implication the whole thing is used, box and all, so we don't want to w/w it. If we use it both boxed and unboxed, then we are definitely using the box, and so we are quite likely to pay a reboxing cost. So we make Used win here. Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer Baseline: (A) Not making Used win (UProd wins) Compare with: (B) making Used win for lub and both Min -0.3% -5.6% -10.7% -11.0% -33.3% Max +0.3% +45.6% +11.5% +11.5% +6.9% Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8% Baseline: (B) Making Used win for both lub and both Compare with: (C) making Used win for both, but UProd win for lub Min -0.1% -0.3% -7.9% -8.0% -6.5% Max +0.1% +1.0% +21.0% +21.0% +0.5% Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1% -} -- If a demand is used multiple times (i.e. reused), than any use-once -- mentioned there, that is not protected by a UCall, can happen many times. markReusedDmd :: ArgUse -> ArgUse markReusedDmd Abs = Abs markReusedDmd (Use _ a) = Use Many (markReused a) markReused :: UseDmd -> UseDmd markReused (UCall _ u) = UCall Many u -- No need to recurse here markReused (UProd ux) = UProd (map markReusedDmd ux) markReused u = u isUsedMU :: ArgUse -> Bool -- True <=> markReusedDmd d = d isUsedMU Abs = True isUsedMU (Use One _) = False isUsedMU (Use Many u) = isUsedU u isUsedU :: UseDmd -> Bool -- True <=> markReused d = d isUsedU Used = True isUsedU UHead = True isUsedU (UProd us) = all isUsedMU us isUsedU (UCall One _) = False isUsedU (UCall Many _) = True -- No need to recurse -- Squashing usage demand demands seqUseDmd :: UseDmd -> () seqUseDmd (UProd ds) = seqArgUseList ds seqUseDmd (UCall c d) = c `seq` seqUseDmd d seqUseDmd _ = () seqArgUseList :: [ArgUse] -> () seqArgUseList [] = () seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds seqArgUse :: ArgUse -> () seqArgUse (Use c u) = c `seq` seqUseDmd u seqArgUse _ = () -- Splitting polymorphic Maybe-Used demands splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse] splitUseProdDmd n Used = Just (replicate n useTop) splitUseProdDmd n UHead = Just (replicate n Abs) splitUseProdDmd n (UProd ds) = WARN( not (ds `lengthIs` n), text "splitUseProdDmd" $$ ppr n $$ ppr ds ) Just ds splitUseProdDmd _ (UCall _ _) = Nothing -- This can happen when the programmer uses unsafeCoerce, -- and we don't then want to crash the compiler (#9208) useCount :: Use u -> Count useCount Abs = One useCount (Use One _) = One useCount _ = Many {- ************************************************************************ * * Clean demand for Strictness and Usage * * ************************************************************************ This domain differst from JointDemand in the sence that pure absence is taken away, i.e., we deal *only* with non-absent demands. Note [Strict demands] ~~~~~~~~~~~~~~~~~~~~~ isStrictDmd returns true only of demands that are both strict and used In particular, it is False for , which can and does arise in, say (#7319) f x = raise# Then 'x' is not used, so f gets strictness -> . Now the w/w generates fx = let x = absentError "unused" in raise At this point we really don't want to convert to fx = case absentError "unused" of x -> raise Since the program is going to diverge, this swaps one error for another, but it's really a bad idea to *ever* evaluate an absent argument. In #7319 we get T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}] Note [Dealing with call demands] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Call demands are constructed and deconstructed coherently for strictness and absence. For instance, the strictness signature for the following function f :: (Int -> (Int, Int)) -> (Int, Bool) f g = (snd (g 3), True) should be: m -} type CleanDemand = JointDmd StrDmd UseDmd -- A demand that is at least head-strict bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2}) = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 } mkHeadStrict :: CleanDemand -> CleanDemand mkHeadStrict cd = cd { sd = HeadStr } mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use One a } mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use Many a } evalDmd :: Demand -- Evaluated strictly, and used arbitrarily deeply evalDmd = JD { sd = Str HeadStr, ud = useTop } mkProdDmd :: [Demand] -> CleanDemand mkProdDmd dx = JD { sd = mkSProd $ map getStrDmd dx , ud = mkUProd $ map getUseDmd dx } -- | Wraps the 'CleanDemand' with a one-shot call demand: @d@ -> @C1(d)@. mkCallDmd :: CleanDemand -> CleanDemand mkCallDmd (JD {sd = d, ud = u}) = JD { sd = mkSCall d, ud = mkUCall One u } -- | @mkCallDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s. mkCallDmds :: Arity -> CleanDemand -> CleanDemand mkCallDmds arity cd = iterate mkCallDmd cd !! arity -- See Note [Demand on the worker] in WorkWrap mkWorkerDemand :: Int -> Demand mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) } where go 0 = Used go n = mkUCall One $ go (n-1) cleanEvalDmd :: CleanDemand cleanEvalDmd = JD { sd = HeadStr, ud = Used } cleanEvalProdDmd :: Arity -> CleanDemand cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) } {- ************************************************************************ * * Demand: combining stricness and usage * * ************************************************************************ -} type Demand = JointDmd ArgStr ArgUse lubDmd :: Demand -> Demand -> Demand lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) = JD { sd = s1 `lubArgStr` s2 , ud = a1 `lubArgUse` a2 } bothDmd :: Demand -> Demand -> Demand bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) = JD { sd = s1 `bothArgStr` s2 , ud = a1 `bothArgUse` a2 } lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd :: Demand strictApply1Dmd = JD { sd = Str (SCall HeadStr) , ud = Use Many (UCall One Used) } lazyApply1Dmd = JD { sd = Lazy , ud = Use One (UCall One Used) } -- Second argument of catch#: -- uses its arg at most once, applies it once -- but is lazy (might not be called at all) lazyApply2Dmd = JD { sd = Lazy , ud = Use One (UCall One (UCall One Used)) } absDmd :: Demand absDmd = JD { sd = Lazy, ud = Abs } topDmd :: Demand topDmd = JD { sd = Lazy, ud = useTop } botDmd :: Demand botDmd = JD { sd = strBot, ud = useBot } seqDmd :: Demand seqDmd = JD { sd = Str HeadStr, ud = Use One UHead } oneifyDmd :: JointDmd s (Use u) -> JointDmd s (Use u) oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a } oneifyDmd jd = jd isTopDmd :: Demand -> Bool -- Used to suppress pretty-printing of an uninformative demand isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True isTopDmd _ = False isAbsDmd :: JointDmd (Str s) (Use u) -> Bool isAbsDmd (JD {ud = Abs}) = True -- The strictness part can be HyperStr isAbsDmd _ = False -- for a bottom demand isSeqDmd :: Demand -> Bool isSeqDmd (JD {sd = Str HeadStr, ud = Use _ UHead}) = True isSeqDmd _ = False isUsedOnce :: JointDmd (Str s) (Use u) -> Bool isUsedOnce (JD { ud = a }) = case useCount a of One -> True Many -> False -- More utility functions for strictness seqDemand :: Demand -> () seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u seqDemandList :: [Demand] -> () seqDemandList [] = () seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds isStrictDmd :: JointDmd (Str s) (Use u) -> Bool -- See Note [Strict demands] isStrictDmd (JD {ud = Abs}) = False isStrictDmd (JD {sd = Lazy}) = False isStrictDmd _ = True isWeakDmd :: Demand -> Bool isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a cleanUseDmd_maybe :: Demand -> Maybe UseDmd cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u cleanUseDmd_maybe _ = Nothing splitFVs :: Bool -- Thunk -> DmdEnv -> (DmdEnv, DmdEnv) splitFVs is_thunk rhs_fvs | is_thunk = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs -- It's OK to use nonDetFoldUFM_Directly because we -- immediately forget the ordering by putting the elements -- in the envs again | otherwise = partitionVarEnv isWeakDmd rhs_fvs where add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv) | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv) | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u }) , addToUFM_Directly sig_fv uniq (JD { sd = s, ud = Abs }) ) data TypeShape = TsFun TypeShape | TsProd [TypeShape] | TsUnk instance Outputable TypeShape where ppr TsUnk = text "TsUnk" ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) -- | @peelTsFuns n ts@ tries to peel off @n@ 'TsFun' constructors from @ts@ and -- returns 'Just' the wrapped 'TypeShape' on success, and 'Nothing' otherwise. peelTsFuns :: Arity -> TypeShape -> Maybe TypeShape peelTsFuns 0 ts = Just ts peelTsFuns n (TsFun ts) = peelTsFuns (n-1) ts peelTsFuns _ _ = Nothing trimToType :: Demand -> TypeShape -> Demand -- See Note [Trimming a demand to a type] trimToType (JD { sd = ms, ud = mu }) ts = JD (go_ms ms ts) (go_mu mu ts) where go_ms :: ArgStr -> TypeShape -> ArgStr go_ms Lazy _ = Lazy go_ms (Str s) ts = Str (go_s s ts) go_s :: StrDmd -> TypeShape -> StrDmd go_s HyperStr _ = HyperStr go_s (SCall s) (TsFun ts) = SCall (go_s s ts) go_s (SProd mss) (TsProd tss) | equalLength mss tss = SProd (zipWith go_ms mss tss) go_s _ _ = HeadStr go_mu :: ArgUse -> TypeShape -> ArgUse go_mu Abs _ = Abs go_mu (Use c u) ts = Use c (go_u u ts) go_u :: UseDmd -> TypeShape -> UseDmd go_u UHead _ = UHead go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts) go_u (UProd mus) (TsProd tss) | equalLength mus tss = UProd (zipWith go_mu mus tss) go_u _ _ = Used {- Note [Trimming a demand to a type] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this: f :: a -> Bool f x = case ... of A g1 -> case (x |> g1) of (p,q) -> ... B -> error "urk" where A,B are the constructors of a GADT. We'll get a U(U,U) demand on x from the A branch, but that's a stupid demand for x itself, which has type 'a'. Indeed we get ASSERTs going off (notably in splitUseProdDmd, #8569). Bottom line: we really don't want to have a binder whose demand is more deeply-nested than its type. There are various ways to tackle this. When processing (x |> g1), we could "trim" the incoming demand U(U,U) to match x's type. But I'm currently doing so just at the moment when we pin a demand on a binder, in DmdAnal.findBndrDmd. Note [Threshold demands] ~~~~~~~~~~~~~~~~~~~~~~~~ Threshold usage demand is generated to figure out if cardinality-instrumented demands of a binding's free variables should be unleashed. See also [Aggregated demand for cardinality]. Note [Replicating polymorphic demands] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some demands can be considered as polymorphic. Generally, it is applicable to such beasts as tops, bottoms as well as Head-Used and Head-stricts demands. For instance, S ~ S(L, ..., L) Also, when top or bottom is occurred as a result demand, it in fact can be expanded to saturate a callee's arity. -} splitProdDmd_maybe :: Demand -> Maybe [Demand] -- Split a product into its components, iff there is any -- useful information to be extracted thereby -- The demand is not necessarily strict! splitProdDmd_maybe (JD { sd = s, ud = u }) = case (s,u) of (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u -> Just (mkJointDmds sx ux) (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s -> Just (mkJointDmds sx ux) (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) _ -> Nothing {- ************************************************************************ * * Demand results * * ************************************************************************ DmdResult: Dunno CPRResult / Diverges CPRResult: NoCPR / \ RetProd RetSum ConTag Product constructors return (Dunno (RetProd rs)) In a fixpoint iteration, start from Diverges We have lubs, but not glbs; but that is ok. -} ------------------------------------------------------------------------ -- Constructed Product Result ------------------------------------------------------------------------ data Termination r = Diverges -- Definitely diverges | Dunno r -- Might diverge or converge deriving( Eq, Show ) -- At this point, Termination is just the 'Lifted' lattice over 'r' -- (https://hackage.haskell.org/package/lattices/docs/Algebra-Lattice-Lifted.html) type DmdResult = Termination CPRResult data CPRResult = NoCPR -- Top of the lattice | RetProd -- Returns a constructor from a product type | RetSum ConTag -- Returns a constructor from a data type deriving( Eq, Show ) lubCPR :: CPRResult -> CPRResult -> CPRResult lubCPR (RetSum t1) (RetSum t2) | t1 == t2 = RetSum t1 lubCPR RetProd RetProd = RetProd lubCPR _ _ = NoCPR lubDmdResult :: DmdResult -> DmdResult -> DmdResult lubDmdResult Diverges r = r lubDmdResult r Diverges = r lubDmdResult (Dunno c1) (Dunno c2) = Dunno (c1 `lubCPR` c2) -- This needs to commute with defaultDmd, i.e. -- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2 -- (See Note [Default demand on free variables] for why) bothDmdResult :: DmdResult -> Termination () -> DmdResult -- See Note [Asymmetry of 'both' for DmdType and DmdResult] bothDmdResult _ Diverges = Diverges bothDmdResult r (Dunno {}) = r -- This needs to commute with defaultDmd, i.e. -- defaultDmd (r1 `bothDmdResult` r2) = defaultDmd r1 `bothDmd` defaultDmd r2 -- (See Note [Default demand on free variables] for why) instance Outputable r => Outputable (Termination r) where ppr Diverges = char 'b' ppr (Dunno c) = ppr c instance Outputable CPRResult where ppr NoCPR = empty ppr (RetSum n) = char 'm' <> int n ppr RetProd = char 'm' seqDmdResult :: DmdResult -> () seqDmdResult Diverges = () seqDmdResult (Dunno c) = seqCPRResult c seqCPRResult :: CPRResult -> () seqCPRResult NoCPR = () seqCPRResult (RetSum n) = n `seq` () seqCPRResult RetProd = () ------------------------------------------------------------------------ -- Combined demand result -- ------------------------------------------------------------------------ -- [cprRes] lets us switch off CPR analysis -- by making sure that everything uses TopRes topRes, botRes :: DmdResult topRes = Dunno NoCPR botRes = Diverges cprSumRes :: ConTag -> DmdResult cprSumRes tag = Dunno $ RetSum tag cprProdRes :: [DmdType] -> DmdResult cprProdRes _arg_tys = Dunno $ RetProd vanillaCprProdRes :: Arity -> DmdResult vanillaCprProdRes _arity = Dunno $ RetProd isTopRes :: DmdResult -> Bool isTopRes (Dunno NoCPR) = True isTopRes _ = False -- | True if the result diverges or throws an exception isBotRes :: DmdResult -> Bool isBotRes Diverges = True isBotRes (Dunno {}) = False trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult trimCPRInfo trim_all trim_sums res = trimR res where trimR (Dunno c) = Dunno (trimC c) trimR res = res trimC (RetSum n) | trim_all || trim_sums = NoCPR | otherwise = RetSum n trimC RetProd | trim_all = NoCPR | otherwise = RetProd trimC NoCPR = NoCPR returnsCPR_maybe :: DmdResult -> Maybe ConTag returnsCPR_maybe (Dunno c) = retCPR_maybe c returnsCPR_maybe _ = Nothing retCPR_maybe :: CPRResult -> Maybe ConTag retCPR_maybe (RetSum t) = Just t retCPR_maybe RetProd = Just fIRST_TAG retCPR_maybe NoCPR = Nothing -- See Notes [Default demand on free variables] -- and [defaultDmd vs. resTypeArgDmd] defaultDmd :: Termination r -> Demand defaultDmd (Dunno {}) = absDmd defaultDmd _ = botDmd -- Diverges resTypeArgDmd :: Termination r -> Demand -- TopRes and BotRes are polymorphic, so that -- BotRes === (Bot -> BotRes) === ... -- TopRes === (Top -> TopRes) === ... -- This function makes that concrete -- Also see Note [defaultDmd vs. resTypeArgDmd] resTypeArgDmd (Dunno _) = topDmd resTypeArgDmd _ = botDmd -- Diverges {- Note [defaultDmd and resTypeArgDmd] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ These functions are similar: They express the demand on something not explicitly mentioned in the environment resp. the argument list. Yet they are different: * Variables not mentioned in the free variables environment are definitely unused, so we can use absDmd there. * Further arguments *can* be used, of course. Hence topDmd is used. ************************************************************************ * * Demand environments and types * * ************************************************************************ -} type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables] data DmdType = DmdType DmdEnv -- Demand on explicitly-mentioned -- free variables [Demand] -- Demand on arguments DmdResult -- See [Nature of result demand] {- Note [Nature of result demand] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A DmdResult contains information about termination (currently distinguishing definite divergence and no information; it is possible to include definite convergence here), and CPR information about the result. The semantics of this depends on whether we are looking at a DmdType, i.e. the demand put on by an expression _under a specific incoming demand_ on its environment, or at a StrictSig describing a demand transformer. For a * DmdType, the termination information is true given the demand it was generated with, while for * a StrictSig it holds after applying enough arguments. The CPR information, though, is valid after the number of arguments mentioned in the type is given. Therefore, when forgetting the demand on arguments, as in dmdAnalRhs, this needs to be considere (via removeDmdTyArgs). Consider b2 x y = x `seq` y `seq` error (show x) this has a strictness signature of b meaning that "b2 `seq` ()" and "b2 1 `seq` ()" might well terminate, but for "b2 1 2 `seq` ()" we get definite divergence. For comparison, b1 x = x `seq` error (show x) has a strictness signature of b and "b1 1 `seq` ()" is known to terminate. Now consider a function h with signature "", and the expression e1 = h b1 now h puts a demand of onto its argument, and the demand transformer turns it into b Now the DmdResult "b" does apply to us, even though "b1 `seq` ()" does not diverge, and we do not anything being passed to b. Note [Asymmetry of 'both' for DmdType and DmdResult] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'both' for DmdTypes is *asymmetrical*, because there is only one result! For example, given (e1 e2), we get a DmdType dt1 for e1, use its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2). Similarly with case e of { p -> rhs } we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then compute (dt_rhs `bothType` dt_scrut). We 1. combine the information on the free variables, 2. take the demand on arguments from the first argument 3. combine the termination results, but 4. take CPR info from the first argument. 3 and 4 are implementd in bothDmdResult. -} -- Equality needed for fixpoints in DmdAnal instance Eq DmdType where (==) (DmdType fv1 ds1 res1) (DmdType fv2 ds2 res2) = nonDetUFMToList fv1 == nonDetUFMToList fv2 -- It's OK to use nonDetUFMToList here because we're testing for -- equality and even though the lists will be in some arbitrary -- Unique order, it is the same order for both && ds1 == ds2 && res1 == res2 lubDmdType :: DmdType -> DmdType -> DmdType lubDmdType d1 d2 = DmdType lub_fv lub_ds lub_res where n = max (dmdTypeDepth d1) (dmdTypeDepth d2) (DmdType fv1 ds1 r1) = ensureArgs n d1 (DmdType fv2 ds2 r2) = ensureArgs n d2 lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2) lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 lub_res = lubDmdResult r1 r2 {- Note [The need for BothDmdArg] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Previously, the right argument to bothDmdType, as well as the return value of dmdAnalStar via postProcessDmdType, was a DmdType. But bothDmdType only needs to know about the free variables and termination information, but nothing about the demand put on arguments, nor cpr information. So we make that explicit by only passing the relevant information. -} type BothDmdArg = (DmdEnv, Termination ()) mkBothDmdArg :: DmdEnv -> BothDmdArg mkBothDmdArg env = (env, Dunno ()) toBothDmdArg :: DmdType -> BothDmdArg toBothDmdArg (DmdType fv _ r) = (fv, go r) where go (Dunno {}) = Dunno () go Diverges = Diverges bothDmdType :: DmdType -> BothDmdArg -> DmdType bothDmdType (DmdType fv1 ds1 r1) (fv2, t2) -- See Note [Asymmetry of 'both' for DmdType and DmdResult] -- 'both' takes the argument/result info from its *first* arg, -- using its second arg just for its free-var info. = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2)) ds1 (r1 `bothDmdResult` t2) instance Outputable DmdType where ppr (DmdType fv ds res) = hsep [hcat (map ppr ds) <> ppr res, if null fv_elts then empty else braces (fsep (map pp_elt fv_elts))] where pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd fv_elts = nonDetUFMToList fv -- It's OK to use nonDetUFMToList here because we only do it for -- pretty printing emptyDmdEnv :: VarEnv Demand emptyDmdEnv = emptyVarEnv -- nopDmdType is the demand of doing nothing -- (lazy, absent, no CPR information, no termination information). -- Note that it is ''not'' the top of the lattice (which would be "may use everything"), -- so it is (no longer) called topDmd nopDmdType, botDmdType :: DmdType nopDmdType = DmdType emptyDmdEnv [] topRes botDmdType = DmdType emptyDmdEnv [] botRes cprProdDmdType :: Arity -> DmdType cprProdDmdType arity = DmdType emptyDmdEnv [] (vanillaCprProdRes arity) isTopDmdType :: DmdType -> Bool isTopDmdType (DmdType env [] res) | isTopRes res && isEmptyVarEnv env = True isTopDmdType _ = False mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType mkDmdType fv ds res = DmdType fv ds res dmdTypeDepth :: DmdType -> Arity dmdTypeDepth (DmdType _ ds _) = length ds -- | This makes sure we can use the demand type with n arguments. -- It extends the argument list with the correct resTypeArgDmd. -- It also adjusts the DmdResult: Divergence survives additional arguments, -- CPR information does not (and definite converge also would not). ensureArgs :: Arity -> DmdType -> DmdType ensureArgs n d | n == depth = d | otherwise = DmdType fv ds' r' where depth = dmdTypeDepth d DmdType fv ds r = d ds' = take n (ds ++ repeat (resTypeArgDmd r)) r' = case r of -- See [Nature of result demand] Dunno _ -> topRes _ -> r seqDmdType :: DmdType -> () seqDmdType (DmdType env ds res) = seqDmdEnv env `seq` seqDemandList ds `seq` seqDmdResult res `seq` () seqDmdEnv :: DmdEnv -> () seqDmdEnv env = seqEltsUFM seqDemandList env splitDmdTy :: DmdType -> (Demand, DmdType) -- Split off one function argument -- We already have a suitable demand on all -- free vars, so no need to add more! splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty) -- When e is evaluated after executing an IO action, and d is e's demand, then -- what of this demand should we consider, given that the IO action can cleanly -- exit? -- * We have to kill all strictness demands (i.e. lub with a lazy demand) -- * We can keep usage information (i.e. lub with an absent demand) -- * We have to kill definite divergence -- * We can keep CPR information. -- See Note [IO hack in the demand analyser] in DmdAnal deferAfterIO :: DmdType -> DmdType deferAfterIO d@(DmdType _ _ res) = case d `lubDmdType` nopDmdType of DmdType fv ds _ -> DmdType fv ds (defer_res res) where defer_res r@(Dunno {}) = r defer_res _ = topRes -- Diverges strictenDmd :: Demand -> CleanDemand strictenDmd (JD { sd = s, ud = u}) = JD { sd = poke_s s, ud = poke_u u } where poke_s Lazy = HeadStr poke_s (Str s) = s poke_u Abs = UHead poke_u (Use _ u) = u -- Deferring and peeling type DmdShell -- Describes the "outer shell" -- of a Demand = JointDmd (Str ()) (Use ()) toCleanDmd :: Demand -> (DmdShell, CleanDemand) -- Splits a Demand into its "shell" and the inner "clean demand" toCleanDmd (JD { sd = s, ud = u }) = (JD { sd = ss, ud = us }, JD { sd = s', ud = u' }) -- See Note [Analyzing with lazy demand and lambdas] -- See Note [Analysing with absent demand] where (ss, s') = case s of Str s' -> (Str (), s') Lazy -> (Lazy, HeadStr) (us, u') = case u of Use c u' -> (Use c (), u') Abs -> (Abs, Used) -- This is used in dmdAnalStar when post-processing -- a function's argument demand. So we only care about what -- does to free variables, and whether it terminates. -- see Note [The need for BothDmdArg] postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty) = (postProcessDmdEnv du fv, term_info) where term_info = case postProcessDmdResult ss res_ty of Dunno _ -> Dunno () Diverges -> Diverges postProcessDmdResult :: Str () -> DmdResult -> DmdResult postProcessDmdResult Lazy _ = topRes postProcessDmdResult _ res = res postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env | Abs <- us = emptyDmdEnv -- In this case (postProcessDmd ds) == id; avoid a redundant rebuild -- of the environment. Be careful, bad things will happen if this doesn't -- match postProcessDmd (see #13977). | Str _ <- ss , Use One _ <- us = env | otherwise = mapVarEnv (postProcessDmd ds) env -- For the Absent case just discard all usage information -- We only processed the thing at all to analyse the body -- See Note [Always analyse in virgin pass] reuseEnv :: DmdEnv -> DmdEnv reuseEnv = mapVarEnv (postProcessDmd (JD { sd = Str (), ud = Use Many () })) postProcessUnsat :: DmdShell -> DmdType -> DmdType postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty) = DmdType (postProcessDmdEnv ds fv) (map (postProcessDmd ds) args) (postProcessDmdResult ss res_ty) postProcessDmd :: DmdShell -> Demand -> Demand postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a}) = JD { sd = s', ud = a' } where s' = case ss of Lazy -> Lazy Str _ -> s a' = case us of Abs -> Abs Use Many _ -> markReusedDmd a Use One _ -> a -- Peels one call level from the demand, and also returns -- whether it was unsaturated (separately for strictness and usage) peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell) -- Exploiting the fact that -- on the strictness side C(B) = B -- and on the usage side C(U) = U peelCallDmd (JD {sd = s, ud = u}) = (JD { sd = s', ud = u' }, JD { sd = ss, ud = us }) where (s', ss) = case s of SCall s' -> (s', Str ()) HyperStr -> (HyperStr, Str ()) _ -> (HeadStr, Lazy) (u', us) = case u of UCall c u' -> (u', Use c ()) _ -> (Used, Use Many ()) -- The _ cases for usage includes UHead which seems a bit wrong -- because the body isn't used at all! -- c.f. the Abs case in toCleanDmd -- Peels that multiple nestings of calls clean demand and also returns -- whether it was unsaturated (separately for strictness and usage -- see Note [Demands from unsaturated function calls] peelManyCalls :: Int -> CleanDemand -> DmdShell peelManyCalls n (JD { sd = str, ud = abs }) = JD { sd = go_str n str, ud = go_abs n abs } where go_str :: Int -> StrDmd -> Str () -- True <=> unsaturated, defer go_str 0 _ = Str () go_str _ HyperStr = Str () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr) go_str n (SCall d') = go_str (n-1) d' go_str _ _ = Lazy go_abs :: Int -> UseDmd -> Use () -- Many <=> unsaturated, or at least go_abs 0 _ = Use One () -- one UCall Many in the demand go_abs n (UCall One d') = go_abs (n-1) d' go_abs _ _ = Use Many () {- Note [Demands from unsaturated function calls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a demand transformer d1 -> d2 -> r for f. If a sufficiently detailed demand is fed into this transformer, e.g arising from "f x1 x2" in a strict, use-once context, then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for the free variable environment) and furthermore the result information r is the one we want to use. An anonymous lambda is also an unsaturated function all (needs one argument, none given), so this applies to that case as well. But the demand fed into f might be less than . There are a few cases: * Not enough demand on the strictness side: - In that case, we need to zap all strictness in the demand on arguments and free variables. - Furthermore, we remove CPR information. It could be left, but given the incoming demand is not enough to evaluate so far we just do not bother. - And finally termination information: If r says that f diverges for sure, then this holds when the demand guarantees that two arguments are going to be passed. If the demand is lower, we may just as well converge. If we were tracking definite convegence, than that would still hold under a weaker demand than expected by the demand transformer. * Not enough demand from the usage side: The missing usage can be expanded using UCall Many, therefore this is subsumed by the third case: * At least one of the uses has a cardinality of Many. - Even if f puts a One demand on any of its argument or free variables, if we call f multiple times, we may evaluate this argument or free variable multiple times. So forget about any occurrence of "One" in the demand. In dmdTransformSig, we call peelManyCalls to find out if we are in any of these cases, and then call postProcessUnsat to reduce the demand appropriately. Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use peelCallDmd, which peels only one level, but also returns the demand put on the body of the function. -} peelFV :: DmdType -> Var -> (DmdType, Demand) peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) (DmdType fv' ds res, dmd) where fv' = fv `delVarEnv` id -- See Note [Default demand on free variables] dmd = lookupVarEnv fv id `orElse` defaultDmd res addDemand :: Demand -> DmdType -> DmdType addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res findIdDemand :: DmdType -> Var -> Demand findIdDemand (DmdType fv _ res) id = lookupVarEnv fv id `orElse` defaultDmd res {- Note [Default demand on free variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the variable is not mentioned in the environment of a demand type, its demand is taken to be a result demand of the type. For the stricness component, if the result demand is a Diverges, then we use HyperStr else we use Lazy For the usage component, we use Absent. So we use either absDmd or botDmd. Also note the equations for lubDmdResult (resp. bothDmdResult) noted there. Note [Always analyse in virgin pass] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Tricky point: make sure that we analyse in the 'virgin' pass. Consider rec { f acc x True = f (...rec { g y = ...g... }...) f acc x False = acc } In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. That might mean that we analyse the sub-expression containing the E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* E, but just returned botType. Then in the *next* (non-virgin) iteration for 'f', we might analyse E in a weaker demand, and that will trigger doing a fixpoint iteration for g. But *because it's not the virgin pass* we won't start g's iteration at bottom. Disaster. (This happened in $sfibToList' of nofib/spectral/fibheaps.) So in the virgin pass we make sure that we do analyse the expression at least once, to initialise its signatures. Note [Analyzing with lazy demand and lambdas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The insight for analyzing lambdas follows from the fact that for strictness S = C(L). This polymorphic expansion is critical for cardinality analysis of the following example: {-# NOINLINE build #-} build g = (g (:) [], g (:) []) h c z = build (\x -> let z1 = z ++ z in if c then \y -> x (y ++ z1) else \y -> x (z1 ++ y)) One can see that `build` assigns to `g` demand . Therefore, when analyzing the lambda `(\x -> ...)`, we expect each lambda \y -> ... to be annotated as "one-shot" one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a demand . This is achieved by, first, converting the lazy demand L into the strict S by the second clause of the analysis. Note [Analysing with absent demand] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we analyse an expression with demand . The "A" means "absent", so this expression will never be needed. What should happen? There are several wrinkles: * We *do* want to analyse the expression regardless. Reason: Note [Always analyse in virgin pass] But we can post-process the results to ignore all the usage demands coming back. This is done by postProcessDmdType. * In a previous incarnation of GHC we needed to be extra careful in the case of an *unlifted type*, because unlifted values are evaluated even if they are not used. Example (see #9254): f :: (() -> (# Int#, () #)) -> () -- Strictness signature is -- -- I.e. calls k, but discards first component of result f k = case k () of (# _, r #) -> r g :: Int -> () g y = f (\n -> (# case y of I# y2 -> y2, n #)) Here f's strictness signature says (correctly) that it calls its argument function and ignores the first component of its result. This is correct in the sense that it'd be fine to (say) modify the function so that always returned 0# in the first component. But in function g, we *will* evaluate the 'case y of ...', because it has type Int#. So 'y' will be evaluated. So we must record this usage of 'y', else 'g' will say 'y' is absent, and will w/w so that 'y' is bound to an aBSENT_ERROR thunk. However, the argument of toCleanDmd always satisfies the let/app invariant; so if it is unlifted it is also okForSpeculation, and so can be evaluated in a short finite time -- and that rules out nasty cases like the one above. (I'm not quite sure why this was a problem in an earlier version of GHC, but it isn't now.) ************************************************************************ * * Demand signatures * * ************************************************************************ In a let-bound Id we record its strictness info. In principle, this strictness info is a demand transformer, mapping a demand on the Id into a DmdType, which gives a) the free vars of the Id's value b) the Id's arguments c) an indication of the result of applying the Id to its arguments However, in fact we store in the Id an extremely emascuated demand transfomer, namely a single DmdType (Nevertheless we dignify StrictSig as a distinct type.) This DmdType gives the demands unleashed by the Id when it is applied to as many arguments as are given in by the arg demands in the DmdType. Also see Note [Nature of result demand] for the meaning of a DmdResult in a strictness signature. If an Id is applied to less arguments than its arity, it means that the demand on the function at a call site is weaker than the vanilla call demand, used for signature inference. Therefore we place a top demand on all arguments. Otherwise, the demand is specified by Id's signature. For example, the demand transformer described by the demand signature StrictSig (DmdType {x -> } m) says that when the function is applied to two arguments, it unleashes demand on the free var x, on the first arg, and on the second, then returning a constructor. If this same function is applied to one arg, all we can say is that it uses x with , and its arg with demand . Note [Understanding DmdType and StrictSig] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Demand types are sound approximations of an expression's semantics relative to the incoming demand we put the expression under. Consider the following expression: \x y -> x `seq` (y, 2*x) Here is a table with demand types resulting from different incoming demands we put that expression under. Note the monotonicity; a stronger incoming demand yields a more precise demand type: incoming demand | demand type ---------------------------------------------------- | {} | {} | {} Note that in the first example, the depth of the demand type was *higher* than the arity of the incoming call demand due to the anonymous lambda. The converse is also possible and happens when we unleash demand signatures. In @f x y@, the incoming call demand on f has arity 2. But if all we have is a demand signature with depth 1 for @f@ (which we can safely unleash, see below), the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1. So: Demand types are elicited by putting an expression under an incoming (call) demand, the arity of which can be lower or higher than the depth of the resulting demand type. In contrast, a demand signature summarises a function's semantics *without* immediately specifying the incoming demand it was produced under. Despite StrSig being a newtype wrapper around DmdType, it actually encodes two things: * The threshold (i.e., minimum arity) to unleash the signature * A demand type that is sound to unleash when the minimum arity requirement is met. Here comes the subtle part: The threshold is encoded in the wrapped demand type's depth! So in mkStrictSigForArity we make sure to trim the list of argument demands to the given threshold arity. Call sites will make sure that this corresponds to the arity of the call demand that elicited the wrapped demand type. See also Note [What are demand signatures?] in DmdAnal. Besides trimming argument demands, mkStrictSigForArity will also trim CPR information if necessary. -} -- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe -- to unleash. Better construct this through 'mkStrictSigForArity'. -- See Note [Understanding DmdType and StrictSig] newtype StrictSig = StrictSig DmdType deriving( Eq ) instance Outputable StrictSig where ppr (StrictSig ty) = ppr ty -- Used for printing top-level strictness pragmas in interface files pprIfaceStrictSig :: StrictSig -> SDoc pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) = hcat (map ppr dmds) <> ppr res -- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig' -- unleashable at that arity. See Note [Understanding DmdType and StrictSig] mkStrictSigForArity :: Arity -> DmdType -> StrictSig mkStrictSigForArity arity dmd_ty = StrictSig (ensureArgs arity dmd_ty) mkClosedStrictSig :: [Demand] -> DmdResult -> StrictSig mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res) splitStrictSig :: StrictSig -> ([Demand], DmdResult) splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) increaseStrictSigArity :: Int -> StrictSig -> StrictSig -- ^ Add extra arguments to a strictness signature. -- In contrast to 'etaExpandStrictSig', this /prepends/ additional argument -- demands and leaves CPR info intact. increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds res)) | isTopDmdType dmd_ty = sig | arity_increase == 0 = sig | arity_increase < 0 = WARN( True, text "increaseStrictSigArity:" <+> text "negative arity increase" <+> ppr arity_increase ) nopSig | otherwise = StrictSig (DmdType env dmds' res) where dmds' = replicate arity_increase topDmd ++ dmds etaExpandStrictSig :: Arity -> StrictSig -> StrictSig -- ^ We are expanding (\x y. e) to (\x y z. e z). -- In contrast to 'increaseStrictSigArity', this /appends/ extra arg demands if -- necessary, potentially destroying the signature's CPR property. etaExpandStrictSig arity (StrictSig dmd_ty) | arity < dmdTypeDepth dmd_ty -- an arity decrease must zap the whole signature, because it was possibly -- computed for a higher incoming call demand. = nopSig | otherwise = StrictSig $ ensureArgs arity dmd_ty isTopSig :: StrictSig -> Bool isTopSig (StrictSig ty) = isTopDmdType ty hasDemandEnvSig :: StrictSig -> Bool hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env) strictSigDmdEnv :: StrictSig -> DmdEnv strictSigDmdEnv (StrictSig (DmdType env _ _)) = env -- | True if the signature diverges or throws an exception isBottomingSig :: StrictSig -> Bool isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res nopSig, botSig :: StrictSig nopSig = StrictSig nopDmdType botSig = StrictSig botDmdType cprProdSig :: Arity -> StrictSig cprProdSig arity = StrictSig (cprProdDmdType arity) seqStrictSig :: StrictSig -> () seqStrictSig (StrictSig ty) = seqDmdType ty dmdTransformSig :: StrictSig -> CleanDemand -> DmdType -- (dmdTransformSig fun_sig dmd) considers a call to a function whose -- signature is fun_sig, with demand dmd. We return the demand -- that the function places on its context (eg its args) dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty -- see Note [Demands from unsaturated function calls] dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType -- Same as dmdTransformSig but for a data constructor (worker), -- which has a special kind of demand transformer. -- If the constructor is saturated, we feed the demand on -- the result into the constructor arguments. dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) (JD { sd = str, ud = abs }) | Just str_dmds <- go_str arity str , Just abs_dmds <- go_abs arity abs = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res -- Must remember whether it's a product, hence con_res, not TopRes | otherwise -- Not saturated = nopDmdType where go_str 0 dmd = splitStrProdDmd arity dmd go_str n (SCall s') = go_str (n-1) s' go_str n HyperStr = go_str (n-1) HyperStr go_str _ _ = Nothing go_abs 0 dmd = splitUseProdDmd arity dmd go_abs n (UCall One u') = go_abs (n-1) u' go_abs _ _ = Nothing dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType -- Like dmdTransformDataConSig, we have a special demand transformer -- for dictionary selectors. If the selector is saturated (ie has one -- argument: the dictionary), we feed the demand on the result into -- the indicated dictionary component. dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd | (cd',defer_use) <- peelCallDmd cd , Just jds <- splitProdDmd_maybe dict_dmd = postProcessUnsat defer_use $ DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topRes | otherwise = nopDmdType -- See Note [Demand transformer for a dictionary selector] where enhance cd old | isAbsDmd old = old | otherwise = mkOnceUsedDmd cd -- This is the one! dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args" {- Note [Demand transformer for a dictionary selector] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd' into the appropriate field of the dictionary. What *is* the appropriate field? We just look at the strictness signature of the class op, which will be something like: U(AAASAAAAA). Then replace the 'S' by the demand 'd'. For single-method classes, which are represented by newtypes the signature of 'op' won't look like U(...), so the splitProdDmd_maybe will fail. That's fine: if we are doing strictness analysis we are also doing inlining, so we'll have inlined 'op' into a cast. So we can bale out in a conservative way, returning nopDmdType. It is (just.. #8329) possible to be running strictness analysis *without* having inlined class ops from single-method classes. Suppose you are using ghc --make; and the first module has a local -O0 flag. So you may load a class without interface pragmas, ie (currently) without an unfolding for the class ops. Now if a subsequent module in the --make sweep has a local -O flag you might do strictness analysis, but there is no inlining for the class op. This is weird, so I'm not worried about whether this optimises brilliantly; but it should not fall over. -} argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] -- See Note [Computing one-shot info] argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args | unsaturated_call = [] | otherwise = go arg_ds where unsaturated_call = arg_ds `lengthExceeds` n_val_args go [] = [] go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds -- Avoid list tail like [ [], [], [] ] cons [] [] = [] cons a as = a:as -- saturatedByOneShots n C1(C1(...)) = True, -- <=> -- there are at least n nested C1(..) calls -- See Note [Demand on the worker] in WorkWrap saturatedByOneShots :: Int -> Demand -> Bool saturatedByOneShots n (JD { ud = usg }) = case usg of Use _ arg_usg -> go n arg_usg _ -> False where go 0 _ = True go n (UCall One u) = go (n-1) u go _ _ = False argOneShots :: Demand -- depending on saturation -> [OneShotInfo] argOneShots (JD { ud = usg }) = case usg of Use _ arg_usg -> go arg_usg _ -> [] where go (UCall One u) = OneShotLam : go u go (UCall Many u) = NoOneShotInfo : go u go _ = [] {- Note [Computing one-shot info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a call f (\pqr. e1) (\xyz. e2) e3 where f has usage signature C1(C(C1(U))) C1(U) U Then argsOneShots returns a [[OneShotInfo]] of [[OneShot,NoOneShotInfo,OneShot], [OneShot]] The occurrence analyser propagates this one-shot infor to the binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal. -} -- | Returns true if an application to n args -- would diverge or throw an exception -- See Note [Unsaturated applications] appIsBottom :: StrictSig -> Int -> Bool appIsBottom (StrictSig (DmdType _ ds res)) n | isBotRes res = not $ lengthExceeds ds n appIsBottom _ _ = False {- Note [Unsaturated applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If a function having bottom as its demand result is applied to a less number of arguments than its syntactic arity, we cannot say for sure that it is going to diverge. This is the reason why we use the function appIsBottom, which, given a strictness signature and a number of arguments, says conservatively if the function is going to diverge or not. Zap absence or one-shot information, under control of flags Note [Killing usage information] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The flags -fkill-one-shot and -fkill-absence let you switch off the generation of absence or one-shot information altogether. This is only used for performance tests, to see how important they are. -} zapUsageEnvSig :: StrictSig -> StrictSig -- Remove the usage environment from the demand zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r zapUsageDemand :: Demand -> Demand -- Remove the usage info, but not the strictness info, from the demand zapUsageDemand = kill_usage $ KillFlags { kf_abs = True , kf_used_once = True , kf_called_once = True } -- | Remove all 1* information (but not C1 information) from the demand zapUsedOnceDemand :: Demand -> Demand zapUsedOnceDemand = kill_usage $ KillFlags { kf_abs = False , kf_used_once = True , kf_called_once = False } -- | Remove all 1* information (but not C1 information) from the strictness -- signature zapUsedOnceSig :: StrictSig -> StrictSig zapUsedOnceSig (StrictSig (DmdType env ds r)) = StrictSig (DmdType env (map zapUsedOnceDemand ds) r) killUsageDemand :: DynFlags -> Demand -> Demand -- See Note [Killing usage information] killUsageDemand dflags dmd | Just kfs <- killFlags dflags = kill_usage kfs dmd | otherwise = dmd killUsageSig :: DynFlags -> StrictSig -> StrictSig -- See Note [Killing usage information] killUsageSig dflags sig@(StrictSig (DmdType env ds r)) | Just kfs <- killFlags dflags = StrictSig (DmdType env (map (kill_usage kfs) ds) r) | otherwise = sig data KillFlags = KillFlags { kf_abs :: Bool , kf_used_once :: Bool , kf_called_once :: Bool } killFlags :: DynFlags -> Maybe KillFlags -- See Note [Killing usage information] killFlags dflags | not kf_abs && not kf_used_once = Nothing | otherwise = Just (KillFlags {..}) where kf_abs = gopt Opt_KillAbsence dflags kf_used_once = gopt Opt_KillOneShot dflags kf_called_once = kf_used_once kill_usage :: KillFlags -> Demand -> Demand kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u} zap_musg :: KillFlags -> ArgUse -> ArgUse zap_musg kfs Abs | kf_abs kfs = useTop | otherwise = Abs zap_musg kfs (Use c u) | kf_used_once kfs = Use Many (zap_usg kfs u) | otherwise = Use c (zap_usg kfs u) zap_usg :: KillFlags -> UseDmd -> UseDmd zap_usg kfs (UCall c u) | kf_called_once kfs = UCall Many (zap_usg kfs u) | otherwise = UCall c (zap_usg kfs u) zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us) zap_usg _ u = u -- If the argument is a used non-newtype dictionary, give it strict -- demand. Also split the product type & demand and recur in order to -- similarly strictify the argument's contained used non-newtype -- superclass dictionaries. We use the demand as our recursive measure -- to guarantee termination. strictifyDictDmd :: Type -> Demand -> Demand strictifyDictDmd ty dmd = case getUseDmd dmd of Use n _ | Just (tycon, _arg_tys, _data_con, inst_con_arg_tys) <- splitDataProductType_maybe ty, not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary -> seqDmd `bothDmd` -- main idea: ensure it's strict case splitProdDmd_maybe dmd of -- superclass cycles should not be a problem, since the demand we are -- consuming would also have to be infinite in order for us to diverge Nothing -> dmd -- no components have interesting demand, so stop -- looking for superclass dicts Just dmds | all (not . isAbsDmd) dmds -> evalDmd -- abstract to strict w/ arbitrary component use, since this -- smells like reboxing; results in CBV boxed -- -- TODO revisit this if we ever do boxity analysis | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of JD {sd = s,ud = a} -> JD (Str s) (Use n a) -- TODO could optimize with an aborting variant of zipWith since -- the superclass dicts are always a prefix _ -> dmd -- unused or not a dictionary strictifyDmd :: Demand -> Demand strictifyDmd dmd@(JD { sd = str }) = dmd { sd = str `bothArgStr` Str HeadStr } {- Note [HyperStr and Use demands] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The information "HyperStr" needs to be in the strictness signature, and not in the demand signature, because we still want to know about the demand on things. Consider f (x,y) True = error (show x) f (x,y) False = x+1 The signature of f should be m. If we were not distinguishing the uses on x and y in the True case, we could either not figure out how deeply we can unpack x, or that we do not have to pass y. ************************************************************************ * * Serialisation * * ************************************************************************ -} instance Binary StrDmd where put_ bh HyperStr = do putByte bh 0 put_ bh HeadStr = do putByte bh 1 put_ bh (SCall s) = do putByte bh 2 put_ bh s put_ bh (SProd sx) = do putByte bh 3 put_ bh sx get bh = do h <- getByte bh case h of 0 -> do return HyperStr 1 -> do return HeadStr 2 -> do s <- get bh return (SCall s) _ -> do sx <- get bh return (SProd sx) instance Binary ArgStr where put_ bh Lazy = do putByte bh 0 put_ bh (Str s) = do putByte bh 1 put_ bh s get bh = do h <- getByte bh case h of 0 -> return Lazy _ -> do s <- get bh return $ Str s instance Binary Count where put_ bh One = do putByte bh 0 put_ bh Many = do putByte bh 1 get bh = do h <- getByte bh case h of 0 -> return One _ -> return Many instance Binary ArgUse where put_ bh Abs = do putByte bh 0 put_ bh (Use c u) = do putByte bh 1 put_ bh c put_ bh u get bh = do h <- getByte bh case h of 0 -> return Abs _ -> do c <- get bh u <- get bh return $ Use c u instance Binary UseDmd where put_ bh Used = do putByte bh 0 put_ bh UHead = do putByte bh 1 put_ bh (UCall c u) = do putByte bh 2 put_ bh c put_ bh u put_ bh (UProd ux) = do putByte bh 3 put_ bh ux get bh = do h <- getByte bh case h of 0 -> return $ Used 1 -> return $ UHead 2 -> do c <- get bh u <- get bh return (UCall c u) _ -> do ux <- get bh return (UProd ux) instance (Binary s, Binary u) => Binary (JointDmd s u) where put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y get bh = do x <- get bh y <- get bh return $ JD { sd = x, ud = y } instance Binary StrictSig where put_ bh (StrictSig aa) = do put_ bh aa get bh = do aa <- get bh return (StrictSig aa) instance Binary DmdType where -- Ignore DmdEnv when spitting out the DmdType put_ bh (DmdType _ ds dr) = do put_ bh ds put_ bh dr get bh = do ds <- get bh dr <- get bh return (DmdType emptyDmdEnv ds dr) instance Binary DmdResult where put_ bh (Dunno c) = do { putByte bh 0; put_ bh c } put_ bh Diverges = putByte bh 1 get bh = do { h <- getByte bh ; case h of 0 -> do { c <- get bh; return (Dunno c) } _ -> return Diverges } instance Binary CPRResult where put_ bh (RetSum n) = do { putByte bh 0; put_ bh n } put_ bh RetProd = putByte bh 1 put_ bh NoCPR = putByte bh 2 get bh = do h <- getByte bh case h of 0 -> do { n <- get bh; return (RetSum n) } 1 -> return RetProd _ -> return NoCPR ghc-lib-parser-8.10.2.20200808/compiler/utils/Digraph.hs0000644000000000000000000004703613713635745020405 0ustar0000000000000000-- (c) The University of Glasgow 2006 {-# LANGUAGE CPP, ScopedTypeVariables, ViewPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Digraph( Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq, SCC(..), Node(..), flattenSCC, flattenSCCs, stronglyConnCompG, topologicalSortG, verticesG, edgesG, hasVertexG, reachableG, reachablesG, transposeG, emptyG, findCycle, -- For backwards compatibility with the simpler version of Digraph stronglyConnCompFromEdgedVerticesOrd, stronglyConnCompFromEdgedVerticesOrdR, stronglyConnCompFromEdgedVerticesUniq, stronglyConnCompFromEdgedVerticesUniqR, -- Simple way to classify edges EdgeType(..), classifyEdges ) where #include "GhclibHsVersions.h" ------------------------------------------------------------------------------ -- A version of the graph algorithms described in: -- -- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell'' -- by David King and John Launchbury -- -- Also included is some additional code for printing tree structures ... -- -- If you ever find yourself in need of algorithms for classifying edges, -- or finding connected/biconnected components, consult the history; Sigbjorn -- Finne contributed some implementations in 1997, although we've since -- removed them since they were not used anywhere in GHC. ------------------------------------------------------------------------------ import GhcPrelude import Util ( minWith, count ) import Outputable import Maybes ( expectJust ) -- std interfaces import Data.Maybe import Data.Array import Data.List hiding (transpose) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Graph as G import Data.Graph hiding (Graph, Edge, transposeG, reachable) import Data.Tree import Unique import UniqFM {- ************************************************************************ * * * Graphs and Graph Construction * * ************************************************************************ Note [Nodes, keys, vertices] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * A 'node' is a big blob of client-stuff * Each 'node' has a unique (client) 'key', but the latter is in Ord and has fast comparison * Digraph then maps each 'key' to a Vertex (Int) which is arranged densely in 0.n -} data Graph node = Graph { gr_int_graph :: IntGraph, gr_vertex_to_node :: Vertex -> node, gr_node_to_vertex :: node -> Maybe Vertex } data Edge node = Edge node node {-| Representation for nodes of the Graph. * The @payload@ is user data, just carried around in this module * The @key@ is the node identifier. Key has an Ord instance for performance reasons. * The @[key]@ are the dependencies of the node; it's ok to have extra keys in the dependencies that are not the key of any Node in the graph -} data Node key payload = DigraphNode { node_payload :: payload, -- ^ User data node_key :: key, -- ^ User defined node id node_dependencies :: [key] -- ^ Dependencies/successors of the node } instance (Outputable a, Outputable b) => Outputable (Node a b) where ppr (DigraphNode a b c) = ppr (a, b, c) emptyGraph :: Graph a emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) -- See Note [Deterministic SCC] graphFromEdgedVertices :: ReduceFn key payload -> [Node key payload] -- The graph; its ok for the -- out-list to contain keys which aren't -- a vertex key, they are ignored -> Graph (Node key payload) graphFromEdgedVertices _reduceFn [] = emptyGraph graphFromEdgedVertices reduceFn edged_vertices = Graph graph vertex_fn (key_vertex . key_extractor) where key_extractor = node_key (bounds, vertex_fn, key_vertex, numbered_nodes) = reduceFn edged_vertices key_extractor graph = array bounds [ (v, sort $ mapMaybe key_vertex ks) | (v, (node_dependencies -> ks)) <- numbered_nodes] -- We normalize outgoing edges by sorting on node order, so -- that the result doesn't depend on the order of the edges -- See Note [Deterministic SCC] -- See Note [reduceNodesIntoVertices implementations] graphFromEdgedVerticesOrd :: Ord key => [Node key payload] -- The graph; its ok for the -- out-list to contain keys which aren't -- a vertex key, they are ignored -> Graph (Node key payload) graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd -- See Note [Deterministic SCC] -- See Note [reduceNodesIntoVertices implementations] graphFromEdgedVerticesUniq :: Uniquable key => [Node key payload] -- The graph; its ok for the -- out-list to contain keys which aren't -- a vertex key, they are ignored -> Graph (Node key payload) graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq type ReduceFn key payload = [Node key payload] -> (Node key payload -> key) -> (Bounds, Vertex -> Node key payload , key -> Maybe Vertex, [(Vertex, Node key payload)]) {- Note [reduceNodesIntoVertices implementations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ reduceNodesIntoVertices is parameterized by the container type. This is to accomodate key types that don't have an Ord instance and hence preclude the use of Data.Map. An example of such type would be Unique, there's no way to implement Ord Unique deterministically. For such types, there's a version with a Uniquable constraint. This leaves us with two versions of every function that depends on reduceNodesIntoVertices, one with Ord constraint and the other with Uniquable constraint. For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq. The Uniq version should be a tiny bit more efficient since it uses Data.IntMap internally. -} reduceNodesIntoVertices :: ([(key, Vertex)] -> m) -> (key -> m -> Maybe Vertex) -> ReduceFn key payload reduceNodesIntoVertices fromList lookup nodes key_extractor = (bounds, (!) vertex_map, key_vertex, numbered_nodes) where max_v = length nodes - 1 bounds = (0, max_v) :: (Vertex, Vertex) -- Keep the order intact to make the result depend on input order -- instead of key order numbered_nodes = zip [0..] nodes vertex_map = array bounds numbered_nodes key_map = fromList [ (key_extractor node, v) | (v, node) <- numbered_nodes ] key_vertex k = lookup k key_map -- See Note [reduceNodesIntoVertices implementations] reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup -- See Note [reduceNodesIntoVertices implementations] reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM) {- ************************************************************************ * * * SCC * * ************************************************************************ -} type WorkItem key payload = (Node key payload, -- Tip of the path [payload]) -- Rest of the path; -- [a,b,c] means c depends on b, b depends on a -- | Find a reasonably short cycle a->b->c->a, in a strongly -- connected component. The input nodes are presumed to be -- a SCC, so you can start anywhere. findCycle :: forall payload key. Ord key => [Node key payload] -- The nodes. The dependencies can -- contain extra keys, which are ignored -> Maybe [payload] -- A cycle, starting with node -- so each depends on the next findCycle graph = go Set.empty (new_work root_deps []) [] where env :: Map.Map key (Node key payload) env = Map.fromList [ (node_key node, node) | node <- graph ] -- Find the node with fewest dependencies among the SCC modules -- This is just a heuristic to find some plausible root module root :: Node key payload root = fst (minWith snd [ (node, count (`Map.member` env) (node_dependencies node)) | node <- graph ]) DigraphNode root_payload root_key root_deps = root -- 'go' implements Dijkstra's algorithm, more or less go :: Set.Set key -- Visited -> [WorkItem key payload] -- Work list, items length n -> [WorkItem key payload] -- Work list, items length n+1 -> Maybe [payload] -- Returned cycle -- Invariant: in a call (go visited ps qs), -- visited = union (map tail (ps ++ qs)) go _ [] [] = Nothing -- No cycles go visited [] qs = go visited qs [] go visited (((DigraphNode payload key deps), path) : ps) qs | key == root_key = Just (root_payload : reverse path) | key `Set.member` visited = go visited ps qs | key `Map.notMember` env = go visited ps qs | otherwise = go (Set.insert key visited) ps (new_qs ++ qs) where new_qs = new_work deps (payload : path) new_work :: [key] -> [payload] -> [WorkItem key payload] new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] {- ************************************************************************ * * * Strongly Connected Component wrappers for Graph * * ************************************************************************ Note: the components are returned topologically sorted: later components depend on earlier ones, but not vice versa i.e. later components only have edges going from them to earlier ones. -} {- Note [Deterministic SCC] ~~~~~~~~~~~~~~~~~~~~~~~~ stronglyConnCompFromEdgedVerticesUniq, stronglyConnCompFromEdgedVerticesUniqR, stronglyConnCompFromEdgedVerticesOrd and stronglyConnCompFromEdgedVerticesOrdR provide a following guarantee: Given a deterministically ordered list of nodes it returns a deterministically ordered list of strongly connected components, where the list of vertices in an SCC is also deterministically ordered. Note that the order of edges doesn't need to be deterministic for this to work. We use the order of nodes to normalize the order of edges. -} stronglyConnCompG :: Graph node -> [SCC node] stronglyConnCompG graph = decodeSccs graph forest where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph) decodeSccs :: Graph node -> Forest Vertex -> [SCC node] decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest = map decode forest where decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] | otherwise = AcyclicSCC (vertex_fn v) decode other = CyclicSCC (dec other []) where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts mentions_itself v = v `elem` (graph ! v) -- The following two versions are provided for backwards compatibility: -- See Note [Deterministic SCC] -- See Note [reduceNodesIntoVertices implementations] stronglyConnCompFromEdgedVerticesOrd :: Ord key => [Node key payload] -> [SCC payload] stronglyConnCompFromEdgedVerticesOrd = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesOrdR -- The following two versions are provided for backwards compatibility: -- See Note [Deterministic SCC] -- See Note [reduceNodesIntoVertices implementations] stronglyConnCompFromEdgedVerticesUniq :: Uniquable key => [Node key payload] -> [SCC payload] stronglyConnCompFromEdgedVerticesUniq = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR -- The "R" interface is used when you expect to apply SCC to -- (some of) the result of SCC, so you don't want to lose the dependency info -- See Note [Deterministic SCC] -- See Note [reduceNodesIntoVertices implementations] stronglyConnCompFromEdgedVerticesOrdR :: Ord key => [Node key payload] -> [SCC (Node key payload)] stronglyConnCompFromEdgedVerticesOrdR = stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd -- The "R" interface is used when you expect to apply SCC to -- (some of) the result of SCC, so you don't want to lose the dependency info -- See Note [Deterministic SCC] -- See Note [reduceNodesIntoVertices implementations] stronglyConnCompFromEdgedVerticesUniqR :: Uniquable key => [Node key payload] -> [SCC (Node key payload)] stronglyConnCompFromEdgedVerticesUniqR = stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq {- ************************************************************************ * * * Misc wrappers for Graph * * ************************************************************************ -} topologicalSortG :: Graph node -> [node] topologicalSortG graph = map (gr_vertex_to_node graph) result where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph) reachableG :: Graph node -> node -> [node] reachableG graph from = map (gr_vertex_to_node graph) result where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from) result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex] -- | Given a list of roots return all reachable nodes. reachablesG :: Graph node -> [node] -> [node] reachablesG graph froms = map (gr_vertex_to_node graph) result where result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) vs vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] hasVertexG :: Graph node -> node -> Bool hasVertexG graph node = isJust $ gr_node_to_vertex graph node verticesG :: Graph node -> [node] verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph) edgesG :: Graph node -> [Edge node] edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph) where v2n = gr_vertex_to_node graph transposeG :: Graph node -> Graph node transposeG graph = Graph (G.transposeG (gr_int_graph graph)) (gr_vertex_to_node graph) (gr_node_to_vertex graph) emptyG :: Graph node -> Bool emptyG g = graphEmpty (gr_int_graph g) {- ************************************************************************ * * * Showing Graphs * * ************************************************************************ -} instance Outputable node => Outputable (Graph node) where ppr graph = vcat [ hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)), hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph)) ] instance Outputable node => Outputable (Edge node) where ppr (Edge from to) = ppr from <+> text "->" <+> ppr to graphEmpty :: G.Graph -> Bool graphEmpty g = lo > hi where (lo, hi) = bounds g {- ************************************************************************ * * * IntGraphs * * ************************************************************************ -} type IntGraph = G.Graph {- ------------------------------------------------------------ -- Depth first search numbering ------------------------------------------------------------ -} -- Data.Tree has flatten for Tree, but nothing for Forest preorderF :: Forest a -> [a] preorderF ts = concat (map flatten ts) {- ------------------------------------------------------------ -- Finding reachable vertices ------------------------------------------------------------ -} -- This generalizes reachable which was found in Data.Graph reachable :: IntGraph -> [Vertex] -> [Vertex] reachable g vs = preorderF (dfs g vs) {- ************************************************************************ * * * Classify Edge Types * * ************************************************************************ -} -- Remark: While we could generalize this algorithm this comes at a runtime -- cost and with no advantages. If you find yourself using this with graphs -- not easily represented using Int nodes please consider rewriting this -- using the more general Graph type. -- | Edge direction based on DFS Classification data EdgeType = Forward | Cross | Backward -- ^ Loop back towards the root node. -- Eg backjumps in loops | SelfLoop -- ^ v -> v deriving (Eq,Ord) instance Outputable EdgeType where ppr Forward = text "Forward" ppr Cross = text "Cross" ppr Backward = text "Backward" ppr SelfLoop = text "SelfLoop" newtype Time = Time Int deriving (Eq,Ord,Num,Outputable) --Allow for specialzation {-# INLINEABLE classifyEdges #-} -- | Given a start vertex, a way to get successors from a node -- and a list of (directed) edges classify the types of edges. classifyEdges :: forall key. Uniquable key => key -> (key -> [key]) -> [(key,key)] -> [((key, key), EdgeType)] classifyEdges root getSucc edges = --let uqe (from,to) = (getUnique from, getUnique to) --in pprTrace "Edges:" (ppr $ map uqe edges) $ zip edges $ map classify edges where (_time, starts, ends) = addTimes (0,emptyUFM,emptyUFM) root classify :: (key,key) -> EdgeType classify (from,to) | startFrom < startTo , endFrom > endTo = Forward | startFrom > startTo , endFrom < endTo = Backward | startFrom > startTo , endFrom > endTo = Cross | getUnique from == getUnique to = SelfLoop | otherwise = pprPanic "Failed to classify edge of Graph" (ppr (getUnique from, getUnique to)) where getTime event node | Just time <- lookupUFM event node = time | otherwise = pprPanic "Failed to classify edge of CFG - not not timed" (text "edges" <> ppr (getUnique from, getUnique to) <+> ppr starts <+> ppr ends ) startFrom = getTime starts from startTo = getTime starts to endFrom = getTime ends from endTo = getTime ends to addTimes :: (Time, UniqFM Time, UniqFM Time) -> key -> (Time, UniqFM Time, UniqFM Time) addTimes (time,starts,ends) n --Dont reenter nodes | elemUFM n starts = (time,starts,ends) | otherwise = let starts' = addToUFM starts n time time' = time + 1 succs = getSucc n :: [key] (time'',starts'',ends') = foldl' addTimes (time',starts',ends) succs ends'' = addToUFM ends' n time'' in (time'' + 1, starts'', ends'') ghc-lib-parser-8.10.2.20200808/compiler/main/DriverPhases.hs0000644000000000000000000003353613713635745021212 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- $Id: DriverPhases.hs,v 1.38 2005/05/17 11:01:59 simonmar Exp $ -- -- GHC Driver -- -- (c) The University of Glasgow 2002 -- ----------------------------------------------------------------------------- module DriverPhases ( HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString, Phase(..), happensBefore, eqPhase, anyHsc, isStopLn, startPhase, phaseInputExt, isHaskellishSuffix, isHaskellSrcSuffix, isBackpackishSuffix, isObjectSuffix, isCishSuffix, isDynLibSuffix, isHaskellUserSrcSuffix, isHaskellSigSuffix, isSourceSuffix, isHaskellishTarget, isHaskellishFilename, isHaskellSrcFilename, isHaskellSigFilename, isObjectFilename, isCishFilename, isDynLibFilename, isHaskellUserSrcFilename, isSourceFilename ) where #include "GhclibHsVersions.h" import GhcPrelude import {-# SOURCE #-} DynFlags import Outputable import GHC.Platform import System.FilePath import Binary import Util ----------------------------------------------------------------------------- -- Phases {- Phase of the | Suffix saying | Flag saying | (suffix of) compilation system | ``start here''| ``stop after''| output file literate pre-processor | .lhs | - | - C pre-processor (opt.) | - | -E | - Haskell compiler | .hs | -C, -S | .hc, .s C compiler (opt.) | .hc or .c | -S | .s assembler | .s or .S | -c | .o linker | other | - | a.out -} -- Note [HscSource types] -- ~~~~~~~~~~~~~~~~~~~~~~ -- There are three types of source file for Haskell code: -- -- * HsSrcFile is an ordinary hs file which contains code, -- -- * HsBootFile is an hs-boot file, which is used to break -- recursive module imports (there will always be an -- HsSrcFile associated with it), and -- -- * HsigFile is an hsig file, which contains only type -- signatures and is used to specify signatures for -- modules. -- -- Syntactically, hs-boot files and hsig files are quite similar: they -- only include type signatures and must be associated with an -- actual HsSrcFile. isHsBootOrSig allows us to abstract over code -- which is indifferent to which. However, there are some important -- differences, mostly owing to the fact that hsigs are proper -- modules (you `import Sig` directly) whereas HsBootFiles are -- temporary placeholders (you `import {-# SOURCE #-} Mod). -- When we finish compiling the true implementation of an hs-boot, -- we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the -- other hand, is never replaced (in particular, we *cannot* use the -- HomeModInfo of the original HsSrcFile backing the signature, since it -- will export too many symbols.) -- -- Additionally, while HsSrcFile is the only Haskell file -- which has *code*, we do generate .o files for HsigFile, because -- this is how the recompilation checker figures out if a file -- needs to be recompiled. These are fake object files which -- should NOT be linked against. data HscSource = HsSrcFile | HsBootFile | HsigFile deriving( Eq, Ord, Show ) -- Ord needed for the finite maps we build in CompManager instance Binary HscSource where put_ bh HsSrcFile = putByte bh 0 put_ bh HsBootFile = putByte bh 1 put_ bh HsigFile = putByte bh 2 get bh = do h <- getByte bh case h of 0 -> return HsSrcFile 1 -> return HsBootFile _ -> return HsigFile hscSourceString :: HscSource -> String hscSourceString HsSrcFile = "" hscSourceString HsBootFile = "[boot]" hscSourceString HsigFile = "[sig]" -- See Note [isHsBootOrSig] isHsBootOrSig :: HscSource -> Bool isHsBootOrSig HsBootFile = True isHsBootOrSig HsigFile = True isHsBootOrSig _ = False isHsigFile :: HscSource -> Bool isHsigFile HsigFile = True isHsigFile _ = False data Phase = Unlit HscSource | Cpp HscSource | HsPp HscSource | Hsc HscSource | Ccxx -- Compile C++ | Cc -- Compile C | Cobjc -- Compile Objective-C | Cobjcxx -- Compile Objective-C++ | HCc -- Haskellised C (as opposed to vanilla C) compilation | As Bool -- Assembler for regular assembly files (Bool: with-cpp) | LlvmOpt -- Run LLVM opt tool over llvm assembly | LlvmLlc -- LLVM bitcode to native assembly | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM | CmmCpp -- pre-process Cmm source | Cmm -- parse & compile Cmm code | MergeForeign -- merge in the foreign object files -- The final phase is a pseudo-phase that tells the pipeline to stop. -- There is no runPhase case for it. | StopLn -- Stop, but linking will follow, so generate .o file deriving (Eq, Show) instance Outputable Phase where ppr p = text (show p) anyHsc :: Phase anyHsc = Hsc (panic "anyHsc") isStopLn :: Phase -> Bool isStopLn StopLn = True isStopLn _ = False eqPhase :: Phase -> Phase -> Bool -- Equality of constructors, ignoring the HscSource field -- NB: the HscSource field can be 'bot'; see anyHsc above eqPhase (Unlit _) (Unlit _) = True eqPhase (Cpp _) (Cpp _) = True eqPhase (HsPp _) (HsPp _) = True eqPhase (Hsc _) (Hsc _) = True eqPhase Cc Cc = True eqPhase Cobjc Cobjc = True eqPhase HCc HCc = True eqPhase (As x) (As y) = x == y eqPhase LlvmOpt LlvmOpt = True eqPhase LlvmLlc LlvmLlc = True eqPhase LlvmMangle LlvmMangle = True eqPhase CmmCpp CmmCpp = True eqPhase Cmm Cmm = True eqPhase MergeForeign MergeForeign = True eqPhase StopLn StopLn = True eqPhase Ccxx Ccxx = True eqPhase Cobjcxx Cobjcxx = True eqPhase _ _ = False {- Note [Partial ordering on phases] We want to know which phases will occur before which others. This is used for sanity checking, to ensure that the pipeline will stop at some point (see DriverPipeline.runPipeline). A < B iff A occurs before B in a normal compilation pipeline. There is explicitly not a total ordering on phases, because in registerised builds, the phase `HsC` doesn't happen before nor after any other phase. Although we check that a normal user doesn't set the stop_phase to HsC through use of -C with registerised builds (in Main.checkOptions), it is still possible for a ghc-api user to do so. So be careful when using the function happensBefore, and don't think that `not (a <= b)` implies `b < a`. -} happensBefore :: DynFlags -> Phase -> Phase -> Bool happensBefore dflags p1 p2 = p1 `happensBefore'` p2 where StopLn `happensBefore'` _ = False x `happensBefore'` y = after_x `eqPhase` y || after_x `happensBefore'` y where after_x = nextPhase dflags x nextPhase :: DynFlags -> Phase -> Phase nextPhase dflags p -- A conservative approximation to the next phase, used in happensBefore = case p of Unlit sf -> Cpp sf Cpp sf -> HsPp sf HsPp sf -> Hsc sf Hsc _ -> maybeHCc LlvmOpt -> LlvmLlc LlvmLlc -> LlvmMangle LlvmMangle -> As False As _ -> MergeForeign Ccxx -> As False Cc -> As False Cobjc -> As False Cobjcxx -> As False CmmCpp -> Cmm Cmm -> maybeHCc HCc -> As False MergeForeign -> StopLn StopLn -> panic "nextPhase: nothing after StopLn" where maybeHCc = if platformUnregisterised (targetPlatform dflags) then HCc else As False -- the first compilation phase for a given file is determined -- by its suffix. startPhase :: String -> Phase startPhase "lhs" = Unlit HsSrcFile startPhase "lhs-boot" = Unlit HsBootFile startPhase "lhsig" = Unlit HsigFile startPhase "hs" = Cpp HsSrcFile startPhase "hs-boot" = Cpp HsBootFile startPhase "hsig" = Cpp HsigFile startPhase "hscpp" = HsPp HsSrcFile startPhase "hspp" = Hsc HsSrcFile startPhase "hc" = HCc startPhase "c" = Cc startPhase "cpp" = Ccxx startPhase "C" = Cc startPhase "m" = Cobjc startPhase "M" = Cobjcxx startPhase "mm" = Cobjcxx startPhase "cc" = Ccxx startPhase "cxx" = Ccxx startPhase "s" = As False startPhase "S" = As True startPhase "ll" = LlvmOpt startPhase "bc" = LlvmLlc startPhase "lm_s" = LlvmMangle startPhase "o" = StopLn startPhase "cmm" = CmmCpp startPhase "cmmcpp" = Cmm startPhase _ = StopLn -- all unknown file types -- This is used to determine the extension for the output from the -- current phase (if it generates a new file). The extension depends -- on the next phase in the pipeline. phaseInputExt :: Phase -> String phaseInputExt (Unlit HsSrcFile) = "lhs" phaseInputExt (Unlit HsBootFile) = "lhs-boot" phaseInputExt (Unlit HsigFile) = "lhsig" phaseInputExt (Cpp _) = "lpp" -- intermediate only phaseInputExt (HsPp _) = "hscpp" -- intermediate only phaseInputExt (Hsc _) = "hspp" -- intermediate only -- NB: as things stand, phaseInputExt (Hsc x) must not evaluate x -- because runPipeline uses the StopBefore phase to pick the -- output filename. That could be fixed, but watch out. phaseInputExt HCc = "hc" phaseInputExt Ccxx = "cpp" phaseInputExt Cobjc = "m" phaseInputExt Cobjcxx = "mm" phaseInputExt Cc = "c" phaseInputExt (As True) = "S" phaseInputExt (As False) = "s" phaseInputExt LlvmOpt = "ll" phaseInputExt LlvmLlc = "bc" phaseInputExt LlvmMangle = "lm_s" phaseInputExt CmmCpp = "cmmcpp" phaseInputExt Cmm = "cmm" phaseInputExt MergeForeign = "o" phaseInputExt StopLn = "o" haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes :: [String] -- When a file with an extension in the haskellish_src_suffixes group is -- loaded in --make mode, its imports will be loaded too. haskellish_src_suffixes = haskellish_user_src_suffixes ++ [ "hspp", "hscpp" ] haskellish_suffixes = haskellish_src_suffixes ++ [ "hc", "cmm", "cmmcpp" ] cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] -- Will not be deleted as temp files: haskellish_user_src_suffixes = haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ] haskellish_sig_suffixes = [ "hsig", "lhsig" ] backpackish_suffixes = [ "bkp" ] objish_suffixes :: Platform -> [String] -- Use the appropriate suffix for the system on which -- the GHC-compiled code will run objish_suffixes platform = case platformOS platform of OSMinGW32 -> [ "o", "O", "obj", "OBJ" ] _ -> [ "o" ] dynlib_suffixes :: Platform -> [String] dynlib_suffixes platform = case platformOS platform of OSMinGW32 -> ["dll", "DLL"] OSDarwin -> ["dylib", "so"] _ -> ["so"] isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix, isHaskellUserSrcSuffix, isHaskellSigSuffix :: String -> Bool isHaskellishSuffix s = s `elem` haskellish_suffixes isBackpackishSuffix s = s `elem` backpackish_suffixes isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes isCishSuffix s = s `elem` cish_suffixes isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool isObjectSuffix platform s = s `elem` objish_suffixes platform isDynLibSuffix platform s = s `elem` dynlib_suffixes platform isSourceSuffix :: String -> Bool isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff || isBackpackishSuffix suff -- | When we are given files (modified by -x arguments) we need -- to determine if they are Haskellish or not to figure out -- how we should try to compile it. The rules are: -- -- 1. If no -x flag was specified, we check to see if -- the file looks like a module name, has no extension, -- or has a Haskell source extension. -- -- 2. If an -x flag was specified, we just make sure the -- specified suffix is a Haskell one. isHaskellishTarget :: (String, Maybe Phase) -> Bool isHaskellishTarget (f,Nothing) = looksLikeModuleName f || isHaskellSrcFilename f || not (hasExtension f) isHaskellishTarget (_,Just phase) = phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm , StopLn] isHaskellishFilename, isHaskellSrcFilename, isCishFilename, isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename :: FilePath -> Bool -- takeExtension return .foo, so we drop 1 to get rid of the . isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f) isCishFilename f = isCishSuffix (drop 1 $ takeExtension f) isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f) isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f) isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f) ghc-lib-parser-8.10.2.20200808/compiler/main/DynFlags.hs0000644000000000000000000075075713713636246020332 0ustar0000000000000000{-# OPTIONS_GHC -O0 #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} ------------------------------------------------------------------------------- -- -- | Dynamic flags -- -- Most flags are dynamic flags, which means they can change from compilation -- to compilation using @OPTIONS_GHC@ pragmas, and in a multi-session GHC each -- session can be using different dynamic flags. Dynamic flags can also be set -- at the prompt in GHCi. -- -- (c) The University of Glasgow 2005 -- ------------------------------------------------------------------------------- {-# OPTIONS_GHC -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly module DynFlags ( -- * Dynamic flags and associated configuration types DumpFlag(..), GeneralFlag(..), WarningFlag(..), WarnReason(..), Language(..), PlatformConstants(..), FatalMessager, LogAction, FlushOut(..), FlushErr(..), ProfAuto(..), glasgowExtsFlags, warningGroups, warningHierarchies, hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion, dopt, dopt_set, dopt_unset, gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag', wopt, wopt_set, wopt_unset, wopt_fatal, wopt_set_fatal, wopt_unset_fatal, xopt, xopt_set, xopt_unset, xopt_set_unlessExplSpec, lang_set, useUnicodeSyntax, useStarIsType, whenGeneratingDynamicToo, ifGeneratingDynamicToo, whenCannotGenerateDynamicToo, dynamicTooMkDynamicDynFlags, dynamicOutputFile, DynFlags(..), FlagSpec(..), HasDynFlags(..), ContainsDynFlags(..), RtsOptsEnabled(..), HscTarget(..), isObjectTarget, defaultObjectTarget, targetRetainsAllBindings, GhcMode(..), isOneShot, GhcLink(..), isNoLink, PackageFlag(..), PackageArg(..), ModRenaming(..), packageFlagsChanged, IgnorePackageFlag(..), TrustFlag(..), PackageDBFlag(..), PkgConfRef(..), Option(..), showOpt, DynLibLoader(..), fFlags, fLangFlags, xFlags, wWarningFlags, dynFlagDependencies, makeDynFlagsConsistent, shouldUseColor, shouldUseHexWordLiterals, positionIndependent, optimisationFlags, setFlagsFromEnvFile, Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, wayGeneralFlags, wayUnsetGeneralFlags, thisPackage, thisComponentId, thisUnitIdInsts, -- ** Log output putLogMsg, -- ** Safe Haskell SafeHaskellMode(..), safeHaskellOn, safeHaskellModeEnabled, safeImportsOn, safeLanguageOn, safeInferOn, packageTrustOn, safeDirectImpsReq, safeImplicitImpsReq, unsafeFlags, unsafeFlagsForInfer, -- ** LLVM Targets LlvmTarget(..), LlvmConfig(..), -- ** System tool settings and locations Settings(..), sProgramName, sProjectVersion, sGhcUsagePath, sGhciUsagePath, sToolDir, sTopDir, sTmpDir, sSystemPackageConfig, sLdSupportsCompactUnwind, sLdSupportsBuildId, sLdSupportsFilelist, sLdIsGnuLd, sGccSupportsNoPie, sPgm_L, sPgm_P, sPgm_F, sPgm_c, sPgm_a, sPgm_l, sPgm_lm, sPgm_dll, sPgm_T, sPgm_windres, sPgm_libtool, sPgm_ar, sPgm_ranlib, sPgm_lo, sPgm_lc, sPgm_lcc, sPgm_i, sOpt_L, sOpt_P, sOpt_P_fingerprint, sOpt_F, sOpt_c, sOpt_cxx, sOpt_a, sOpt_l, sOpt_lm, sOpt_windres, sOpt_lo, sOpt_lc, sOpt_lcc, sOpt_i, sExtraGccViaCFlags, sTargetPlatformString, sIntegerLibrary, sIntegerLibraryType, sGhcWithInterpreter, sGhcWithNativeCodeGen, sGhcWithSMP, sGhcRTSWays, sTablesNextToCode, sLeadingUnderscore, sLibFFI, sGhcThreaded, sGhcDebugged, sGhcRtsWithLibdw, IntegerLibrary(..), GhcNameVersion(..), FileSettings(..), PlatformMisc(..), settings, programName, projectVersion, ghcUsagePath, ghciUsagePath, topDir, tmpDir, versionedAppDir, versionedFilePath, extraGccViaCFlags, systemPackageConfig, pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_lm, pgm_dll, pgm_T, pgm_windres, pgm_libtool, pgm_ar, pgm_ranlib, pgm_lo, pgm_lc, pgm_lcc, pgm_i, opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i, opt_P_signature, opt_windres, opt_lo, opt_lc, opt_lcc, tablesNextToCode, -- ** Manipulating DynFlags addPluginModuleName, defaultDynFlags, -- Settings -> DynFlags defaultWays, interpWays, interpreterProfiled, interpreterDynamic, initDynFlags, -- DynFlags -> IO DynFlags defaultFatalMessager, defaultLogAction, defaultLogActionHPrintDoc, defaultLogActionHPutStrDoc, defaultFlushOut, defaultFlushErr, getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] getVerbFlags, updOptLevel, setTmpDir, setUnitId, canonicalizeHomeModule, canonicalizeModuleIfHome, -- ** Parsing DynFlags parseDynamicFlagsCmdLine, parseDynamicFilePragma, parseDynamicFlagsFull, -- ** Available DynFlags allNonDeprecatedFlags, flagsAll, flagsDynamic, flagsPackage, flagsForCompletion, supportedLanguagesAndExtensions, languageExtensions, -- ** DynFlags C compiler options picCCOpts, picPOpts, -- * Compiler configuration suitable for display to the user compilerInfo, rtsIsProfiled, dynamicGhc, #include "GHCConstantsHaskellExports.hs" bLOCK_SIZE_W, wORD_SIZE_IN_BITS, wordAlignment, tAG_MASK, mAX_PTR_TAG, tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD, unsafeGlobalDynFlags, setUnsafeGlobalDynFlags, -- * SSE and AVX isSseEnabled, isSse2Enabled, isSse4_2Enabled, isBmiEnabled, isBmi2Enabled, isAvxEnabled, isAvx2Enabled, isAvx512cdEnabled, isAvx512erEnabled, isAvx512fEnabled, isAvx512pfEnabled, -- * Linker/compiler information LinkerInfo(..), CompilerInfo(..), -- * File cleanup FilesToClean(..), emptyFilesToClean, -- * Include specifications IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes, -- * Make use of the Cmm CFG CfgWeights(..), backendMaintainsCfg ) where #include "GhclibHsVersions.h" import GhcPrelude import GHC.Platform import GHC.UniqueSubdir (uniqueSubdir) import PlatformConstants import Module import PackageConfig import {-# SOURCE #-} Plugins import {-# SOURCE #-} Hooks import {-# SOURCE #-} PrelNames ( mAIN ) import {-# SOURCE #-} Packages (PackageState, emptyPackageState) import DriverPhases ( Phase(..), phaseInputExt ) import Config import CliOption import CmdLineParser hiding (WarnReason(..)) import qualified CmdLineParser as Cmd import Constants import GhcNameVersion import Panic import qualified PprColour as Col import Util import Maybes import MonadUtils import qualified Pretty import SrcLoc import BasicTypes ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) import FastString import Fingerprint import FileSettings import Outputable import Settings import ToolSettings import Foreign.C ( CInt(..) ) import System.IO.Unsafe ( unsafeDupablePerformIO ) import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn , getCaretDiagnostic ) import Json import SysTools.Terminal ( stderrSupportsAnsiColors ) import SysTools.BaseDir ( expandToolDir, expandTopDir ) import System.IO.Unsafe ( unsafePerformIO ) import Data.IORef import Control.Arrow ((&&&)) import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader import Control.Monad.Trans.Except import Data.Ord import Data.Bits import Data.Char import Data.Int import Data.List import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Data.Word import System.FilePath import System.Directory import System.Environment (lookupEnv) import System.IO import System.IO.Error import Text.ParserCombinators.ReadP hiding (char) import Text.ParserCombinators.ReadP as R import EnumSet (EnumSet) import qualified EnumSet import GHC.Foreign (withCString, peekCString) import qualified GHC.LanguageExtensions as LangExt #if GHC_STAGE >= 2 -- used by SHARED_GLOBAL_VAR import Foreign (Ptr) #endif -- Note [Updating flag description in the User's Guide] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- If you modify anything in this file please make sure that your changes are -- described in the User's Guide. Please update the flag description in the -- users guide (docs/users_guide) whenever you add or change a flag. -- Note [Supporting CLI completion] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- The command line interface completion (in for example bash) is an easy way -- for the developer to learn what flags are available from GHC. -- GHC helps by separating which flags are available when compiling with GHC, -- and which flags are available when using GHCi. -- A flag is assumed to either work in both these modes, or only in one of them. -- When adding or changing a flag, please consider for which mode the flag will -- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag, -- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec. -- Note [Adding a language extension] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- There are a few steps to adding (or removing) a language extension, -- -- * Adding the extension to GHC.LanguageExtensions -- -- The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs -- is the canonical list of language extensions known by GHC. -- -- * Adding a flag to DynFlags.xFlags -- -- This is fairly self-explanatory. The name should be concise, memorable, -- and consistent with any previous implementations of the similar idea in -- other Haskell compilers. -- -- * Adding the flag to the documentation -- -- This is the same as any other flag. See -- Note [Updating flag description in the User's Guide] -- -- * Adding the flag to Cabal -- -- The Cabal library has its own list of all language extensions supported -- by all major compilers. This is the list that user code being uploaded -- to Hackage is checked against to ensure language extension validity. -- Consequently, it is very important that this list remains up-to-date. -- -- To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs) -- whose job it is to ensure these GHC's extensions are consistent with -- Cabal. -- -- The recommended workflow is, -- -- 1. Temporarily add your new language extension to the -- expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't -- break while Cabal is updated. -- -- 2. After your GHC change is accepted, submit a Cabal pull request adding -- your new extension to Cabal's list (found in -- Cabal/Language/Haskell/Extension.hs). -- -- 3. After your Cabal change is accepted, let the GHC developers know so -- they can update the Cabal submodule and remove the extensions from -- expectedGhcOnlyExtensions. -- -- * Adding the flag to the GHC Wiki -- -- There is a change log tracking language extension additions and removals -- on the GHC wiki: https://gitlab.haskell.org/ghc/ghc/wikis/language-pragma-history -- -- See #4437 and #8176. -- ----------------------------------------------------------------------------- -- DynFlags data DumpFlag -- See Note [Updating flag description in the User's Guide] -- debugging flags = Opt_D_dump_cmm | Opt_D_dump_cmm_from_stg | Opt_D_dump_cmm_raw | Opt_D_dump_cmm_verbose_by_proc -- All of the cmm subflags (there are a lot!) automatically -- enabled if you run -ddump-cmm-verbose-by-proc -- Each flag corresponds to exact stage of Cmm pipeline. | Opt_D_dump_cmm_verbose -- same as -ddump-cmm-verbose-by-proc but writes each stage -- to a separate file (if used with -ddump-to-file) | Opt_D_dump_cmm_cfg | Opt_D_dump_cmm_cbe | Opt_D_dump_cmm_switch | Opt_D_dump_cmm_proc | Opt_D_dump_cmm_sp | Opt_D_dump_cmm_sink | Opt_D_dump_cmm_caf | Opt_D_dump_cmm_procmap | Opt_D_dump_cmm_split | Opt_D_dump_cmm_info | Opt_D_dump_cmm_cps -- end cmm subflags | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout. | Opt_D_dump_asm | Opt_D_dump_asm_native | Opt_D_dump_asm_liveness | Opt_D_dump_asm_regalloc | Opt_D_dump_asm_regalloc_stages | Opt_D_dump_asm_conflicts | Opt_D_dump_asm_stats | Opt_D_dump_asm_expanded | Opt_D_dump_llvm | Opt_D_dump_core_stats | Opt_D_dump_deriv | Opt_D_dump_ds | Opt_D_dump_ds_preopt | Opt_D_dump_foreign | Opt_D_dump_inlinings | Opt_D_dump_rule_firings | Opt_D_dump_rule_rewrites | Opt_D_dump_simpl_trace | Opt_D_dump_occur_anal | Opt_D_dump_parsed | Opt_D_dump_parsed_ast | Opt_D_dump_rn | Opt_D_dump_rn_ast | Opt_D_dump_simpl | Opt_D_dump_simpl_iterations | Opt_D_dump_spec | Opt_D_dump_prep | Opt_D_dump_stg -- CoreToStg output | Opt_D_dump_stg_unarised -- STG after unarise | Opt_D_dump_stg_final -- STG after stg2stg | Opt_D_dump_call_arity | Opt_D_dump_exitify | Opt_D_dump_stranal | Opt_D_dump_str_signatures | Opt_D_dump_tc | Opt_D_dump_tc_ast | Opt_D_dump_types | Opt_D_dump_rules | Opt_D_dump_cse | Opt_D_dump_worker_wrapper | Opt_D_dump_rn_trace | Opt_D_dump_rn_stats | Opt_D_dump_opt_cmm | Opt_D_dump_simpl_stats | Opt_D_dump_cs_trace -- Constraint solver in type checker | Opt_D_dump_tc_trace | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker | Opt_D_dump_if_trace | Opt_D_dump_vt_trace | Opt_D_dump_splices | Opt_D_th_dec_file | Opt_D_dump_BCOs | Opt_D_dump_ticked | Opt_D_dump_rtti | Opt_D_source_stats | Opt_D_verbose_stg2stg | Opt_D_dump_hi | Opt_D_dump_hi_diffs | Opt_D_dump_mod_cycles | Opt_D_dump_mod_map | Opt_D_dump_timings | Opt_D_dump_view_pattern_commoning | Opt_D_verbose_core2core | Opt_D_dump_debug | Opt_D_dump_json | Opt_D_ppr_debug | Opt_D_no_debug_output deriving (Eq, Show, Enum) -- | Enumerates the simple on-or-off dynamic flags data GeneralFlag -- See Note [Updating flag description in the User's Guide] = Opt_DumpToFile -- ^ Append dump output to files instead of stdout. | Opt_D_faststring_stats | Opt_D_dump_minimal_imports | Opt_DoCoreLinting | Opt_DoStgLinting | Opt_DoCmmLinting | Opt_DoAsmLinting | Opt_DoAnnotationLinting | Opt_NoLlvmMangler -- hidden flag | Opt_FastLlvm -- hidden flag | Opt_NoTypeableBinds | Opt_WarnIsError -- -Werror; makes warnings fatal | Opt_ShowWarnGroups -- Show the group a warning belongs to | Opt_HideSourcePaths -- Hide module source/object paths | Opt_PrintExplicitForalls | Opt_PrintExplicitKinds | Opt_PrintExplicitCoercions | Opt_PrintExplicitRuntimeReps | Opt_PrintEqualityRelations | Opt_PrintAxiomIncomps | Opt_PrintUnicodeSyntax | Opt_PrintExpandedSynonyms | Opt_PrintPotentialInstances | Opt_PrintTypecheckerElaboration -- optimisation opts | Opt_CallArity | Opt_Exitification | Opt_Strictness | Opt_LateDmdAnal -- #6087 | Opt_KillAbsence | Opt_KillOneShot | Opt_FullLaziness | Opt_FloatIn | Opt_LateSpecialise | Opt_Specialise | Opt_SpecialiseAggressively | Opt_CrossModuleSpecialise | Opt_StaticArgumentTransformation | Opt_CSE | Opt_StgCSE | Opt_StgLiftLams | Opt_LiberateCase | Opt_SpecConstr | Opt_SpecConstrKeen | Opt_DoLambdaEtaExpansion | Opt_IgnoreAsserts | Opt_DoEtaReduction | Opt_CaseMerge | Opt_CaseFolding -- Constant folding through case-expressions | Opt_UnboxStrictFields | Opt_UnboxSmallStrictFields | Opt_DictsCheap | Opt_EnableRewriteRules -- Apply rewrite rules during simplification | Opt_EnableThSpliceWarnings -- Enable warnings for TH splices | Opt_RegsGraph -- do graph coloring register allocation | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation | Opt_PedanticBottoms -- Be picky about how we treat bottom | Opt_LlvmTBAA -- Use LLVM TBAA infastructure for improving AA (hidden flag) | Opt_LlvmFillUndefWithGarbage -- Testing for undef bugs (hidden flag) | Opt_IrrefutableTuples | Opt_CmmSink | Opt_CmmElimCommonBlocks | Opt_AsmShortcutting | Opt_OmitYields | Opt_FunToThunk -- allow WwLib.mkWorkerArgs to remove all value lambdas | Opt_DictsStrict -- be strict in argument dictionaries | Opt_DmdTxDictSel -- use a special demand transformer for dictionary selectors | Opt_Loopification -- See Note [Self-recursive tail calls] | Opt_CfgBlocklayout -- ^ Use the cfg based block layout algorithm. | Opt_WeightlessBlocklayout -- ^ Layout based on last instruction per block. | Opt_CprAnal | Opt_WorkerWrapper | Opt_SolveConstantDicts | Opt_AlignmentSanitisation | Opt_CatchBottoms | Opt_NumConstantFolding -- PreInlining is on by default. The option is there just to see how -- bad things get if you turn it off! | Opt_SimplPreInlining -- Interface files | Opt_IgnoreInterfacePragmas | Opt_OmitInterfacePragmas | Opt_ExposeAllUnfoldings | Opt_WriteInterface -- forces .hi files to be written even with -fno-code | Opt_WriteHie -- generate .hie files -- profiling opts | Opt_AutoSccsOnIndividualCafs | Opt_ProfCountEntries -- misc opts | Opt_Pp | Opt_ForceRecomp | Opt_IgnoreOptimChanges | Opt_IgnoreHpcChanges | Opt_ExcessPrecision | Opt_EagerBlackHoling | Opt_NoHsMain | Opt_SplitSections | Opt_StgStats | Opt_HideAllPackages | Opt_HideAllPluginPackages | Opt_PrintBindResult | Opt_Haddock | Opt_HaddockOptions | Opt_BreakOnException | Opt_BreakOnError | Opt_PrintEvldWithShow | Opt_PrintBindContents | Opt_GenManifest | Opt_EmbedManifest | Opt_SharedImplib | Opt_BuildingCabalPackage | Opt_IgnoreDotGhci | Opt_GhciSandbox | Opt_GhciHistory | Opt_GhciLeakCheck | Opt_ValidateHie | Opt_LocalGhciHistory | Opt_NoIt | Opt_HelpfulErrors | Opt_DeferTypeErrors | Opt_DeferTypedHoles | Opt_DeferOutOfScopeVariables | Opt_PIC -- ^ @-fPIC@ | Opt_PIE -- ^ @-fPIE@ | Opt_PICExecutable -- ^ @-pie@ | Opt_ExternalDynamicRefs | Opt_SccProfilingOn | Opt_Ticky | Opt_Ticky_Allocd | Opt_Ticky_LNE | Opt_Ticky_Dyn_Thunk | Opt_RPath | Opt_RelativeDynlibPaths | Opt_Hpc | Opt_FlatCache | Opt_ExternalInterpreter | Opt_OptimalApplicativeDo | Opt_VersionMacros | Opt_WholeArchiveHsLibs -- copy all libs into a single folder prior to linking binaries -- this should elivate the excessive command line limit restrictions -- on windows, by only requiring a single -L argument instead of -- one for each dependency. At the time of this writing, gcc -- forwards all -L flags to the collect2 command without using a -- response file and as such breaking apart. | Opt_SingleLibFolder | Opt_KeepCAFs | Opt_KeepGoing | Opt_ByteCode -- output style opts | Opt_ErrorSpans -- Include full span info in error messages, -- instead of just the start position. | Opt_DeferDiagnostics | Opt_DiagnosticsShowCaret -- Show snippets of offending code | Opt_PprCaseAsLet | Opt_PprShowTicks | Opt_ShowHoleConstraints -- Options relating to the display of valid hole fits -- when generating an error message for a typed hole -- See Note [Valid hole fits include] in TcHoleErrors.hs | Opt_ShowValidHoleFits | Opt_SortValidHoleFits | Opt_SortBySizeHoleFits | Opt_SortBySubsumHoleFits | Opt_AbstractRefHoleFits | Opt_UnclutterValidHoleFits | Opt_ShowTypeAppOfHoleFits | Opt_ShowTypeAppVarsOfHoleFits | Opt_ShowDocsOfHoleFits | Opt_ShowTypeOfHoleFits | Opt_ShowProvOfHoleFits | Opt_ShowMatchesOfHoleFits | Opt_ShowLoadedModules | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals] -- Suppress all coercions, them replacing with '...' | Opt_SuppressCoercions | Opt_SuppressVarKinds -- Suppress module id prefixes on variables. | Opt_SuppressModulePrefixes -- Suppress type applications. | Opt_SuppressTypeApplications -- Suppress info such as arity and unfoldings on identifiers. | Opt_SuppressIdInfo -- Suppress separate type signatures in core, but leave types on -- lambda bound vars | Opt_SuppressUnfoldings -- Suppress the details of even stable unfoldings | Opt_SuppressTypeSignatures -- Suppress unique ids on variables. -- Except for uniques, as some simplifier phases introduce new -- variables that have otherwise identical names. | Opt_SuppressUniques | Opt_SuppressStgExts | Opt_SuppressTicks -- Replaces Opt_PprShowTicks | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps -- temporary flags | Opt_AutoLinkPackages | Opt_ImplicitImportQualified -- keeping stuff | Opt_KeepHscppFiles | Opt_KeepHiDiffs | Opt_KeepHcFiles | Opt_KeepSFiles | Opt_KeepTmpFiles | Opt_KeepRawTokenStream | Opt_KeepLlvmFiles | Opt_KeepHiFiles | Opt_KeepOFiles | Opt_BuildDynamicToo -- safe haskell flags | Opt_DistrustAllPackages | Opt_PackageTrust | Opt_PluginTrustworthy | Opt_G_NoStateHack | Opt_G_NoOptCoercion deriving (Eq, Show, Enum) -- Check whether a flag should be considered an "optimisation flag" -- for purposes of recompilation avoidance (see -- Note [Ignoring some flag changes] in FlagChecker). Being listed here is -- not a guarantee that the flag has no other effect. We could, and -- perhaps should, separate out the flags that have some minor impact on -- program semantics and/or error behavior (e.g., assertions), but -- then we'd need to go to extra trouble (and an additional flag) -- to allow users to ignore the optimisation level even though that -- means ignoring some change. optimisationFlags :: EnumSet GeneralFlag optimisationFlags = EnumSet.fromList [ Opt_CallArity , Opt_Strictness , Opt_LateDmdAnal , Opt_KillAbsence , Opt_KillOneShot , Opt_FullLaziness , Opt_FloatIn , Opt_LateSpecialise , Opt_Specialise , Opt_SpecialiseAggressively , Opt_CrossModuleSpecialise , Opt_StaticArgumentTransformation , Opt_CSE , Opt_StgCSE , Opt_StgLiftLams , Opt_LiberateCase , Opt_SpecConstr , Opt_SpecConstrKeen , Opt_DoLambdaEtaExpansion , Opt_IgnoreAsserts , Opt_DoEtaReduction , Opt_CaseMerge , Opt_CaseFolding , Opt_UnboxStrictFields , Opt_UnboxSmallStrictFields , Opt_DictsCheap , Opt_EnableRewriteRules , Opt_RegsGraph , Opt_RegsIterative , Opt_PedanticBottoms , Opt_LlvmTBAA , Opt_LlvmFillUndefWithGarbage , Opt_IrrefutableTuples , Opt_CmmSink , Opt_CmmElimCommonBlocks , Opt_AsmShortcutting , Opt_OmitYields , Opt_FunToThunk , Opt_DictsStrict , Opt_DmdTxDictSel , Opt_Loopification , Opt_CfgBlocklayout , Opt_WeightlessBlocklayout , Opt_CprAnal , Opt_WorkerWrapper , Opt_SolveConstantDicts , Opt_CatchBottoms , Opt_IgnoreAsserts ] -- | Used when outputting warnings: if a reason is given, it is -- displayed. If a warning isn't controlled by a flag, this is made -- explicit at the point of use. data WarnReason = NoReason -- | Warning was enabled with the flag | Reason !WarningFlag -- | Warning was made an error because of -Werror or -Werror=WarningFlag | ErrReason !(Maybe WarningFlag) deriving Show -- | Used to differentiate the scope an include needs to apply to. -- We have to split the include paths to avoid accidentally forcing recursive -- includes since -I overrides the system search paths. See #14312. data IncludeSpecs = IncludeSpecs { includePathsQuote :: [String] , includePathsGlobal :: [String] } deriving Show -- | Append to the list of includes a path that shall be included using `-I` -- when the C compiler is called. These paths override system search paths. addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs addGlobalInclude spec paths = let f = includePathsGlobal spec in spec { includePathsGlobal = f ++ paths } -- | Append to the list of includes a path that shall be included using -- `-iquote` when the C compiler is called. These paths only apply when quoted -- includes are used. e.g. #include "foo.h" addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs addQuoteInclude spec paths = let f = includePathsQuote spec in spec { includePathsQuote = f ++ paths } -- | Concatenate and flatten the list of global and quoted includes returning -- just a flat list of paths. flattenIncludes :: IncludeSpecs -> [String] flattenIncludes specs = includePathsQuote specs ++ includePathsGlobal specs instance Outputable WarnReason where ppr = text . show instance ToJson WarnReason where json NoReason = JSNull json (Reason wf) = JSString (show wf) json (ErrReason Nothing) = JSString "Opt_WarnIsError" json (ErrReason (Just wf)) = JSString (show wf) data WarningFlag = -- See Note [Updating flag description in the User's Guide] Opt_WarnDuplicateExports | Opt_WarnDuplicateConstraints | Opt_WarnRedundantConstraints | Opt_WarnHiShadows | Opt_WarnImplicitPrelude | Opt_WarnIncompletePatterns | Opt_WarnIncompleteUniPatterns | Opt_WarnIncompletePatternsRecUpd | Opt_WarnOverflowedLiterals | Opt_WarnEmptyEnumerations | Opt_WarnMissingFields | Opt_WarnMissingImportList | Opt_WarnMissingMethods | Opt_WarnMissingSignatures | Opt_WarnMissingLocalSignatures | Opt_WarnNameShadowing | Opt_WarnOverlappingPatterns | Opt_WarnTypeDefaults | Opt_WarnMonomorphism | Opt_WarnUnusedTopBinds | Opt_WarnUnusedLocalBinds | Opt_WarnUnusedPatternBinds | Opt_WarnUnusedImports | Opt_WarnUnusedMatches | Opt_WarnUnusedTypePatterns | Opt_WarnUnusedForalls | Opt_WarnUnusedRecordWildcards | Opt_WarnRedundantRecordWildcards | Opt_WarnWarningsDeprecations | Opt_WarnDeprecatedFlags | Opt_WarnMissingMonadFailInstances -- since 8.0 | Opt_WarnSemigroup -- since 8.0 | Opt_WarnDodgyExports | Opt_WarnDodgyImports | Opt_WarnOrphans | Opt_WarnAutoOrphans | Opt_WarnIdentities | Opt_WarnTabs | Opt_WarnUnrecognisedPragmas | Opt_WarnDodgyForeignImports | Opt_WarnUnusedDoBind | Opt_WarnWrongDoBind | Opt_WarnAlternativeLayoutRuleTransitional | Opt_WarnUnsafe | Opt_WarnSafe | Opt_WarnTrustworthySafe | Opt_WarnMissedSpecs | Opt_WarnAllMissedSpecs | Opt_WarnUnsupportedCallingConventions | Opt_WarnUnsupportedLlvmVersion | Opt_WarnMissedExtraSharedLib | Opt_WarnInlineRuleShadowing | Opt_WarnTypedHoles | Opt_WarnPartialTypeSignatures | Opt_WarnMissingExportedSignatures | Opt_WarnUntickedPromotedConstructors | Opt_WarnDerivingTypeable | Opt_WarnDeferredTypeErrors | Opt_WarnDeferredOutOfScopeVariables | Opt_WarnNonCanonicalMonadInstances -- since 8.0 | Opt_WarnNonCanonicalMonadFailInstances -- since 8.0, removed 8.8 | Opt_WarnNonCanonicalMonoidInstances -- since 8.0 | Opt_WarnMissingPatternSynonymSignatures -- since 8.0 | Opt_WarnUnrecognisedWarningFlags -- since 8.0 | Opt_WarnSimplifiableClassConstraints -- Since 8.2 | Opt_WarnCPPUndef -- Since 8.2 | Opt_WarnUnbangedStrictPatterns -- Since 8.2 | Opt_WarnMissingHomeModules -- Since 8.2 | Opt_WarnPartialFields -- Since 8.4 | Opt_WarnMissingExportList | Opt_WarnInaccessibleCode | Opt_WarnStarIsType -- Since 8.6 | Opt_WarnStarBinder -- Since 8.6 | Opt_WarnImplicitKindVars -- Since 8.6 | Opt_WarnSpaceAfterBang | Opt_WarnMissingDerivingStrategies -- Since 8.8 | Opt_WarnPrepositiveQualifiedModule -- Since TBD | Opt_WarnUnusedPackages -- Since 8.10 | Opt_WarnInferredSafeImports -- Since 8.10 | Opt_WarnMissingSafeHaskellMode -- Since 8.10 | Opt_WarnCompatUnqualifiedImports -- Since 8.10 | Opt_WarnDerivingDefaults deriving (Eq, Show, Enum) data Language = Haskell98 | Haskell2010 deriving (Eq, Enum, Show) instance Outputable Language where ppr = text . show -- | The various Safe Haskell modes data SafeHaskellMode = Sf_None -- ^ inferred unsafe | Sf_Unsafe -- ^ declared and checked | Sf_Trustworthy -- ^ declared and checked | Sf_Safe -- ^ declared and checked | Sf_SafeInferred -- ^ inferred as safe | Sf_Ignore -- ^ @-fno-safe-haskell@ state deriving (Eq) instance Show SafeHaskellMode where show Sf_None = "None" show Sf_Unsafe = "Unsafe" show Sf_Trustworthy = "Trustworthy" show Sf_Safe = "Safe" show Sf_SafeInferred = "Safe-Inferred" show Sf_Ignore = "Ignore" instance Outputable SafeHaskellMode where ppr = text . show -- | Contains not only a collection of 'GeneralFlag's but also a plethora of -- information relating to the compilation of a single file or GHC session data DynFlags = DynFlags { ghcMode :: GhcMode, ghcLink :: GhcLink, hscTarget :: HscTarget, -- formerly Settings ghcNameVersion :: {-# UNPACK #-} !GhcNameVersion, fileSettings :: {-# UNPACK #-} !FileSettings, targetPlatform :: Platform, -- Filled in by SysTools toolSettings :: {-# UNPACK #-} !ToolSettings, platformMisc :: {-# UNPACK #-} !PlatformMisc, platformConstants :: PlatformConstants, rawSettings :: [(String, String)], integerLibrary :: IntegerLibrary, -- ^ IntegerGMP or IntegerSimple. Set at configure time, but may be overriden -- by GHC-API users. See Note [The integer library] in PrelNames llvmConfig :: LlvmConfig, -- ^ N.B. It's important that this field is lazy since we load the LLVM -- configuration lazily. See Note [LLVM Configuration] in SysTools. verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] optLevel :: Int, -- ^ Optimisation level debugLevel :: Int, -- ^ How much debug information to produce simplPhases :: Int, -- ^ Number of simplifier phases maxSimplIterations :: Int, -- ^ Max simplifier iterations ruleCheck :: Maybe String, inlineCheck :: Maybe String, -- ^ A prefix to report inlining decisions about strictnessBefore :: [Int], -- ^ Additional demand analysis parMakeCount :: Maybe Int, -- ^ The number of modules to compile in parallel -- in --make mode, where Nothing ==> compile as -- many in parallel as there are CPUs. enableTimeStats :: Bool, -- ^ Enable RTS timing statistics? ghcHeapSize :: Maybe Int, -- ^ The heap size to set. maxRelevantBinds :: Maybe Int, -- ^ Maximum number of bindings from the type envt -- to show in type error messages maxValidHoleFits :: Maybe Int, -- ^ Maximum number of hole fits to show -- in typed hole error messages maxRefHoleFits :: Maybe Int, -- ^ Maximum number of refinement hole -- fits to show in typed hole error -- messages refLevelHoleFits :: Maybe Int, -- ^ Maximum level of refinement for -- refinement hole fits in typed hole -- error messages maxUncoveredPatterns :: Int, -- ^ Maximum number of unmatched patterns to show -- in non-exhaustiveness warnings maxPmCheckModels :: Int, -- ^ Soft limit on the number of models -- the pattern match checker checks -- a pattern against. A safe guard -- against exponential blow-up. simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function specConstrRecursive :: Int, -- ^ Max number of specialisations for recursive types -- Not optional; otherwise ForceSpecConstr can diverge. binBlobThreshold :: Word, -- ^ Binary literals (e.g. strings) whose size is above -- this threshold will be dumped in a binary file -- by the assembler code generator (0 to disable) liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating -- See CoreMonad.FloatOutSwitches liftLamsRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a -- recursive function. liftLamsNonRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a -- non-recursive function. liftLamsKnown :: Bool, -- ^ Lambda lift even when this turns a known call -- into an unknown call. cmmProcAlignment :: Maybe Int, -- ^ Align Cmm functions at this boundary or use default. historySize :: Int, -- ^ Simplification history size importPaths :: [FilePath], mainModIs :: Module, mainFunIs :: Maybe String, reductionDepth :: IntWithInf, -- ^ Typechecker maximum stack depth solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver -- Typically only 1 is needed thisInstalledUnitId :: InstalledUnitId, thisComponentId_ :: Maybe ComponentId, thisUnitIdInsts_ :: Maybe [(ModuleName, Module)], -- ways ways :: [Way], -- ^ Way flags from the command line buildTag :: String, -- ^ The global \"way\" (e.g. \"p\" for prof) -- For object splitting splitInfo :: Maybe (String,Int), -- paths etc. objectDir :: Maybe String, dylibInstallName :: Maybe String, hiDir :: Maybe String, hieDir :: Maybe String, stubDir :: Maybe String, dumpDir :: Maybe String, objectSuf :: String, hcSuf :: String, hiSuf :: String, hieSuf :: String, canGenerateDynamicToo :: IORef Bool, dynObjectSuf :: String, dynHiSuf :: String, outputFile :: Maybe String, dynOutputFile :: Maybe String, outputHi :: Maybe String, dynLibLoader :: DynLibLoader, -- | This is set by 'DriverPipeline.runPipeline' based on where -- its output is going. dumpPrefix :: Maybe FilePath, -- | Override the 'dumpPrefix' set by 'DriverPipeline.runPipeline'. -- Set by @-ddump-file-prefix@ dumpPrefixForce :: Maybe FilePath, ldInputs :: [Option], includePaths :: IncludeSpecs, libraryPaths :: [String], frameworkPaths :: [String], -- used on darwin only cmdlineFrameworks :: [String], -- ditto rtsOpts :: Maybe String, rtsOptsEnabled :: RtsOptsEnabled, rtsOptsSuggestions :: Bool, hpcDir :: String, -- ^ Path to store the .mix files -- Plugins pluginModNames :: [ModuleName], pluginModNameOpts :: [(ModuleName,String)], frontendPluginOpts :: [String], -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse* -- order that they're specified on the command line. cachedPlugins :: [LoadedPlugin], -- ^ plugins dynamically loaded after processing arguments. What will be -- loaded here is directed by pluginModNames. Arguments are loaded from -- pluginModNameOpts. The purpose of this field is to cache the plugins so -- they don't have to be loaded each time they are needed. See -- 'DynamicLoading.initializePlugins'. staticPlugins :: [StaticPlugin], -- ^ staic plugins which do not need dynamic loading. These plugins are -- intended to be added by GHC API users directly to this list. -- -- To add dynamically loaded plugins through the GHC API see -- 'addPluginModuleName' instead. -- GHC API hooks hooks :: Hooks, -- For ghc -M depMakefile :: FilePath, depIncludePkgDeps :: Bool, depIncludeCppDeps :: Bool, depExcludeMods :: [ModuleName], depSuffixes :: [String], -- Package flags packageDBFlags :: [PackageDBFlag], -- ^ The @-package-db@ flags given on the command line, In -- *reverse* order that they're specified on the command line. -- This is intended to be applied with the list of "initial" -- package databases derived from @GHC_PACKAGE_PATH@; see -- 'getPackageConfRefs'. ignorePackageFlags :: [IgnorePackageFlag], -- ^ The @-ignore-package@ flags from the command line. -- In *reverse* order that they're specified on the command line. packageFlags :: [PackageFlag], -- ^ The @-package@ and @-hide-package@ flags from the command-line. -- In *reverse* order that they're specified on the command line. pluginPackageFlags :: [PackageFlag], -- ^ The @-plugin-package-id@ flags from command line. -- In *reverse* order that they're specified on the command line. trustFlags :: [TrustFlag], -- ^ The @-trust@ and @-distrust@ flags. -- In *reverse* order that they're specified on the command line. packageEnv :: Maybe FilePath, -- ^ Filepath to the package environment file (if overriding default) -- Package state -- NB. do not modify this field, it is calculated by -- Packages.initPackages pkgDatabase :: Maybe [(FilePath, [PackageConfig])], pkgState :: PackageState, -- Temporary files -- These have to be IORefs, because the defaultCleanupHandler needs to -- know what to clean when an exception happens filesToClean :: IORef FilesToClean, dirsToClean :: IORef (Map FilePath FilePath), -- The next available suffix to uniquely name a temp file, updated atomically nextTempSuffix :: IORef Int, -- Names of files which were generated from -ddump-to-file; used to -- track which ones we need to truncate because it's our first run -- through generatedDumps :: IORef (Set FilePath), -- hsc dynamic flags dumpFlags :: EnumSet DumpFlag, generalFlags :: EnumSet GeneralFlag, warningFlags :: EnumSet WarningFlag, fatalWarningFlags :: EnumSet WarningFlag, -- Don't change this without updating extensionFlags: language :: Maybe Language, -- | Safe Haskell mode safeHaskell :: SafeHaskellMode, safeInfer :: Bool, safeInferred :: Bool, -- We store the location of where some extension and flags were turned on so -- we can produce accurate error messages when Safe Haskell fails due to -- them. thOnLoc :: SrcSpan, newDerivOnLoc :: SrcSpan, overlapInstLoc :: SrcSpan, incoherentOnLoc :: SrcSpan, pkgTrustOnLoc :: SrcSpan, warnSafeOnLoc :: SrcSpan, warnUnsafeOnLoc :: SrcSpan, trustworthyOnLoc :: SrcSpan, -- Don't change this without updating extensionFlags: -- Here we collect the settings of the language extensions -- from the command line, the ghci config file and -- from interactive :set / :seti commands. extensions :: [OnOff LangExt.Extension], -- extensionFlags should always be equal to -- flattenExtensionFlags language extensions -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used -- by template-haskell extensionFlags :: EnumSet LangExt.Extension, -- Unfolding control -- See Note [Discounts and thresholds] in CoreUnfold ufCreationThreshold :: Int, ufUseThreshold :: Int, ufFunAppDiscount :: Int, ufDictDiscount :: Int, ufKeenessFactor :: Float, ufDearOp :: Int, ufVeryAggressive :: Bool, maxWorkerArgs :: Int, ghciHistSize :: Int, -- | MsgDoc output action: use "ErrUtils" instead of this if you can log_action :: LogAction, flushOut :: FlushOut, flushErr :: FlushErr, ghcVersionFile :: Maybe FilePath, haddockOptions :: Maybe String, -- | GHCi scripts specified by -ghci-script, in reverse order ghciScripts :: [String], -- Output style options pprUserLength :: Int, pprCols :: Int, useUnicode :: Bool, useColor :: OverridingBool, canUseColor :: Bool, colScheme :: Col.Scheme, -- | what kind of {-# SCC #-} to add automatically profAuto :: ProfAuto, interactivePrint :: Maybe String, nextWrapperNum :: IORef (ModuleEnv Int), -- | Machine dependent flags (-m stuff) sseVersion :: Maybe SseVersion, bmiVersion :: Maybe BmiVersion, avx :: Bool, avx2 :: Bool, avx512cd :: Bool, -- Enable AVX-512 Conflict Detection Instructions. avx512er :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions. avx512f :: Bool, -- Enable AVX-512 instructions. avx512pf :: Bool, -- Enable AVX-512 PreFetch Instructions. -- | Run-time linker information (what options we need, etc.) rtldInfo :: IORef (Maybe LinkerInfo), -- | Run-time compiler information rtccInfo :: IORef (Maybe CompilerInfo), -- Constants used to control the amount of optimization done. -- | Max size, in bytes, of inline array allocations. maxInlineAllocSize :: Int, -- | Only inline memcpy if it generates no more than this many -- pseudo (roughly: Cmm) instructions. maxInlineMemcpyInsns :: Int, -- | Only inline memset if it generates no more than this many -- pseudo (roughly: Cmm) instructions. maxInlineMemsetInsns :: Int, -- | Reverse the order of error messages in GHC/GHCi reverseErrors :: Bool, -- | Limit the maximum number of errors to show maxErrors :: Maybe Int, -- | Unique supply configuration for testing build determinism initialUnique :: Int, uniqueIncrement :: Int, -- | Temporary: CFG Edge weights for fast iterations cfgWeightInfo :: CfgWeights } -- | Edge weights to use when generating a CFG from CMM data CfgWeights = CFGWeights { uncondWeight :: Int , condBranchWeight :: Int , switchWeight :: Int , callWeight :: Int , likelyCondWeight :: Int , unlikelyCondWeight :: Int , infoTablePenalty :: Int , backEdgeBonus :: Int } defaultCfgWeights :: CfgWeights defaultCfgWeights = CFGWeights { uncondWeight = 1000 , condBranchWeight = 800 , switchWeight = 1 , callWeight = -10 , likelyCondWeight = 900 , unlikelyCondWeight = 300 , infoTablePenalty = 300 , backEdgeBonus = 400 } parseCfgWeights :: String -> CfgWeights -> CfgWeights parseCfgWeights s oldWeights = foldl' (\cfg (n,v) -> update n v cfg) oldWeights assignments where assignments = map assignment $ settings s update "uncondWeight" n w = w {uncondWeight = n} update "condBranchWeight" n w = w {condBranchWeight = n} update "switchWeight" n w = w {switchWeight = n} update "callWeight" n w = w {callWeight = n} update "likelyCondWeight" n w = w {likelyCondWeight = n} update "unlikelyCondWeight" n w = w {unlikelyCondWeight = n} update "infoTablePenalty" n w = w {infoTablePenalty = n} update "backEdgeBonus" n w = w {backEdgeBonus = n} update other _ _ = panic $ other ++ " is not a cfg weight parameter. " ++ exampleString settings s | (s1,rest) <- break (== ',') s , null rest = [s1] | (s1,rest) <- break (== ',') s = [s1] ++ settings (drop 1 rest) | otherwise = panic $ "Invalid cfg parameters." ++ exampleString assignment as | (name, _:val) <- break (== '=') as = (name,read val) | otherwise = panic $ "Invalid cfg parameters." ++ exampleString exampleString = "Example parameters: uncondWeight=1000," ++ "condBranchWeight=800,switchWeight=0,callWeight=300" ++ ",likelyCondWeight=900,unlikelyCondWeight=300" ++ ",infoTablePenalty=300,backEdgeBonus=400" backendMaintainsCfg :: DynFlags -> Bool backendMaintainsCfg dflags = case (platformArch $ targetPlatform dflags) of -- ArchX86 -- Should work but not tested so disabled currently. ArchX86_64 -> True _otherwise -> False class HasDynFlags m where getDynFlags :: m DynFlags {- It would be desirable to have the more generalised instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where getDynFlags = lift getDynFlags instance definition. However, that definition would overlap with the `HasDynFlags (GhcT m)` instance. Instead we define instances for a couple of common Monad transformers explicitly. -} instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where getDynFlags = lift getDynFlags instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where getDynFlags = lift getDynFlags instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where getDynFlags = lift getDynFlags instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where getDynFlags = lift getDynFlags class ContainsDynFlags t where extractDynFlags :: t -> DynFlags data ProfAuto = NoProfAuto -- ^ no SCC annotations added | ProfAutoAll -- ^ top-level and nested functions are annotated | ProfAutoTop -- ^ top-level functions annotated only | ProfAutoExports -- ^ exported functions annotated only | ProfAutoCalls -- ^ annotate call-sites deriving (Eq,Enum) data LlvmTarget = LlvmTarget { lDataLayout :: String , lCPU :: String , lAttributes :: [String] } -- | See Note [LLVM Configuration] in SysTools. data LlvmConfig = LlvmConfig { llvmTargets :: [(String, LlvmTarget)] , llvmPasses :: [(Int, String)] } ----------------------------------------------------------------------------- -- Accessessors from 'DynFlags' -- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the -- vast majority of code. But GHCi questionably uses this to produce a default -- 'DynFlags' from which to compute a flags diff for printing. settings :: DynFlags -> Settings settings dflags = Settings { sGhcNameVersion = ghcNameVersion dflags , sFileSettings = fileSettings dflags , sTargetPlatform = targetPlatform dflags , sToolSettings = toolSettings dflags , sPlatformMisc = platformMisc dflags , sPlatformConstants = platformConstants dflags , sRawSettings = rawSettings dflags } programName :: DynFlags -> String programName dflags = ghcNameVersion_programName $ ghcNameVersion dflags projectVersion :: DynFlags -> String projectVersion dflags = ghcNameVersion_projectVersion (ghcNameVersion dflags) ghcUsagePath :: DynFlags -> FilePath ghcUsagePath dflags = fileSettings_ghcUsagePath $ fileSettings dflags ghciUsagePath :: DynFlags -> FilePath ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags toolDir :: DynFlags -> Maybe FilePath toolDir dflags = fileSettings_toolDir $ fileSettings dflags topDir :: DynFlags -> FilePath topDir dflags = fileSettings_topDir $ fileSettings dflags tmpDir :: DynFlags -> String tmpDir dflags = fileSettings_tmpDir $ fileSettings dflags extraGccViaCFlags :: DynFlags -> [String] extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags systemPackageConfig :: DynFlags -> FilePath systemPackageConfig dflags = fileSettings_systemPackageConfig $ fileSettings dflags pgm_L :: DynFlags -> String pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags pgm_P :: DynFlags -> (String,[Option]) pgm_P dflags = toolSettings_pgm_P $ toolSettings dflags pgm_F :: DynFlags -> String pgm_F dflags = toolSettings_pgm_F $ toolSettings dflags pgm_c :: DynFlags -> String pgm_c dflags = toolSettings_pgm_c $ toolSettings dflags pgm_a :: DynFlags -> (String,[Option]) pgm_a dflags = toolSettings_pgm_a $ toolSettings dflags pgm_l :: DynFlags -> (String,[Option]) pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags pgm_lm :: DynFlags -> (String,[Option]) pgm_lm dflags = toolSettings_pgm_lm $ toolSettings dflags pgm_dll :: DynFlags -> (String,[Option]) pgm_dll dflags = toolSettings_pgm_dll $ toolSettings dflags pgm_T :: DynFlags -> String pgm_T dflags = toolSettings_pgm_T $ toolSettings dflags pgm_windres :: DynFlags -> String pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags pgm_libtool :: DynFlags -> String pgm_libtool dflags = toolSettings_pgm_libtool $ toolSettings dflags pgm_lcc :: DynFlags -> (String,[Option]) pgm_lcc dflags = toolSettings_pgm_lcc $ toolSettings dflags pgm_ar :: DynFlags -> String pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags pgm_ranlib :: DynFlags -> String pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags pgm_lo :: DynFlags -> (String,[Option]) pgm_lo dflags = toolSettings_pgm_lo $ toolSettings dflags pgm_lc :: DynFlags -> (String,[Option]) pgm_lc dflags = toolSettings_pgm_lc $ toolSettings dflags pgm_i :: DynFlags -> String pgm_i dflags = toolSettings_pgm_i $ toolSettings dflags opt_L :: DynFlags -> [String] opt_L dflags = toolSettings_opt_L $ toolSettings dflags opt_P :: DynFlags -> [String] opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) ++ toolSettings_opt_P (toolSettings dflags) -- This function packages everything that's needed to fingerprint opt_P -- flags. See Note [Repeated -optP hashing]. opt_P_signature :: DynFlags -> ([String], Fingerprint) opt_P_signature dflags = ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags) , toolSettings_opt_P_fingerprint $ toolSettings dflags ) opt_F :: DynFlags -> [String] opt_F dflags= toolSettings_opt_F $ toolSettings dflags opt_c :: DynFlags -> [String] opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags) ++ toolSettings_opt_c (toolSettings dflags) opt_cxx :: DynFlags -> [String] opt_cxx dflags= toolSettings_opt_cxx $ toolSettings dflags opt_a :: DynFlags -> [String] opt_a dflags= toolSettings_opt_a $ toolSettings dflags opt_l :: DynFlags -> [String] opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags) ++ toolSettings_opt_l (toolSettings dflags) opt_lm :: DynFlags -> [String] opt_lm dflags= toolSettings_opt_lm $ toolSettings dflags opt_windres :: DynFlags -> [String] opt_windres dflags= toolSettings_opt_windres $ toolSettings dflags opt_lcc :: DynFlags -> [String] opt_lcc dflags= toolSettings_opt_lcc $ toolSettings dflags opt_lo :: DynFlags -> [String] opt_lo dflags= toolSettings_opt_lo $ toolSettings dflags opt_lc :: DynFlags -> [String] opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags opt_i :: DynFlags -> [String] opt_i dflags= toolSettings_opt_i $ toolSettings dflags tablesNextToCode :: DynFlags -> Bool tablesNextToCode = platformMisc_tablesNextToCode . platformMisc -- | The directory for this version of ghc in the user's app directory -- (typically something like @~/.ghc/x86_64-linux-7.6.3@) -- versionedAppDir :: DynFlags -> MaybeT IO FilePath versionedAppDir dflags = do -- Make sure we handle the case the HOME isn't set (see #11678) appdir <- tryMaybeT $ getAppUserDataDirectory (programName dflags) return $ appdir versionedFilePath dflags versionedFilePath :: DynFlags -> FilePath versionedFilePath dflags = uniqueSubdir $ platformMini $ targetPlatform dflags -- | The target code type of the compilation (if any). -- -- Whenever you change the target, also make sure to set 'ghcLink' to -- something sensible. -- -- 'HscNothing' can be used to avoid generating any output, however, note -- that: -- -- * If a program uses Template Haskell the typechecker may need to run code -- from an imported module. To facilitate this, code generation is enabled -- for modules imported by modules that use template haskell. -- See Note [-fno-code mode]. -- data HscTarget = HscC -- ^ Generate C code. | HscAsm -- ^ Generate assembly using the native code generator. | HscLlvm -- ^ Generate assembly using the llvm code generator. | HscInterpreted -- ^ Generate bytecode. (Requires 'LinkInMemory') | HscNothing -- ^ Don't generate any code. See notes above. deriving (Eq, Show) -- | Will this target result in an object file on the disk? isObjectTarget :: HscTarget -> Bool isObjectTarget HscC = True isObjectTarget HscAsm = True isObjectTarget HscLlvm = True isObjectTarget _ = False -- | Does this target retain *all* top-level bindings for a module, -- rather than just the exported bindings, in the TypeEnv and compiled -- code (if any)? In interpreted mode we do this, so that GHCi can -- call functions inside a module. In HscNothing mode we also do it, -- so that Haddock can get access to the GlobalRdrEnv for a module -- after typechecking it. targetRetainsAllBindings :: HscTarget -> Bool targetRetainsAllBindings HscInterpreted = True targetRetainsAllBindings HscNothing = True targetRetainsAllBindings _ = False -- | The 'GhcMode' tells us whether we're doing multi-module -- compilation (controlled via the "GHC" API) or one-shot -- (single-module) compilation. This makes a difference primarily to -- the "Finder": in one-shot mode we look for interface files for -- imported modules, but in multi-module mode we look for source files -- in order to check whether they need to be recompiled. data GhcMode = CompManager -- ^ @\-\-make@, GHCi, etc. | OneShot -- ^ @ghc -c Foo.hs@ | MkDepend -- ^ @ghc -M@, see "Finder" for why we need this deriving Eq instance Outputable GhcMode where ppr CompManager = text "CompManager" ppr OneShot = text "OneShot" ppr MkDepend = text "MkDepend" isOneShot :: GhcMode -> Bool isOneShot OneShot = True isOneShot _other = False -- | What to do in the link step, if there is one. data GhcLink = NoLink -- ^ Don't link at all | LinkBinary -- ^ Link object code into a binary | LinkInMemory -- ^ Use the in-memory dynamic linker (works for both -- bytecode and object code). | LinkDynLib -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) | LinkStaticLib -- ^ Link objects into a static lib deriving (Eq, Show) isNoLink :: GhcLink -> Bool isNoLink NoLink = True isNoLink _ = False -- | We accept flags which make packages visible, but how they select -- the package varies; this data type reflects what selection criterion -- is used. data PackageArg = PackageArg String -- ^ @-package@, by 'PackageName' | UnitIdArg UnitId -- ^ @-package-id@, by 'UnitId' deriving (Eq, Show) instance Outputable PackageArg where ppr (PackageArg pn) = text "package" <+> text pn ppr (UnitIdArg uid) = text "unit" <+> ppr uid -- | Represents the renaming that may be associated with an exposed -- package, e.g. the @rns@ part of @-package "foo (rns)"@. -- -- Here are some example parsings of the package flags (where -- a string literal is punned to be a 'ModuleName': -- -- * @-package foo@ is @ModRenaming True []@ -- * @-package foo ()@ is @ModRenaming False []@ -- * @-package foo (A)@ is @ModRenaming False [("A", "A")]@ -- * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@ -- * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@ data ModRenaming = ModRenaming { modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope? modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope -- under name @n@. } deriving (Eq) instance Outputable ModRenaming where ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns) -- | Flags for manipulating the set of non-broken packages. newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@ deriving (Eq) -- | Flags for manipulating package trust. data TrustFlag = TrustPackage String -- ^ @-trust@ | DistrustPackage String -- ^ @-distrust@ deriving (Eq) -- | Flags for manipulating packages visibility. data PackageFlag = ExposePackage String PackageArg ModRenaming -- ^ @-package@, @-package-id@ | HidePackage String -- ^ @-hide-package@ deriving (Eq) -- NB: equality instance is used by packageFlagsChanged data PackageDBFlag = PackageDB PkgConfRef | NoUserPackageDB | NoGlobalPackageDB | ClearPackageDBs deriving (Eq) packageFlagsChanged :: DynFlags -> DynFlags -> Bool packageFlagsChanged idflags1 idflags0 = packageFlags idflags1 /= packageFlags idflags0 || ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 || pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 || trustFlags idflags1 /= trustFlags idflags0 || packageDBFlags idflags1 /= packageDBFlags idflags0 || packageGFlags idflags1 /= packageGFlags idflags0 where packageGFlags dflags = map (`gopt` dflags) [ Opt_HideAllPackages , Opt_HideAllPluginPackages , Opt_AutoLinkPackages ] instance Outputable PackageFlag where ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn) ppr (HidePackage str) = text "-hide-package" <+> text str -- | The 'HscTarget' value corresponding to the default way to create -- object files on the current platform. defaultHscTarget :: Platform -> PlatformMisc -> HscTarget defaultHscTarget platform pMisc | platformUnregisterised platform = HscC | platformMisc_ghcWithNativeCodeGen pMisc = HscAsm | otherwise = HscLlvm defaultObjectTarget :: DynFlags -> HscTarget defaultObjectTarget dflags = defaultHscTarget (targetPlatform dflags) (platformMisc dflags) data DynLibLoader = Deployable | SystemDependent deriving Eq data RtsOptsEnabled = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly | RtsOptsAll deriving (Show) shouldUseColor :: DynFlags -> Bool shouldUseColor dflags = overrideWith (canUseColor dflags) (useColor dflags) shouldUseHexWordLiterals :: DynFlags -> Bool shouldUseHexWordLiterals dflags = Opt_HexWordLiterals `EnumSet.member` generalFlags dflags -- | Are we building with @-fPIE@ or @-fPIC@ enabled? positionIndependent :: DynFlags -> Bool positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags ----------------------------------------------------------------------------- -- Ways -- The central concept of a "way" is that all objects in a given -- program must be compiled in the same "way". Certain options change -- parameters of the virtual machine, eg. profiling adds an extra word -- to the object header, so profiling objects cannot be linked with -- non-profiling objects. -- After parsing the command-line options, we determine which "way" we -- are building - this might be a combination way, eg. profiling+threaded. -- We then find the "build-tag" associated with this way, and this -- becomes the suffix used to find .hi files and libraries used in -- this compilation. data Way = WayCustom String -- for GHC API clients building custom variants | WayThreaded | WayDebug | WayProf | WayEventLog | WayDyn deriving (Eq, Ord, Show) allowed_combination :: [Way] -> Bool allowed_combination way = and [ x `allowedWith` y | x <- way, y <- way, x < y ] where -- Note ordering in these tests: the left argument is -- <= the right argument, according to the Ord instance -- on Way above. -- dyn is allowed with everything _ `allowedWith` WayDyn = True WayDyn `allowedWith` _ = True -- debug is allowed with everything _ `allowedWith` WayDebug = True WayDebug `allowedWith` _ = True (WayCustom {}) `allowedWith` _ = True WayThreaded `allowedWith` WayProf = True WayThreaded `allowedWith` WayEventLog = True WayProf `allowedWith` WayEventLog = True _ `allowedWith` _ = False mkBuildTag :: [Way] -> String mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) wayTag :: Way -> String wayTag (WayCustom xs) = xs wayTag WayThreaded = "thr" wayTag WayDebug = "debug" wayTag WayDyn = "dyn" wayTag WayProf = "p" wayTag WayEventLog = "l" wayRTSOnly :: Way -> Bool wayRTSOnly (WayCustom {}) = False wayRTSOnly WayThreaded = True wayRTSOnly WayDebug = True wayRTSOnly WayDyn = False wayRTSOnly WayProf = False wayRTSOnly WayEventLog = True wayDesc :: Way -> String wayDesc (WayCustom xs) = xs wayDesc WayThreaded = "Threaded" wayDesc WayDebug = "Debug" wayDesc WayDyn = "Dynamic" wayDesc WayProf = "Profiling" wayDesc WayEventLog = "RTS Event Logging" -- Turn these flags on when enabling this way wayGeneralFlags :: Platform -> Way -> [GeneralFlag] wayGeneralFlags _ (WayCustom {}) = [] wayGeneralFlags _ WayThreaded = [] wayGeneralFlags _ WayDebug = [] wayGeneralFlags _ WayDyn = [Opt_PIC, Opt_ExternalDynamicRefs] -- We could get away without adding -fPIC when compiling the -- modules of a program that is to be linked with -dynamic; the -- program itself does not need to be position-independent, only -- the libraries need to be. HOWEVER, GHCi links objects into a -- .so before loading the .so using the system linker. Since only -- PIC objects can be linked into a .so, we have to compile even -- modules of the main program with -fPIC when using -dynamic. wayGeneralFlags _ WayProf = [Opt_SccProfilingOn] wayGeneralFlags _ WayEventLog = [] -- Turn these flags off when enabling this way wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag] wayUnsetGeneralFlags _ (WayCustom {}) = [] wayUnsetGeneralFlags _ WayThreaded = [] wayUnsetGeneralFlags _ WayDebug = [] wayUnsetGeneralFlags _ WayDyn = [-- There's no point splitting -- when we're going to be dynamically -- linking. Plus it breaks compilation -- on OSX x86. Opt_SplitSections] wayUnsetGeneralFlags _ WayProf = [] wayUnsetGeneralFlags _ WayEventLog = [] wayOptc :: Platform -> Way -> [String] wayOptc _ (WayCustom {}) = [] wayOptc platform WayThreaded = case platformOS platform of OSOpenBSD -> ["-pthread"] OSNetBSD -> ["-pthread"] _ -> [] wayOptc _ WayDebug = [] wayOptc _ WayDyn = [] wayOptc _ WayProf = ["-DPROFILING"] wayOptc _ WayEventLog = ["-DTRACING"] wayOptl :: Platform -> Way -> [String] wayOptl _ (WayCustom {}) = [] wayOptl platform WayThreaded = case platformOS platform of -- N.B. FreeBSD cc throws a warning if we pass -pthread without -- actually using any pthread symbols. OSFreeBSD -> ["-pthread", "-Wno-unused-command-line-argument"] OSOpenBSD -> ["-pthread"] OSNetBSD -> ["-pthread"] _ -> [] wayOptl _ WayDebug = [] wayOptl _ WayDyn = [] wayOptl _ WayProf = [] wayOptl _ WayEventLog = [] wayOptP :: Platform -> Way -> [String] wayOptP _ (WayCustom {}) = [] wayOptP _ WayThreaded = [] wayOptP _ WayDebug = [] wayOptP _ WayDyn = [] wayOptP _ WayProf = ["-DPROFILING"] wayOptP _ WayEventLog = ["-DTRACING"] whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m () whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ()) ifGeneratingDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a ifGeneratingDynamicToo dflags f g = generateDynamicTooConditional dflags f g g whenCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m () -> m () whenCannotGenerateDynamicToo dflags f = ifCannotGenerateDynamicToo dflags f (return ()) ifCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a ifCannotGenerateDynamicToo dflags f g = generateDynamicTooConditional dflags g f g generateDynamicTooConditional :: MonadIO m => DynFlags -> m a -> m a -> m a -> m a generateDynamicTooConditional dflags canGen cannotGen notTryingToGen = if gopt Opt_BuildDynamicToo dflags then do let ref = canGenerateDynamicToo dflags b <- liftIO $ readIORef ref if b then canGen else cannotGen else notTryingToGen dynamicTooMkDynamicDynFlags :: DynFlags -> DynFlags dynamicTooMkDynamicDynFlags dflags0 = let dflags1 = addWay' WayDyn dflags0 dflags2 = dflags1 { outputFile = dynOutputFile dflags1, hiSuf = dynHiSuf dflags1, objectSuf = dynObjectSuf dflags1 } dflags3 = updateWays dflags2 dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo in dflags4 -- | Compute the path of the dynamic object corresponding to an object file. dynamicOutputFile :: DynFlags -> FilePath -> FilePath dynamicOutputFile dflags outputFile = dynOut outputFile where dynOut = flip addExtension (dynObjectSuf dflags) . dropExtension ----------------------------------------------------------------------------- -- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value initDynFlags :: DynFlags -> IO DynFlags initDynFlags dflags = do let -- We can't build with dynamic-too on Windows, as labels before -- the fork point are different depending on whether we are -- building dynamically or not. platformCanGenerateDynamicToo = platformOS (targetPlatform dflags) /= OSMinGW32 refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo refNextTempSuffix <- newIORef 0 refFilesToClean <- newIORef emptyFilesToClean refDirsToClean <- newIORef Map.empty refGeneratedDumps <- newIORef Set.empty refRtldInfo <- newIORef Nothing refRtccInfo <- newIORef Nothing wrapperNum <- newIORef emptyModuleEnv canUseUnicode <- do let enc = localeEncoding str = "‘’" (withCString enc str $ \cstr -> do str' <- peekCString enc cstr return (str == str')) `catchIOError` \_ -> return False maybeGhcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE" let adjustNoUnicode (Just _) = False adjustNoUnicode Nothing = True let useUnicode' = (adjustNoUnicode maybeGhcNoUnicodeEnv) && canUseUnicode canUseColor <- stderrSupportsAnsiColors maybeGhcColorsEnv <- lookupEnv "GHC_COLORS" maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS" let adjustCols (Just env) = Col.parseScheme env adjustCols Nothing = id let (useColor', colScheme') = (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv) (useColor dflags, colScheme dflags) return dflags{ canGenerateDynamicToo = refCanGenerateDynamicToo, nextTempSuffix = refNextTempSuffix, filesToClean = refFilesToClean, dirsToClean = refDirsToClean, generatedDumps = refGeneratedDumps, nextWrapperNum = wrapperNum, useUnicode = useUnicode', useColor = useColor', canUseColor = canUseColor, colScheme = colScheme', rtldInfo = refRtldInfo, rtccInfo = refRtccInfo } -- | The normal 'DynFlags'. Note that they are not suitable for use in this form -- and must be fully initialized by 'GHC.runGhc' first. defaultDynFlags :: Settings -> LlvmConfig -> DynFlags defaultDynFlags mySettings llvmConfig = -- See Note [Updating flag description in the User's Guide] DynFlags { ghcMode = CompManager, ghcLink = LinkBinary, hscTarget = defaultHscTarget (sTargetPlatform mySettings) (sPlatformMisc mySettings), integerLibrary = sIntegerLibraryType mySettings, verbosity = 0, optLevel = 0, debugLevel = 0, simplPhases = 2, maxSimplIterations = 4, ruleCheck = Nothing, inlineCheck = Nothing, binBlobThreshold = 500000, -- 500K is a good default (see #16190) maxRelevantBinds = Just 6, maxValidHoleFits = Just 6, maxRefHoleFits = Just 6, refLevelHoleFits = Nothing, maxUncoveredPatterns = 4, maxPmCheckModels = 100, simplTickFactor = 100, specConstrThreshold = Just 2000, specConstrCount = Just 3, specConstrRecursive = 3, liberateCaseThreshold = Just 2000, floatLamArgs = Just 0, -- Default: float only if no fvs liftLamsRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 liftLamsNonRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 liftLamsKnown = False, -- Default: don't turn known calls into unknown ones cmmProcAlignment = Nothing, historySize = 20, strictnessBefore = [], parMakeCount = Just 1, enableTimeStats = False, ghcHeapSize = Nothing, importPaths = ["."], mainModIs = mAIN, mainFunIs = Nothing, reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, thisInstalledUnitId = toInstalledUnitId mainUnitId, thisUnitIdInsts_ = Nothing, thisComponentId_ = Nothing, objectDir = Nothing, dylibInstallName = Nothing, hiDir = Nothing, hieDir = Nothing, stubDir = Nothing, dumpDir = Nothing, objectSuf = phaseInputExt StopLn, hcSuf = phaseInputExt HCc, hiSuf = "hi", hieSuf = "hie", canGenerateDynamicToo = panic "defaultDynFlags: No canGenerateDynamicToo", dynObjectSuf = "dyn_" ++ phaseInputExt StopLn, dynHiSuf = "dyn_hi", pluginModNames = [], pluginModNameOpts = [], frontendPluginOpts = [], cachedPlugins = [], staticPlugins = [], hooks = emptyHooks, outputFile = Nothing, dynOutputFile = Nothing, outputHi = Nothing, dynLibLoader = SystemDependent, dumpPrefix = Nothing, dumpPrefixForce = Nothing, ldInputs = [], includePaths = IncludeSpecs [] [], libraryPaths = [], frameworkPaths = [], cmdlineFrameworks = [], rtsOpts = Nothing, rtsOptsEnabled = RtsOptsSafeOnly, rtsOptsSuggestions = True, hpcDir = ".hpc", packageDBFlags = [], packageFlags = [], pluginPackageFlags = [], ignorePackageFlags = [], trustFlags = [], packageEnv = Nothing, pkgDatabase = Nothing, -- This gets filled in with GHC.setSessionDynFlags pkgState = emptyPackageState, ways = defaultWays mySettings, buildTag = mkBuildTag (defaultWays mySettings), splitInfo = Nothing, ghcNameVersion = sGhcNameVersion mySettings, fileSettings = sFileSettings mySettings, toolSettings = sToolSettings mySettings, targetPlatform = sTargetPlatform mySettings, platformMisc = sPlatformMisc mySettings, platformConstants = sPlatformConstants mySettings, rawSettings = sRawSettings mySettings, -- See Note [LLVM configuration]. llvmConfig = llvmConfig, -- ghc -M values depMakefile = "Makefile", depIncludePkgDeps = False, depIncludeCppDeps = False, depExcludeMods = [], depSuffixes = [], -- end of ghc -M values nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix", filesToClean = panic "defaultDynFlags: No filesToClean", dirsToClean = panic "defaultDynFlags: No dirsToClean", generatedDumps = panic "defaultDynFlags: No generatedDumps", ghcVersionFile = Nothing, haddockOptions = Nothing, dumpFlags = EnumSet.empty, generalFlags = EnumSet.fromList (defaultFlags mySettings), warningFlags = EnumSet.fromList standardWarnings, fatalWarningFlags = EnumSet.empty, ghciScripts = [], language = Nothing, safeHaskell = Sf_None, safeInfer = True, safeInferred = True, thOnLoc = noSrcSpan, newDerivOnLoc = noSrcSpan, overlapInstLoc = noSrcSpan, incoherentOnLoc = noSrcSpan, pkgTrustOnLoc = noSrcSpan, warnSafeOnLoc = noSrcSpan, warnUnsafeOnLoc = noSrcSpan, trustworthyOnLoc = noSrcSpan, extensions = [], extensionFlags = flattenExtensionFlags Nothing [], -- The ufCreationThreshold threshold must be reasonably high to -- take account of possible discounts. -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to inline -- into Csg.calc (The unfolding for sqr never makes it into the -- interface file.) ufCreationThreshold = 750, ufUseThreshold = 60, ufFunAppDiscount = 60, -- Be fairly keen to inline a function if that means -- we'll be able to pick the right method from a dictionary ufDictDiscount = 30, ufKeenessFactor = 1.5, ufDearOp = 40, ufVeryAggressive = False, maxWorkerArgs = 10, ghciHistSize = 50, -- keep a log of length 50 by default -- Logging log_action = defaultLogAction, flushOut = defaultFlushOut, flushErr = defaultFlushErr, pprUserLength = 5, pprCols = 100, useUnicode = False, useColor = Auto, canUseColor = False, colScheme = Col.defaultScheme, profAuto = NoProfAuto, interactivePrint = Nothing, nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum", sseVersion = Nothing, bmiVersion = Nothing, avx = False, avx2 = False, avx512cd = False, avx512er = False, avx512f = False, avx512pf = False, rtldInfo = panic "defaultDynFlags: no rtldInfo", rtccInfo = panic "defaultDynFlags: no rtccInfo", maxInlineAllocSize = 128, maxInlineMemcpyInsns = 32, maxInlineMemsetInsns = 32, initialUnique = 0, uniqueIncrement = 1, reverseErrors = False, maxErrors = Nothing, cfgWeightInfo = defaultCfgWeights } defaultWays :: Settings -> [Way] defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings) then [WayDyn] else [] interpWays :: [Way] interpWays | dynamicGhc = [WayDyn] | rtsIsProfiled = [WayProf] | otherwise = [] interpreterProfiled :: DynFlags -> Bool interpreterProfiled dflags | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags | otherwise = rtsIsProfiled interpreterDynamic :: DynFlags -> Bool interpreterDynamic dflags | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags | otherwise = dynamicGhc -------------------------------------------------------------------------- -- -- Note [JSON Error Messages] -- -- When the user requests the compiler output to be dumped as json -- we used to collect them all in an IORef and then print them at the end. -- This doesn't work very well with GHCi. (See #14078) So instead we now -- use the simpler method of just outputting a JSON document inplace to -- stdout. -- -- Before the compiler calls log_action, it has already turned the `ErrMsg` -- into a formatted message. This means that we lose some possible -- information to provide to the user but refactoring log_action is quite -- invasive as it is called in many places. So, for now I left it alone -- and we can refine its behaviour as users request different output. type FatalMessager = String -> IO () type LogAction = DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () defaultFatalMessager :: FatalMessager defaultFatalMessager = hPutStrLn stderr -- See Note [JSON Error Messages] -- jsonLogAction :: LogAction jsonLogAction dflags reason severity srcSpan _style msg = do defaultLogActionHPutStrDoc dflags stdout (doc $$ text "") (mkCodeStyle CStyle) where doc = renderJSON $ JSObject [ ( "span", json srcSpan ) , ( "doc" , JSString (showSDoc dflags msg) ) , ( "severity", json severity ) , ( "reason" , json reason ) ] defaultLogAction :: LogAction defaultLogAction dflags reason severity srcSpan style msg = case severity of SevOutput -> printOut msg style SevDump -> printOut (msg $$ blankLine) style SevInteractive -> putStrSDoc msg style SevInfo -> printErrs msg style SevFatal -> printErrs msg style SevWarning -> printWarns SevError -> printWarns where printOut = defaultLogActionHPrintDoc dflags stdout printErrs = defaultLogActionHPrintDoc dflags stderr putStrSDoc = defaultLogActionHPutStrDoc dflags stdout -- Pretty print the warning flag, if any (#10752) message = mkLocMessageAnn flagMsg severity srcSpan msg printWarns = do hPutChar stderr '\n' caretDiagnostic <- if gopt Opt_DiagnosticsShowCaret dflags then getCaretDiagnostic severity srcSpan else pure empty printErrs (message $+$ caretDiagnostic) (setStyleColoured True style) -- careful (#2302): printErrs prints in UTF-8, -- whereas converting to string first and using -- hPutStr would just emit the low 8 bits of -- each unicode char. flagMsg = case reason of NoReason -> Nothing Reason wflag -> do spec <- flagSpecOf wflag return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag) ErrReason Nothing -> return "-Werror" ErrReason (Just wflag) -> do spec <- flagSpecOf wflag return $ "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++ ", -Werror=" ++ flagSpecName spec warnFlagGrp flag | gopt Opt_ShowWarnGroups dflags = case smallestGroups flag of [] -> "" groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" | otherwise = "" -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () defaultLogActionHPrintDoc dflags h d sty = defaultLogActionHPutStrDoc dflags h (d $$ text "") sty defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () defaultLogActionHPutStrDoc dflags h d sty -- Don't add a newline at the end, so that successive -- calls to this log-action can output all on the same line = printSDoc Pretty.PageMode dflags h sty d newtype FlushOut = FlushOut (IO ()) defaultFlushOut :: FlushOut defaultFlushOut = FlushOut $ hFlush stdout newtype FlushErr = FlushErr (IO ()) defaultFlushErr :: FlushErr defaultFlushErr = FlushErr $ hFlush stderr {- Note [Verbosity levels] ~~~~~~~~~~~~~~~~~~~~~~~ 0 | print errors & warnings only 1 | minimal verbosity: print "compiling M ... done." for each module. 2 | equivalent to -dshow-passes 3 | equivalent to existing "ghc -v" 4 | "ghc -v -ddump-most" 5 | "ghc -v -ddump-all" -} data OnOff a = On a | Off a deriving (Eq, Show) instance Outputable a => Outputable (OnOff a) where ppr (On x) = text "On" <+> ppr x ppr (Off x) = text "Off" <+> ppr x -- OnOffs accumulate in reverse order, so we use foldr in order to -- process them in the right order flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension flattenExtensionFlags ml = foldr f defaultExtensionFlags where f (On f) flags = EnumSet.insert f flags f (Off f) flags = EnumSet.delete f flags defaultExtensionFlags = EnumSet.fromList (languageExtensions ml) -- | The language extensions implied by the various language variants. -- When updating this be sure to update the flag documentation in -- @docs/users-guide/glasgow_exts.rst@. languageExtensions :: Maybe Language -> [LangExt.Extension] languageExtensions Nothing -- Nothing => the default case = LangExt.NondecreasingIndentation -- This has been on by default for some time : delete LangExt.DatatypeContexts -- The Haskell' committee decided to -- remove datatype contexts from the -- language: -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html (languageExtensions (Just Haskell2010)) -- NB: MonoPatBinds is no longer the default languageExtensions (Just Haskell98) = [LangExt.ImplicitPrelude, -- See Note [When is StarIsType enabled] LangExt.StarIsType, LangExt.CUSKs, LangExt.MonomorphismRestriction, LangExt.NPlusKPatterns, LangExt.DatatypeContexts, LangExt.TraditionalRecordSyntax, LangExt.NondecreasingIndentation -- strictly speaking non-standard, but we always had this -- on implicitly before the option was added in 7.1, and -- turning it off breaks code, so we're keeping it on for -- backwards compatibility. Cabal uses -XHaskell98 by -- default unless you specify another language. ] languageExtensions (Just Haskell2010) = [LangExt.ImplicitPrelude, -- See Note [When is StarIsType enabled] LangExt.StarIsType, LangExt.CUSKs, LangExt.MonomorphismRestriction, LangExt.DatatypeContexts, LangExt.TraditionalRecordSyntax, LangExt.EmptyDataDecls, LangExt.ForeignFunctionInterface, LangExt.PatternGuards, LangExt.DoAndIfThenElse, LangExt.RelaxedPolyRec] hasPprDebug :: DynFlags -> Bool hasPprDebug = dopt Opt_D_ppr_debug hasNoDebugOutput :: DynFlags -> Bool hasNoDebugOutput = dopt Opt_D_no_debug_output hasNoStateHack :: DynFlags -> Bool hasNoStateHack = gopt Opt_G_NoStateHack hasNoOptCoercion :: DynFlags -> Bool hasNoOptCoercion = gopt Opt_G_NoOptCoercion -- | Test whether a 'DumpFlag' is set dopt :: DumpFlag -> DynFlags -> Bool dopt f dflags = (f `EnumSet.member` dumpFlags dflags) || (verbosity dflags >= 4 && enableIfVerbose f) where enableIfVerbose Opt_D_dump_tc_trace = False enableIfVerbose Opt_D_dump_rn_trace = False enableIfVerbose Opt_D_dump_cs_trace = False enableIfVerbose Opt_D_dump_if_trace = False enableIfVerbose Opt_D_dump_vt_trace = False enableIfVerbose Opt_D_dump_tc = False enableIfVerbose Opt_D_dump_rn = False enableIfVerbose Opt_D_dump_rn_stats = False enableIfVerbose Opt_D_dump_hi_diffs = False enableIfVerbose Opt_D_verbose_core2core = False enableIfVerbose Opt_D_verbose_stg2stg = False enableIfVerbose Opt_D_dump_splices = False enableIfVerbose Opt_D_th_dec_file = False enableIfVerbose Opt_D_dump_rule_firings = False enableIfVerbose Opt_D_dump_rule_rewrites = False enableIfVerbose Opt_D_dump_simpl_trace = False enableIfVerbose Opt_D_dump_rtti = False enableIfVerbose Opt_D_dump_inlinings = False enableIfVerbose Opt_D_dump_core_stats = False enableIfVerbose Opt_D_dump_asm_stats = False enableIfVerbose Opt_D_dump_types = False enableIfVerbose Opt_D_dump_simpl_iterations = False enableIfVerbose Opt_D_dump_ticked = False enableIfVerbose Opt_D_dump_view_pattern_commoning = False enableIfVerbose Opt_D_dump_mod_cycles = False enableIfVerbose Opt_D_dump_mod_map = False enableIfVerbose Opt_D_dump_ec_trace = False enableIfVerbose _ = True -- | Set a 'DumpFlag' dopt_set :: DynFlags -> DumpFlag -> DynFlags dopt_set dfs f = dfs{ dumpFlags = EnumSet.insert f (dumpFlags dfs) } -- | Unset a 'DumpFlag' dopt_unset :: DynFlags -> DumpFlag -> DynFlags dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) } -- | Test whether a 'GeneralFlag' is set gopt :: GeneralFlag -> DynFlags -> Bool gopt f dflags = f `EnumSet.member` generalFlags dflags -- | Set a 'GeneralFlag' gopt_set :: DynFlags -> GeneralFlag -> DynFlags gopt_set dfs f = dfs{ generalFlags = EnumSet.insert f (generalFlags dfs) } -- | Unset a 'GeneralFlag' gopt_unset :: DynFlags -> GeneralFlag -> DynFlags gopt_unset dfs f = dfs{ generalFlags = EnumSet.delete f (generalFlags dfs) } -- | Test whether a 'WarningFlag' is set wopt :: WarningFlag -> DynFlags -> Bool wopt f dflags = f `EnumSet.member` warningFlags dflags -- | Set a 'WarningFlag' wopt_set :: DynFlags -> WarningFlag -> DynFlags wopt_set dfs f = dfs{ warningFlags = EnumSet.insert f (warningFlags dfs) } -- | Unset a 'WarningFlag' wopt_unset :: DynFlags -> WarningFlag -> DynFlags wopt_unset dfs f = dfs{ warningFlags = EnumSet.delete f (warningFlags dfs) } -- | Test whether a 'WarningFlag' is set as fatal wopt_fatal :: WarningFlag -> DynFlags -> Bool wopt_fatal f dflags = f `EnumSet.member` fatalWarningFlags dflags -- | Mark a 'WarningFlag' as fatal (do not set the flag) wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags wopt_set_fatal dfs f = dfs { fatalWarningFlags = EnumSet.insert f (fatalWarningFlags dfs) } -- | Mark a 'WarningFlag' as not fatal wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags wopt_unset_fatal dfs f = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } -- | Test whether a 'LangExt.Extension' is set xopt :: LangExt.Extension -> DynFlags -> Bool xopt f dflags = f `EnumSet.member` extensionFlags dflags -- | Set a 'LangExt.Extension' xopt_set :: DynFlags -> LangExt.Extension -> DynFlags xopt_set dfs f = let onoffs = On f : extensions dfs in dfs { extensions = onoffs, extensionFlags = flattenExtensionFlags (language dfs) onoffs } -- | Unset a 'LangExt.Extension' xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags xopt_unset dfs f = let onoffs = Off f : extensions dfs in dfs { extensions = onoffs, extensionFlags = flattenExtensionFlags (language dfs) onoffs } -- | Set or unset a 'LangExt.Extension', unless it has been explicitly -- set or unset before. xopt_set_unlessExplSpec :: LangExt.Extension -> (DynFlags -> LangExt.Extension -> DynFlags) -> DynFlags -> DynFlags xopt_set_unlessExplSpec ext setUnset dflags = let referedExts = stripOnOff <$> extensions dflags stripOnOff (On x) = x stripOnOff (Off x) = x in if ext `elem` referedExts then dflags else setUnset dflags ext lang_set :: DynFlags -> Maybe Language -> DynFlags lang_set dflags lang = dflags { language = lang, extensionFlags = flattenExtensionFlags lang (extensions dflags) } -- | An internal helper to check whether to use unicode syntax for output. -- -- Note: You should very likely be using 'Outputable.unicodeSyntax' instead -- of this function. useUnicodeSyntax :: DynFlags -> Bool useUnicodeSyntax = gopt Opt_PrintUnicodeSyntax useStarIsType :: DynFlags -> Bool useStarIsType = xopt LangExt.StarIsType -- | Set the Haskell language standard to use setLanguage :: Language -> DynP () setLanguage l = upd (`lang_set` Just l) -- | Some modules have dependencies on others through the DynFlags rather than textual imports dynFlagDependencies :: DynFlags -> [ModuleName] dynFlagDependencies = pluginModNames -- | Is the -fpackage-trust mode on packageTrustOn :: DynFlags -> Bool packageTrustOn = gopt Opt_PackageTrust -- | Is Safe Haskell on in some way (including inference mode) safeHaskellOn :: DynFlags -> Bool safeHaskellOn dflags = safeHaskellModeEnabled dflags || safeInferOn dflags safeHaskellModeEnabled :: DynFlags -> Bool safeHaskellModeEnabled dflags = safeHaskell dflags `elem` [Sf_Unsafe, Sf_Trustworthy , Sf_Safe ] -- | Is the Safe Haskell safe language in use safeLanguageOn :: DynFlags -> Bool safeLanguageOn dflags = safeHaskell dflags == Sf_Safe -- | Is the Safe Haskell safe inference mode active safeInferOn :: DynFlags -> Bool safeInferOn = safeInfer -- | Test if Safe Imports are on in some form safeImportsOn :: DynFlags -> Bool safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe || safeHaskell dflags == Sf_Trustworthy || safeHaskell dflags == Sf_Safe -- | Set a 'Safe Haskell' flag setSafeHaskell :: SafeHaskellMode -> DynP () setSafeHaskell s = updM f where f dfs = do let sf = safeHaskell dfs safeM <- combineSafeFlags sf s case s of Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False } -- leave safe inferrence on in Trustworthy mode so we can warn -- if it could have been inferred safe. Sf_Trustworthy -> do l <- getCurLoc return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l } -- leave safe inference on in Unsafe mode as well. _ -> return $ dfs { safeHaskell = safeM } -- | Are all direct imports required to be safe for this Safe Haskell mode? -- Direct imports are when the code explicitly imports a module safeDirectImpsReq :: DynFlags -> Bool safeDirectImpsReq d = safeLanguageOn d -- | Are all implicit imports required to be safe for this Safe Haskell mode? -- Implicit imports are things in the prelude. e.g System.IO when print is used. safeImplicitImpsReq :: DynFlags -> Bool safeImplicitImpsReq d = safeLanguageOn d -- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags. -- This makes Safe Haskell very much a monoid but for now I prefer this as I don't -- want to export this functionality from the module but do want to export the -- type constructors. combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode combineSafeFlags a b | a == Sf_None = return b | b == Sf_None = return a | a == Sf_Ignore || b == Sf_Ignore = return Sf_Ignore | a == b = return a | otherwise = addErr errm >> pure a where errm = "Incompatible Safe Haskell flags! (" ++ show a ++ ", " ++ show b ++ ")" -- | A list of unsafe flags under Safe Haskell. Tuple elements are: -- * name of the flag -- * function to get srcspan that enabled the flag -- * function to test if the flag is on -- * function to turn the flag off unsafeFlags, unsafeFlagsForInfer :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc, xopt LangExt.GeneralizedNewtypeDeriving, flip xopt_unset LangExt.GeneralizedNewtypeDeriving) , ("-XTemplateHaskell", thOnLoc, xopt LangExt.TemplateHaskell, flip xopt_unset LangExt.TemplateHaskell) ] unsafeFlagsForInfer = unsafeFlags -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from -> (DynFlags -> [a]) -- ^ Relevant record accessor: one of the @opt_*@ accessors -> [a] -- ^ Correctly ordered extracted options getOpts dflags opts = reverse (opts dflags) -- We add to the options from the front, so we need to reverse the list -- | Gets the verbosity flag for the current verbosity level. This is fed to -- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included getVerbFlags :: DynFlags -> [String] getVerbFlags dflags | verbosity dflags >= 4 = ["-v"] | otherwise = [] setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir, setDynObjectSuf, setDynHiSuf, setDylibInstallName, setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode, setPgmP, addOptl, addOptc, addOptcxx, addOptP, addCmdlineFramework, addHaddockOpts, addGhciScript, setInteractivePrint :: String -> DynFlags -> DynFlags setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce :: Maybe String -> DynFlags -> DynFlags setObjectDir f d = d { objectDir = Just f} setHiDir f d = d { hiDir = Just f} setHieDir f d = d { hieDir = Just f} setStubDir f d = d { stubDir = Just f , includePaths = addGlobalInclude (includePaths d) [f] } -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file -- \#included from the .hc file when compiling via C (i.e. unregisterised -- builds). setDumpDir f d = d { dumpDir = Just f} setOutputDir f = setObjectDir f . setHieDir f . setHiDir f . setStubDir f . setDumpDir f setDylibInstallName f d = d { dylibInstallName = Just f} setObjectSuf f d = d { objectSuf = f} setDynObjectSuf f d = d { dynObjectSuf = f} setHiSuf f d = d { hiSuf = f} setHieSuf f d = d { hieSuf = f} setDynHiSuf f d = d { dynHiSuf = f} setHcSuf f d = d { hcSuf = f} setOutputFile f d = d { outputFile = f} setDynOutputFile f d = d { dynOutputFile = f} setOutputHi f d = d { outputHi = f} setJsonLogAction :: DynFlags -> DynFlags setJsonLogAction d = d { log_action = jsonLogAction } thisComponentId :: DynFlags -> ComponentId thisComponentId dflags = case thisComponentId_ dflags of Just cid -> cid Nothing -> case thisUnitIdInsts_ dflags of Just _ -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") Nothing -> ComponentId (unitIdFS (thisPackage dflags)) thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)] thisUnitIdInsts dflags = case thisUnitIdInsts_ dflags of Just insts -> insts Nothing -> [] thisPackage :: DynFlags -> UnitId thisPackage dflags = case thisUnitIdInsts_ dflags of Nothing -> default_uid Just insts | all (\(x,y) -> mkHoleModule x == y) insts -> newUnitId (thisComponentId dflags) insts | otherwise -> default_uid where default_uid = DefiniteUnitId (DefUnitId (thisInstalledUnitId dflags)) parseUnitIdInsts :: String -> [(ModuleName, Module)] parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of [(r, "")] -> r _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str) where parse = sepBy parseEntry (R.char ',') parseEntry = do n <- parseModuleName _ <- R.char '=' m <- parseModuleId return (n, m) setUnitIdInsts :: String -> DynFlags -> DynFlags setUnitIdInsts s d = d { thisUnitIdInsts_ = Just (parseUnitIdInsts s) } setComponentId :: String -> DynFlags -> DynFlags setComponentId s d = d { thisComponentId_ = Just (ComponentId (fsLit s)) } addPluginModuleName :: String -> DynFlags -> DynFlags addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } clearPluginModuleNames :: DynFlags -> DynFlags clearPluginModuleNames d = d { pluginModNames = [] , pluginModNameOpts = [] , cachedPlugins = [] } addPluginModuleNameOption :: String -> DynFlags -> DynFlags addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) } where (m, rest) = break (== ':') optflag option = case rest of [] -> "" -- should probably signal an error (_:plug_opt) -> plug_opt -- ignore the ':' from break addFrontendPluginOption :: String -> DynFlags -> DynFlags addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d } parseDynLibLoaderMode f d = case splitAt 8 f of ("deploy", "") -> d { dynLibLoader = Deployable } ("sysdep", "") -> d { dynLibLoader = SystemDependent } _ -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f)) setDumpPrefixForce f d = d { dumpPrefixForce = f} -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] -- Config.hs should really use Option. setPgmP f = alterToolSettings (\s -> s { toolSettings_pgm_P = (pgm, map Option args)}) where (pgm:args) = words f addOptl f = alterToolSettings (\s -> s { toolSettings_opt_l = f : toolSettings_opt_l s}) addOptc f = alterToolSettings (\s -> s { toolSettings_opt_c = f : toolSettings_opt_c s}) addOptcxx f = alterToolSettings (\s -> s { toolSettings_opt_cxx = f : toolSettings_opt_cxx s}) addOptP f = alterToolSettings $ \s -> s { toolSettings_opt_P = f : toolSettings_opt_P s , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) } -- See Note [Repeated -optP hashing] where fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss setDepMakefile :: FilePath -> DynFlags -> DynFlags setDepMakefile f d = d { depMakefile = f } setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags setDepIncludeCppDeps b d = d { depIncludeCppDeps = b } setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags setDepIncludePkgDeps b d = d { depIncludePkgDeps = b } addDepExcludeMod :: String -> DynFlags -> DynFlags addDepExcludeMod m d = d { depExcludeMods = mkModuleName m : depExcludeMods d } addDepSuffix :: FilePath -> DynFlags -> DynFlags addDepSuffix s d = d { depSuffixes = s : depSuffixes d } addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d} addGhcVersionFile :: FilePath -> DynFlags -> DynFlags addGhcVersionFile f d = d { ghcVersionFile = Just f } addHaddockOpts f d = d { haddockOptions = Just f} addGhciScript f d = d { ghciScripts = f : ghciScripts d} setInteractivePrint f d = d { interactivePrint = Just f} ----------------------------------------------------------------------------- -- Setting the optimisation level updOptLevel :: Int -> DynFlags -> DynFlags -- ^ Sets the 'DynFlags' to be appropriate to the optimisation level updOptLevel n dfs = dfs2{ optLevel = final_n } where final_n = max 0 (min 2 n) -- Clamp to 0 <= n <= 2 dfs1 = foldr (flip gopt_unset) dfs remove_gopts dfs2 = foldr (flip gopt_set) dfs1 extra_gopts extra_gopts = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ] remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ] {- ********************************************************************** %* * DynFlags parser %* * %********************************************************************* -} -- ----------------------------------------------------------------------------- -- Parsing the dynamic flags. -- | Parse dynamic flags from a list of command line arguments. Returns -- the parsed 'DynFlags', the left-over arguments, and a list of warnings. -- Throws a 'UsageError' if errors occurred during parsing (such as unknown -- flags or missing arguments). parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String] -> m (DynFlags, [Located String], [Warn]) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True -- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags -- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db). -- Used to parse flags set in a modules pragma. parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String] -> m (DynFlags, [Located String], [Warn]) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False -- | Parses the dynamically set flags for GHC. This is the most general form of -- the dynamic flag parser that the other methods simply wrap. It allows -- saying which flags are valid flags and indicating if we are parsing -- arguments from the command line or from a file pragma. parseDynamicFlagsFull :: MonadIO m => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against -> Bool -- ^ are the arguments from the command line? -> DynFlags -- ^ current dynamic flags -> [Located String] -- ^ arguments to parse -> m (DynFlags, [Located String], [Warn]) parseDynamicFlagsFull activeFlags cmdline dflags0 args = do let ((leftover, errs, warns), dflags1) = runCmdLine (processArgs activeFlags args) dflags0 -- See Note [Handling errors when parsing commandline flags] unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $ map ((showPpr dflags0 . getLoc &&& unLoc) . errMsg) $ errs -- check for disabled flags in safe haskell let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 dflags3 = updateWays dflags2 theWays = ways dflags3 unless (allowed_combination theWays) $ liftIO $ throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ intercalate "/" (map wayDesc theWays))) let chooseOutput | isJust (outputFile dflags3) -- Only iff user specified -o ... , not (isJust (dynOutputFile dflags3)) -- but not -dyno = return $ dflags3 { dynOutputFile = Just $ dynamicOutputFile dflags3 outFile } | otherwise = return dflags3 where outFile = fromJust $ outputFile dflags3 dflags4 <- ifGeneratingDynamicToo dflags3 chooseOutput (return dflags3) let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4 -- Set timer stats & heap size when (enableTimeStats dflags5) $ liftIO enableTimingStats case (ghcHeapSize dflags5) of Just x -> liftIO (setHeapSize x) _ -> return () liftIO $ setUnsafeGlobalDynFlags dflags5 let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns) return (dflags5, leftover, warns' ++ warns) -- | Write an error or warning to the 'LogOutput'. putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () putLogMsg dflags = log_action dflags dflags updateWays :: DynFlags -> DynFlags updateWays dflags = let theWays = sort $ nub $ ways dflags in dflags { ways = theWays, buildTag = mkBuildTag (filter (not . wayRTSOnly) theWays) } -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode. -- -- The bool is to indicate if we are parsing command line flags (false means -- file pragma). This allows us to generate better warnings. safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns) where -- Handle illegal flags under safe language. (dflagsUnset, warns) = foldl' check_method (dflags, []) unsafeFlags check_method (df, warns) (str,loc,test,fix) | test df = (fix df, warns ++ safeFailure (loc df) str) | otherwise = (df, warns) safeFailure loc str = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " ++ str] safeFlagCheck cmdl dflags = case (safeInferOn dflags) of True | safeFlags -> (dflags', warn) True -> (dflags' { safeInferred = False }, warn) False -> (dflags', warn) where -- dynflags and warn for when -fpackage-trust by itself with no safe -- haskell flag (dflags', warn) | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg) | otherwise = (dflags, []) pkgWarnMsg = [L (pkgTrustOnLoc dflags') $ "-fpackage-trust ignored;" ++ " must be specified with a Safe Haskell flag"] -- Have we inferred Unsafe? See Note [HscMain . Safe Haskell Inference] safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer {- ********************************************************************** %* * DynFlags specifications %* * %********************************************************************* -} -- | All dynamic flags option strings without the deprecated ones. -- These are the user facing strings for enabling and disabling options. allNonDeprecatedFlags :: [String] allNonDeprecatedFlags = allFlagsDeps False -- | All flags with possibility to filter deprecated ones allFlagsDeps :: Bool -> [String] allFlagsDeps keepDeprecated = [ '-':flagName flag | (deprecated, flag) <- flagsAllDeps , keepDeprecated || not (isDeprecated deprecated)] where isDeprecated Deprecated = True isDeprecated _ = False {- - Below we export user facing symbols for GHC dynamic flags for use with the - GHC API. -} -- All dynamic flags present in GHC. flagsAll :: [Flag (CmdLineP DynFlags)] flagsAll = map snd flagsAllDeps -- All dynamic flags present in GHC with deprecation information. flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))] flagsAllDeps = package_flags_deps ++ dynamic_flags_deps -- All dynamic flags, minus package flags, present in GHC. flagsDynamic :: [Flag (CmdLineP DynFlags)] flagsDynamic = map snd dynamic_flags_deps -- ALl package flags present in GHC. flagsPackage :: [Flag (CmdLineP DynFlags)] flagsPackage = map snd package_flags_deps ----------------Helpers to make flags and keep deprecation information---------- type FlagMaker m = String -> OptKind m -> Flag m type DynFlagMaker = FlagMaker (CmdLineP DynFlags) data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord) -- Make a non-deprecated flag make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> (Deprecation, Flag (CmdLineP DynFlags)) make_ord_flag fm name kind = (NotDeprecated, fm name kind) -- Make a deprecated flag make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String -> (Deprecation, Flag (CmdLineP DynFlags)) make_dep_flag fm name kind message = (Deprecated, fm name $ add_dep_message kind message) add_dep_message :: OptKind (CmdLineP DynFlags) -> String -> OptKind (CmdLineP DynFlags) add_dep_message (NoArg f) message = NoArg $ f >> deprecate message add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message add_dep_message (OptPrefix f) message = OptPrefix $ \s -> f s >> deprecate message add_dep_message (OptIntSuffix f) message = OptIntSuffix $ \oi -> f oi >> deprecate message add_dep_message (IntSuffix f) message = IntSuffix $ \i -> f i >> deprecate message add_dep_message (FloatSuffix f) message = FloatSuffix $ \fl -> f fl >> deprecate message add_dep_message (PassFlag f) message = PassFlag $ \s -> f s >> deprecate message add_dep_message (AnySuffix f) message = AnySuffix $ \s -> f s >> deprecate message ----------------------- The main flags themselves ------------------------------ -- See Note [Updating flag description in the User's Guide] -- See Note [Supporting CLI completion] dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] dynamic_flags_deps = [ make_dep_flag defFlag "n" (NoArg $ return ()) "The -n flag is deprecated and no longer has any effect" , make_ord_flag defFlag "cpp" (NoArg (setExtensionFlag LangExt.Cpp)) , make_ord_flag defFlag "F" (NoArg (setGeneralFlag Opt_Pp)) , (Deprecated, defFlag "#include" (HasArg (\_s -> deprecate ("-#include and INCLUDE pragmas are " ++ "deprecated: They no longer have any effect")))) , make_ord_flag defFlag "v" (OptIntSuffix setVerbosity) , make_ord_flag defGhcFlag "j" (OptIntSuffix (\n -> case n of Just n | n > 0 -> upd (\d -> d { parMakeCount = Just n }) | otherwise -> addErr "Syntax: -j[n] where n > 0" Nothing -> upd (\d -> d { parMakeCount = Nothing }))) -- When the number of parallel builds -- is omitted, it is the same -- as specifing that the number of -- parallel builds is equal to the -- result of getNumProcessors , make_ord_flag defFlag "instantiated-with" (sepArg setUnitIdInsts) , make_ord_flag defFlag "this-component-id" (sepArg setComponentId) -- RTS options ------------------------------------------------------------- , make_ord_flag defFlag "H" (HasArg (\s -> upd (\d -> d { ghcHeapSize = Just $ fromIntegral (decodeSize s)}))) , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d -> d { enableTimeStats = True }))) ------- ways --------------------------------------------------------------- , make_ord_flag defGhcFlag "prof" (NoArg (addWay WayProf)) , make_ord_flag defGhcFlag "eventlog" (NoArg (addWay WayEventLog)) , make_dep_flag defGhcFlag "smp" (NoArg $ addWay WayThreaded) "Use -threaded instead" , make_ord_flag defGhcFlag "debug" (NoArg (addWay WayDebug)) , make_ord_flag defGhcFlag "threaded" (NoArg (addWay WayThreaded)) , make_ord_flag defGhcFlag "ticky" (NoArg (setGeneralFlag Opt_Ticky >> addWay WayDebug)) -- -ticky enables ticky-ticky code generation, and also implies -debug which -- is required to get the RTS ticky support. ----- Linker -------------------------------------------------------- , make_ord_flag defGhcFlag "static" (NoArg removeWayDyn) , make_ord_flag defGhcFlag "dynamic" (NoArg (addWay WayDyn)) , make_ord_flag defGhcFlag "rdynamic" $ noArg $ #if defined(linux_HOST_OS) addOptl "-rdynamic" #elif defined(mingw32_HOST_OS) addOptl "-Wl,--export-all-symbols" #else -- ignored for compat w/ gcc: id #endif , make_ord_flag defGhcFlag "relative-dynlib-paths" (NoArg (setGeneralFlag Opt_RelativeDynlibPaths)) , make_ord_flag defGhcFlag "copy-libs-when-linking" (NoArg (setGeneralFlag Opt_SingleLibFolder)) , make_ord_flag defGhcFlag "pie" (NoArg (setGeneralFlag Opt_PICExecutable)) , make_ord_flag defGhcFlag "no-pie" (NoArg (unSetGeneralFlag Opt_PICExecutable)) ------- Specific phases -------------------------------------------- -- need to appear before -pgmL to be parsed as LLVM flags. , make_ord_flag defFlag "pgmlo" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lo = (f,[]) } , make_ord_flag defFlag "pgmlc" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc = (f,[]) } , make_ord_flag defFlag "pgmi" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_i = f } , make_ord_flag defFlag "pgmL" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_L = f } , make_ord_flag defFlag "pgmP" (hasArg setPgmP) , make_ord_flag defFlag "pgmF" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_F = f } , make_ord_flag defFlag "pgmc" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_c = f , -- Don't pass -no-pie with -pgmc -- (see #15319) toolSettings_ccSupportsNoPie = False } , make_ord_flag defFlag "pgms" (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8")) , make_ord_flag defFlag "pgma" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_a = (f,[]) } , make_ord_flag defFlag "pgml" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_l = (f,[]) } , make_ord_flag defFlag "pgmdll" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_dll = (f,[]) } , make_ord_flag defFlag "pgmwindres" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f } , make_ord_flag defFlag "pgmlibtool" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_libtool = f } , make_ord_flag defFlag "pgmar" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f } , make_ord_flag defFlag "pgmranlib" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ranlib = f } -- need to appear before -optl/-opta to be parsed as LLVM flags. , make_ord_flag defFlag "optlo" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lo = f : toolSettings_opt_lo s } , make_ord_flag defFlag "optlc" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lc = f : toolSettings_opt_lc s } , make_ord_flag defFlag "opti" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_i = f : toolSettings_opt_i s } , make_ord_flag defFlag "optL" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_L = f : toolSettings_opt_L s } , make_ord_flag defFlag "optP" (hasArg addOptP) , make_ord_flag defFlag "optF" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_F = f : toolSettings_opt_F s } , make_ord_flag defFlag "optc" (hasArg addOptc) , make_ord_flag defFlag "optcxx" (hasArg addOptcxx) , make_ord_flag defFlag "opta" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_a = f : toolSettings_opt_a s } , make_ord_flag defFlag "optl" (hasArg addOptl) , make_ord_flag defFlag "optwindres" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_windres = f : toolSettings_opt_windres s } , make_ord_flag defGhcFlag "split-objs" (NoArg $ addWarn "ignoring -split-objs") , make_ord_flag defGhcFlag "split-sections" (noArgM (\dflags -> do if platformHasSubsectionsViaSymbols (targetPlatform dflags) then do addWarn $ "-split-sections is not useful on this platform " ++ "since it always uses subsections via symbols. Ignoring." return dflags else return (gopt_set dflags Opt_SplitSections))) -------- ghc -M ----------------------------------------------------- , make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix) , make_ord_flag defGhcFlag "dep-makefile" (hasArg setDepMakefile) , make_ord_flag defGhcFlag "include-cpp-deps" (noArg (setDepIncludeCppDeps True)) , make_ord_flag defGhcFlag "include-pkg-deps" (noArg (setDepIncludePkgDeps True)) , make_ord_flag defGhcFlag "exclude-module" (hasArg addDepExcludeMod) -------- Linking ---------------------------------------------------- , make_ord_flag defGhcFlag "no-link" (noArg (\d -> d { ghcLink=NoLink })) , make_ord_flag defGhcFlag "shared" (noArg (\d -> d { ghcLink=LinkDynLib })) , make_ord_flag defGhcFlag "staticlib" (noArg (\d -> d { ghcLink=LinkStaticLib })) , make_ord_flag defGhcFlag "dynload" (hasArg parseDynLibLoaderMode) , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName) ------- Libraries --------------------------------------------------- , make_ord_flag defFlag "L" (Prefix addLibraryPath) , make_ord_flag defFlag "l" (hasArg (addLdInputs . Option . ("-l" ++))) ------- Frameworks -------------------------------------------------- -- -framework-path should really be -F ... , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath) , make_ord_flag defFlag "framework" (hasArg addCmdlineFramework) ------- Output Redirection ------------------------------------------ , make_ord_flag defGhcFlag "odir" (hasArg setObjectDir) , make_ord_flag defGhcFlag "o" (sepArg (setOutputFile . Just)) , make_ord_flag defGhcFlag "dyno" (sepArg (setDynOutputFile . Just)) , make_ord_flag defGhcFlag "ohi" (hasArg (setOutputHi . Just )) , make_ord_flag defGhcFlag "osuf" (hasArg setObjectSuf) , make_ord_flag defGhcFlag "dynosuf" (hasArg setDynObjectSuf) , make_ord_flag defGhcFlag "hcsuf" (hasArg setHcSuf) , make_ord_flag defGhcFlag "hisuf" (hasArg setHiSuf) , make_ord_flag defGhcFlag "hiesuf" (hasArg setHieSuf) , make_ord_flag defGhcFlag "dynhisuf" (hasArg setDynHiSuf) , make_ord_flag defGhcFlag "hidir" (hasArg setHiDir) , make_ord_flag defGhcFlag "hiedir" (hasArg setHieDir) , make_ord_flag defGhcFlag "tmpdir" (hasArg setTmpDir) , make_ord_flag defGhcFlag "stubdir" (hasArg setStubDir) , make_ord_flag defGhcFlag "dumpdir" (hasArg setDumpDir) , make_ord_flag defGhcFlag "outputdir" (hasArg setOutputDir) , make_ord_flag defGhcFlag "ddump-file-prefix" (hasArg (setDumpPrefixForce . Just)) , make_ord_flag defGhcFlag "dynamic-too" (NoArg (setGeneralFlag Opt_BuildDynamicToo)) ------- Keeping temporary files ------------------------------------- -- These can be singular (think ghc -c) or plural (think ghc --make) , make_ord_flag defGhcFlag "keep-hc-file" (NoArg (setGeneralFlag Opt_KeepHcFiles)) , make_ord_flag defGhcFlag "keep-hc-files" (NoArg (setGeneralFlag Opt_KeepHcFiles)) , make_ord_flag defGhcFlag "keep-hscpp-file" (NoArg (setGeneralFlag Opt_KeepHscppFiles)) , make_ord_flag defGhcFlag "keep-hscpp-files" (NoArg (setGeneralFlag Opt_KeepHscppFiles)) , make_ord_flag defGhcFlag "keep-s-file" (NoArg (setGeneralFlag Opt_KeepSFiles)) , make_ord_flag defGhcFlag "keep-s-files" (NoArg (setGeneralFlag Opt_KeepSFiles)) , make_ord_flag defGhcFlag "keep-llvm-file" (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles) , make_ord_flag defGhcFlag "keep-llvm-files" (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles) -- This only makes sense as plural , make_ord_flag defGhcFlag "keep-tmp-files" (NoArg (setGeneralFlag Opt_KeepTmpFiles)) , make_ord_flag defGhcFlag "keep-hi-file" (NoArg (setGeneralFlag Opt_KeepHiFiles)) , make_ord_flag defGhcFlag "no-keep-hi-file" (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) , make_ord_flag defGhcFlag "keep-hi-files" (NoArg (setGeneralFlag Opt_KeepHiFiles)) , make_ord_flag defGhcFlag "no-keep-hi-files" (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) , make_ord_flag defGhcFlag "keep-o-file" (NoArg (setGeneralFlag Opt_KeepOFiles)) , make_ord_flag defGhcFlag "no-keep-o-file" (NoArg (unSetGeneralFlag Opt_KeepOFiles)) , make_ord_flag defGhcFlag "keep-o-files" (NoArg (setGeneralFlag Opt_KeepOFiles)) , make_ord_flag defGhcFlag "no-keep-o-files" (NoArg (unSetGeneralFlag Opt_KeepOFiles)) ------- Miscellaneous ---------------------------------------------- , make_ord_flag defGhcFlag "no-auto-link-packages" (NoArg (unSetGeneralFlag Opt_AutoLinkPackages)) , make_ord_flag defGhcFlag "no-hs-main" (NoArg (setGeneralFlag Opt_NoHsMain)) , make_ord_flag defGhcFlag "fno-state-hack" (NoArg (setGeneralFlag Opt_G_NoStateHack)) , make_ord_flag defGhcFlag "fno-opt-coercion" (NoArg (setGeneralFlag Opt_G_NoOptCoercion)) , make_ord_flag defGhcFlag "with-rtsopts" (HasArg setRtsOpts) , make_ord_flag defGhcFlag "rtsopts" (NoArg (setRtsOptsEnabled RtsOptsAll)) , make_ord_flag defGhcFlag "rtsopts=all" (NoArg (setRtsOptsEnabled RtsOptsAll)) , make_ord_flag defGhcFlag "rtsopts=some" (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) , make_ord_flag defGhcFlag "rtsopts=none" (NoArg (setRtsOptsEnabled RtsOptsNone)) , make_ord_flag defGhcFlag "rtsopts=ignore" (NoArg (setRtsOptsEnabled RtsOptsIgnore)) , make_ord_flag defGhcFlag "rtsopts=ignoreAll" (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll)) , make_ord_flag defGhcFlag "no-rtsopts" (NoArg (setRtsOptsEnabled RtsOptsNone)) , make_ord_flag defGhcFlag "no-rtsopts-suggestions" (noArg (\d -> d {rtsOptsSuggestions = False})) , make_ord_flag defGhcFlag "dhex-word-literals" (NoArg (setGeneralFlag Opt_HexWordLiterals)) , make_ord_flag defGhcFlag "ghcversion-file" (hasArg addGhcVersionFile) , make_ord_flag defGhcFlag "main-is" (SepArg setMainIs) , make_ord_flag defGhcFlag "haddock" (NoArg (setGeneralFlag Opt_Haddock)) , make_ord_flag defGhcFlag "haddock-opts" (hasArg addHaddockOpts) , make_ord_flag defGhcFlag "hpcdir" (SepArg setOptHpcDir) , make_ord_flag defGhciFlag "ghci-script" (hasArg addGhciScript) , make_ord_flag defGhciFlag "interactive-print" (hasArg setInteractivePrint) , make_ord_flag defGhcFlag "ticky-allocd" (NoArg (setGeneralFlag Opt_Ticky_Allocd)) , make_ord_flag defGhcFlag "ticky-LNE" (NoArg (setGeneralFlag Opt_Ticky_LNE)) , make_ord_flag defGhcFlag "ticky-dyn-thunk" (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk)) ------- recompilation checker -------------------------------------- , make_dep_flag defGhcFlag "recomp" (NoArg $ unSetGeneralFlag Opt_ForceRecomp) "Use -fno-force-recomp instead" , make_dep_flag defGhcFlag "no-recomp" (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead" , make_ord_flag defFlag "fmax-errors" (intSuffix (\n d -> d { maxErrors = Just (max 1 n) })) , make_ord_flag defFlag "fno-max-errors" (noArg (\d -> d { maxErrors = Nothing })) , make_ord_flag defFlag "freverse-errors" (noArg (\d -> d {reverseErrors = True} )) , make_ord_flag defFlag "fno-reverse-errors" (noArg (\d -> d {reverseErrors = False} )) ------ HsCpp opts --------------------------------------------------- , make_ord_flag defFlag "D" (AnySuffix (upd . addOptP)) , make_ord_flag defFlag "U" (AnySuffix (upd . addOptP)) ------- Include/Import Paths ---------------------------------------- , make_ord_flag defFlag "I" (Prefix addIncludePath) , make_ord_flag defFlag "i" (OptPrefix addImportPath) ------ Output style options ----------------------------------------- , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d -> d { pprUserLength = n })) , make_ord_flag defFlag "dppr-cols" (intSuffix (\n d -> d { pprCols = n })) , make_ord_flag defFlag "fdiagnostics-color=auto" (NoArg (upd (\d -> d { useColor = Auto }))) , make_ord_flag defFlag "fdiagnostics-color=always" (NoArg (upd (\d -> d { useColor = Always }))) , make_ord_flag defFlag "fdiagnostics-color=never" (NoArg (upd (\d -> d { useColor = Never }))) -- Suppress all that is suppressable in core dumps. -- Except for uniques, as some simplifier phases introduce new variables that -- have otherwise identical names. , make_ord_flag defGhcFlag "dsuppress-all" (NoArg $ do setGeneralFlag Opt_SuppressCoercions setGeneralFlag Opt_SuppressVarKinds setGeneralFlag Opt_SuppressModulePrefixes setGeneralFlag Opt_SuppressTypeApplications setGeneralFlag Opt_SuppressIdInfo setGeneralFlag Opt_SuppressTicks setGeneralFlag Opt_SuppressStgExts setGeneralFlag Opt_SuppressTypeSignatures setGeneralFlag Opt_SuppressTimestamps) ------ Debugging ---------------------------------------------------- , make_ord_flag defGhcFlag "dstg-stats" (NoArg (setGeneralFlag Opt_StgStats)) , make_ord_flag defGhcFlag "ddump-cmm" (setDumpFlag Opt_D_dump_cmm) , make_ord_flag defGhcFlag "ddump-cmm-from-stg" (setDumpFlag Opt_D_dump_cmm_from_stg) , make_ord_flag defGhcFlag "ddump-cmm-raw" (setDumpFlag Opt_D_dump_cmm_raw) , make_ord_flag defGhcFlag "ddump-cmm-verbose" (setDumpFlag Opt_D_dump_cmm_verbose) , make_ord_flag defGhcFlag "ddump-cmm-verbose-by-proc" (setDumpFlag Opt_D_dump_cmm_verbose_by_proc) , make_ord_flag defGhcFlag "ddump-cmm-cfg" (setDumpFlag Opt_D_dump_cmm_cfg) , make_ord_flag defGhcFlag "ddump-cmm-cbe" (setDumpFlag Opt_D_dump_cmm_cbe) , make_ord_flag defGhcFlag "ddump-cmm-switch" (setDumpFlag Opt_D_dump_cmm_switch) , make_ord_flag defGhcFlag "ddump-cmm-proc" (setDumpFlag Opt_D_dump_cmm_proc) , make_ord_flag defGhcFlag "ddump-cmm-sp" (setDumpFlag Opt_D_dump_cmm_sp) , make_ord_flag defGhcFlag "ddump-cmm-sink" (setDumpFlag Opt_D_dump_cmm_sink) , make_ord_flag defGhcFlag "ddump-cmm-caf" (setDumpFlag Opt_D_dump_cmm_caf) , make_ord_flag defGhcFlag "ddump-cmm-procmap" (setDumpFlag Opt_D_dump_cmm_procmap) , make_ord_flag defGhcFlag "ddump-cmm-split" (setDumpFlag Opt_D_dump_cmm_split) , make_ord_flag defGhcFlag "ddump-cmm-info" (setDumpFlag Opt_D_dump_cmm_info) , make_ord_flag defGhcFlag "ddump-cmm-cps" (setDumpFlag Opt_D_dump_cmm_cps) , make_ord_flag defGhcFlag "ddump-cfg-weights" (setDumpFlag Opt_D_dump_cfg_weights) , make_ord_flag defGhcFlag "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats) , make_ord_flag defGhcFlag "ddump-asm" (setDumpFlag Opt_D_dump_asm) , make_ord_flag defGhcFlag "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native) , make_ord_flag defGhcFlag "ddump-asm-liveness" (setDumpFlag Opt_D_dump_asm_liveness) , make_ord_flag defGhcFlag "ddump-asm-regalloc" (setDumpFlag Opt_D_dump_asm_regalloc) , make_ord_flag defGhcFlag "ddump-asm-conflicts" (setDumpFlag Opt_D_dump_asm_conflicts) , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages" (setDumpFlag Opt_D_dump_asm_regalloc_stages) , make_ord_flag defGhcFlag "ddump-asm-stats" (setDumpFlag Opt_D_dump_asm_stats) , make_ord_flag defGhcFlag "ddump-asm-expanded" (setDumpFlag Opt_D_dump_asm_expanded) , make_ord_flag defGhcFlag "ddump-llvm" (NoArg $ setObjTarget HscLlvm >> setDumpFlag' Opt_D_dump_llvm) , make_ord_flag defGhcFlag "ddump-deriv" (setDumpFlag Opt_D_dump_deriv) , make_ord_flag defGhcFlag "ddump-ds" (setDumpFlag Opt_D_dump_ds) , make_ord_flag defGhcFlag "ddump-ds-preopt" (setDumpFlag Opt_D_dump_ds_preopt) , make_ord_flag defGhcFlag "ddump-foreign" (setDumpFlag Opt_D_dump_foreign) , make_ord_flag defGhcFlag "ddump-inlinings" (setDumpFlag Opt_D_dump_inlinings) , make_ord_flag defGhcFlag "ddump-rule-firings" (setDumpFlag Opt_D_dump_rule_firings) , make_ord_flag defGhcFlag "ddump-rule-rewrites" (setDumpFlag Opt_D_dump_rule_rewrites) , make_ord_flag defGhcFlag "ddump-simpl-trace" (setDumpFlag Opt_D_dump_simpl_trace) , make_ord_flag defGhcFlag "ddump-occur-anal" (setDumpFlag Opt_D_dump_occur_anal) , make_ord_flag defGhcFlag "ddump-parsed" (setDumpFlag Opt_D_dump_parsed) , make_ord_flag defGhcFlag "ddump-parsed-ast" (setDumpFlag Opt_D_dump_parsed_ast) , make_ord_flag defGhcFlag "ddump-rn" (setDumpFlag Opt_D_dump_rn) , make_ord_flag defGhcFlag "ddump-rn-ast" (setDumpFlag Opt_D_dump_rn_ast) , make_ord_flag defGhcFlag "ddump-simpl" (setDumpFlag Opt_D_dump_simpl) , make_ord_flag defGhcFlag "ddump-simpl-iterations" (setDumpFlag Opt_D_dump_simpl_iterations) , make_ord_flag defGhcFlag "ddump-spec" (setDumpFlag Opt_D_dump_spec) , make_ord_flag defGhcFlag "ddump-prep" (setDumpFlag Opt_D_dump_prep) , make_ord_flag defGhcFlag "ddump-stg" (setDumpFlag Opt_D_dump_stg) , make_ord_flag defGhcFlag "ddump-stg-unarised" (setDumpFlag Opt_D_dump_stg_unarised) , make_ord_flag defGhcFlag "ddump-stg-final" (setDumpFlag Opt_D_dump_stg_final) , make_ord_flag defGhcFlag "ddump-call-arity" (setDumpFlag Opt_D_dump_call_arity) , make_ord_flag defGhcFlag "ddump-exitify" (setDumpFlag Opt_D_dump_exitify) , make_ord_flag defGhcFlag "ddump-stranal" (setDumpFlag Opt_D_dump_stranal) , make_ord_flag defGhcFlag "ddump-str-signatures" (setDumpFlag Opt_D_dump_str_signatures) , make_ord_flag defGhcFlag "ddump-tc" (setDumpFlag Opt_D_dump_tc) , make_ord_flag defGhcFlag "ddump-tc-ast" (setDumpFlag Opt_D_dump_tc_ast) , make_ord_flag defGhcFlag "ddump-types" (setDumpFlag Opt_D_dump_types) , make_ord_flag defGhcFlag "ddump-rules" (setDumpFlag Opt_D_dump_rules) , make_ord_flag defGhcFlag "ddump-cse" (setDumpFlag Opt_D_dump_cse) , make_ord_flag defGhcFlag "ddump-worker-wrapper" (setDumpFlag Opt_D_dump_worker_wrapper) , make_ord_flag defGhcFlag "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) , make_ord_flag defGhcFlag "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) , make_ord_flag defGhcFlag "ddump-cs-trace" (setDumpFlag Opt_D_dump_cs_trace) , make_ord_flag defGhcFlag "ddump-tc-trace" (NoArg (do setDumpFlag' Opt_D_dump_tc_trace setDumpFlag' Opt_D_dump_cs_trace)) , make_ord_flag defGhcFlag "ddump-ec-trace" (setDumpFlag Opt_D_dump_ec_trace) , make_ord_flag defGhcFlag "ddump-vt-trace" (setDumpFlag Opt_D_dump_vt_trace) , make_ord_flag defGhcFlag "ddump-splices" (setDumpFlag Opt_D_dump_splices) , make_ord_flag defGhcFlag "dth-dec-file" (setDumpFlag Opt_D_th_dec_file) , make_ord_flag defGhcFlag "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) , make_ord_flag defGhcFlag "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm) , make_ord_flag defGhcFlag "ddump-simpl-stats" (setDumpFlag Opt_D_dump_simpl_stats) , make_ord_flag defGhcFlag "ddump-bcos" (setDumpFlag Opt_D_dump_BCOs) , make_ord_flag defGhcFlag "dsource-stats" (setDumpFlag Opt_D_source_stats) , make_ord_flag defGhcFlag "dverbose-core2core" (NoArg $ setVerbosity (Just 2) >> setVerboseCore2Core) , make_ord_flag defGhcFlag "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg) , make_ord_flag defGhcFlag "ddump-hi" (setDumpFlag Opt_D_dump_hi) , make_ord_flag defGhcFlag "ddump-minimal-imports" (NoArg (setGeneralFlag Opt_D_dump_minimal_imports)) , make_ord_flag defGhcFlag "ddump-hpc" (setDumpFlag Opt_D_dump_ticked) -- back compat , make_ord_flag defGhcFlag "ddump-ticked" (setDumpFlag Opt_D_dump_ticked) , make_ord_flag defGhcFlag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) , make_ord_flag defGhcFlag "ddump-mod-map" (setDumpFlag Opt_D_dump_mod_map) , make_ord_flag defGhcFlag "ddump-timings" (setDumpFlag Opt_D_dump_timings) , make_ord_flag defGhcFlag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) , make_ord_flag defGhcFlag "ddump-to-file" (NoArg (setGeneralFlag Opt_DumpToFile)) , make_ord_flag defGhcFlag "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs) , make_ord_flag defGhcFlag "ddump-rtti" (setDumpFlag Opt_D_dump_rtti) , make_ord_flag defGhcFlag "dcore-lint" (NoArg (setGeneralFlag Opt_DoCoreLinting)) , make_ord_flag defGhcFlag "dstg-lint" (NoArg (setGeneralFlag Opt_DoStgLinting)) , make_ord_flag defGhcFlag "dcmm-lint" (NoArg (setGeneralFlag Opt_DoCmmLinting)) , make_ord_flag defGhcFlag "dasm-lint" (NoArg (setGeneralFlag Opt_DoAsmLinting)) , make_ord_flag defGhcFlag "dannot-lint" (NoArg (setGeneralFlag Opt_DoAnnotationLinting)) , make_ord_flag defGhcFlag "dshow-passes" (NoArg $ forceRecompile >> (setVerbosity $ Just 2)) , make_ord_flag defGhcFlag "dfaststring-stats" (NoArg (setGeneralFlag Opt_D_faststring_stats)) , make_ord_flag defGhcFlag "dno-llvm-mangler" (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag , make_ord_flag defGhcFlag "fast-llvm" (NoArg (setGeneralFlag Opt_FastLlvm)) -- hidden flag , make_ord_flag defGhcFlag "dno-typeable-binds" (NoArg (setGeneralFlag Opt_NoTypeableBinds)) , make_ord_flag defGhcFlag "ddump-debug" (setDumpFlag Opt_D_dump_debug) , make_ord_flag defGhcFlag "ddump-json" (noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) ) , make_ord_flag defGhcFlag "dppr-debug" (setDumpFlag Opt_D_ppr_debug) , make_ord_flag defGhcFlag "ddebug-output" (noArg (flip dopt_unset Opt_D_no_debug_output)) , make_ord_flag defGhcFlag "dno-debug-output" (setDumpFlag Opt_D_no_debug_output) ------ Machine dependent (-m) stuff --------------------------- , make_ord_flag defGhcFlag "msse" (noArg (\d -> d { sseVersion = Just SSE1 })) , make_ord_flag defGhcFlag "msse2" (noArg (\d -> d { sseVersion = Just SSE2 })) , make_ord_flag defGhcFlag "msse3" (noArg (\d -> d { sseVersion = Just SSE3 })) , make_ord_flag defGhcFlag "msse4" (noArg (\d -> d { sseVersion = Just SSE4 })) , make_ord_flag defGhcFlag "msse4.2" (noArg (\d -> d { sseVersion = Just SSE42 })) , make_ord_flag defGhcFlag "mbmi" (noArg (\d -> d { bmiVersion = Just BMI1 })) , make_ord_flag defGhcFlag "mbmi2" (noArg (\d -> d { bmiVersion = Just BMI2 })) , make_ord_flag defGhcFlag "mavx" (noArg (\d -> d { avx = True })) , make_ord_flag defGhcFlag "mavx2" (noArg (\d -> d { avx2 = True })) , make_ord_flag defGhcFlag "mavx512cd" (noArg (\d -> d { avx512cd = True })) , make_ord_flag defGhcFlag "mavx512er" (noArg (\d -> d { avx512er = True })) , make_ord_flag defGhcFlag "mavx512f" (noArg (\d -> d { avx512f = True })) , make_ord_flag defGhcFlag "mavx512pf" (noArg (\d -> d { avx512pf = True })) ------ Warning opts ------------------------------------------------- , make_ord_flag defFlag "W" (NoArg (mapM_ setWarningFlag minusWOpts)) , make_ord_flag defFlag "Werror" (NoArg (do { setGeneralFlag Opt_WarnIsError ; mapM_ setFatalWarningFlag minusWeverythingOpts })) , make_ord_flag defFlag "Wwarn" (NoArg (do { unSetGeneralFlag Opt_WarnIsError ; mapM_ unSetFatalWarningFlag minusWeverythingOpts })) -- Opt_WarnIsError is still needed to pass -Werror -- to CPP; see runCpp in SysTools , make_dep_flag defFlag "Wnot" (NoArg (upd (\d -> d {warningFlags = EnumSet.empty}))) "Use -w or -Wno-everything instead" , make_ord_flag defFlag "w" (NoArg (upd (\d -> d {warningFlags = EnumSet.empty}))) -- New-style uniform warning sets -- -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything , make_ord_flag defFlag "Weverything" (NoArg (mapM_ setWarningFlag minusWeverythingOpts)) , make_ord_flag defFlag "Wno-everything" (NoArg (upd (\d -> d {warningFlags = EnumSet.empty}))) , make_ord_flag defFlag "Wall" (NoArg (mapM_ setWarningFlag minusWallOpts)) , make_ord_flag defFlag "Wno-all" (NoArg (mapM_ unSetWarningFlag minusWallOpts)) , make_ord_flag defFlag "Wextra" (NoArg (mapM_ setWarningFlag minusWOpts)) , make_ord_flag defFlag "Wno-extra" (NoArg (mapM_ unSetWarningFlag minusWOpts)) , make_ord_flag defFlag "Wdefault" (NoArg (mapM_ setWarningFlag standardWarnings)) , make_ord_flag defFlag "Wno-default" (NoArg (mapM_ unSetWarningFlag standardWarnings)) , make_ord_flag defFlag "Wcompat" (NoArg (mapM_ setWarningFlag minusWcompatOpts)) , make_ord_flag defFlag "Wno-compat" (NoArg (mapM_ unSetWarningFlag minusWcompatOpts)) ------ Plugin flags ------------------------------------------------ , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption) , make_ord_flag defGhcFlag "fplugin-trustworthy" (NoArg (setGeneralFlag Opt_PluginTrustworthy)) , make_ord_flag defGhcFlag "fplugin" (hasArg addPluginModuleName) , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames) , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption) ------ Optimisation flags ------------------------------------------ , make_dep_flag defGhcFlag "Onot" (noArgM $ setOptLevel 0 ) "Use -O0 instead" , make_ord_flag defGhcFlag "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1))) -- If the number is missing, use 1 , make_ord_flag defFlag "fbinary-blob-threshold" (intSuffix (\n d -> d { binBlobThreshold = fromIntegral n })) , make_ord_flag defFlag "fmax-relevant-binds" (intSuffix (\n d -> d { maxRelevantBinds = Just n })) , make_ord_flag defFlag "fno-max-relevant-binds" (noArg (\d -> d { maxRelevantBinds = Nothing })) , make_ord_flag defFlag "fmax-valid-hole-fits" (intSuffix (\n d -> d { maxValidHoleFits = Just n })) , make_ord_flag defFlag "fno-max-valid-hole-fits" (noArg (\d -> d { maxValidHoleFits = Nothing })) , make_ord_flag defFlag "fmax-refinement-hole-fits" (intSuffix (\n d -> d { maxRefHoleFits = Just n })) , make_ord_flag defFlag "fno-max-refinement-hole-fits" (noArg (\d -> d { maxRefHoleFits = Nothing })) , make_ord_flag defFlag "frefinement-level-hole-fits" (intSuffix (\n d -> d { refLevelHoleFits = Just n })) , make_ord_flag defFlag "fno-refinement-level-hole-fits" (noArg (\d -> d { refLevelHoleFits = Nothing })) , make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs" (noArg id) "vectors registers are now passed in registers by default." , make_ord_flag defFlag "fmax-uncovered-patterns" (intSuffix (\n d -> d { maxUncoveredPatterns = n })) , make_ord_flag defFlag "fmax-pmcheck-models" (intSuffix (\n d -> d { maxPmCheckModels = n })) , make_ord_flag defFlag "fsimplifier-phases" (intSuffix (\n d -> d { simplPhases = n })) , make_ord_flag defFlag "fmax-simplifier-iterations" (intSuffix (\n d -> d { maxSimplIterations = n })) , (Deprecated, defFlag "fmax-pmcheck-iterations" (intSuffixM (\_ d -> do { deprecate $ "use -fmax-pmcheck-models instead" ; return d }))) , make_ord_flag defFlag "fsimpl-tick-factor" (intSuffix (\n d -> d { simplTickFactor = n })) , make_ord_flag defFlag "fspec-constr-threshold" (intSuffix (\n d -> d { specConstrThreshold = Just n })) , make_ord_flag defFlag "fno-spec-constr-threshold" (noArg (\d -> d { specConstrThreshold = Nothing })) , make_ord_flag defFlag "fspec-constr-count" (intSuffix (\n d -> d { specConstrCount = Just n })) , make_ord_flag defFlag "fno-spec-constr-count" (noArg (\d -> d { specConstrCount = Nothing })) , make_ord_flag defFlag "fspec-constr-recursive" (intSuffix (\n d -> d { specConstrRecursive = n })) , make_ord_flag defFlag "fliberate-case-threshold" (intSuffix (\n d -> d { liberateCaseThreshold = Just n })) , make_ord_flag defFlag "fno-liberate-case-threshold" (noArg (\d -> d { liberateCaseThreshold = Nothing })) , make_ord_flag defFlag "drule-check" (sepArg (\s d -> d { ruleCheck = Just s })) , make_ord_flag defFlag "dinline-check" (sepArg (\s d -> d { inlineCheck = Just s })) , make_ord_flag defFlag "freduction-depth" (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n })) , make_ord_flag defFlag "fconstraint-solver-iterations" (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n })) , (Deprecated, defFlag "fcontext-stack" (intSuffixM (\n d -> do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" ; return $ d { reductionDepth = treatZeroAsInf n } }))) , (Deprecated, defFlag "ftype-function-depth" (intSuffixM (\n d -> do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" ; return $ d { reductionDepth = treatZeroAsInf n } }))) , make_ord_flag defFlag "fstrictness-before" (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d })) , make_ord_flag defFlag "ffloat-lam-args" (intSuffix (\n d -> d { floatLamArgs = Just n })) , make_ord_flag defFlag "ffloat-all-lams" (noArg (\d -> d { floatLamArgs = Nothing })) , make_ord_flag defFlag "fstg-lift-lams-rec-args" (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) , make_ord_flag defFlag "fstg-lift-lams-rec-args-any" (noArg (\d -> d { liftLamsRecArgs = Nothing })) , make_ord_flag defFlag "fstg-lift-lams-non-rec-args" (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any" (noArg (\d -> d { liftLamsRecArgs = Nothing })) , make_ord_flag defFlag "fstg-lift-lams-known" (noArg (\d -> d { liftLamsKnown = True })) , make_ord_flag defFlag "fno-stg-lift-lams-known" (noArg (\d -> d { liftLamsKnown = False })) , make_ord_flag defFlag "fproc-alignment" (intSuffix (\n d -> d { cmmProcAlignment = Just n })) , make_ord_flag defFlag "fblock-layout-weights" (HasArg (\s -> upd (\d -> d { cfgWeightInfo = parseCfgWeights s (cfgWeightInfo d)}))) , make_ord_flag defFlag "fhistory-size" (intSuffix (\n d -> d { historySize = n })) , make_ord_flag defFlag "funfolding-creation-threshold" (intSuffix (\n d -> d {ufCreationThreshold = n})) , make_ord_flag defFlag "funfolding-use-threshold" (intSuffix (\n d -> d {ufUseThreshold = n})) , make_ord_flag defFlag "funfolding-fun-discount" (intSuffix (\n d -> d {ufFunAppDiscount = n})) , make_ord_flag defFlag "funfolding-dict-discount" (intSuffix (\n d -> d {ufDictDiscount = n})) , make_ord_flag defFlag "funfolding-keeness-factor" (floatSuffix (\n d -> d {ufKeenessFactor = n})) , make_ord_flag defFlag "fmax-worker-args" (intSuffix (\n d -> d {maxWorkerArgs = n})) , make_ord_flag defGhciFlag "fghci-hist-size" (intSuffix (\n d -> d {ghciHistSize = n})) , make_ord_flag defGhcFlag "fmax-inline-alloc-size" (intSuffix (\n d -> d { maxInlineAllocSize = n })) , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns" (intSuffix (\n d -> d { maxInlineMemcpyInsns = n })) , make_ord_flag defGhcFlag "fmax-inline-memset-insns" (intSuffix (\n d -> d { maxInlineMemsetInsns = n })) , make_ord_flag defGhcFlag "dinitial-unique" (intSuffix (\n d -> d { initialUnique = n })) , make_ord_flag defGhcFlag "dunique-increment" (intSuffix (\n d -> d { uniqueIncrement = n })) ------ Profiling ---------------------------------------------------- -- OLD profiling flags , make_dep_flag defGhcFlag "auto-all" (noArg (\d -> d { profAuto = ProfAutoAll } )) "Use -fprof-auto instead" , make_dep_flag defGhcFlag "no-auto-all" (noArg (\d -> d { profAuto = NoProfAuto } )) "Use -fno-prof-auto instead" , make_dep_flag defGhcFlag "auto" (noArg (\d -> d { profAuto = ProfAutoExports } )) "Use -fprof-auto-exported instead" , make_dep_flag defGhcFlag "no-auto" (noArg (\d -> d { profAuto = NoProfAuto } )) "Use -fno-prof-auto instead" , make_dep_flag defGhcFlag "caf-all" (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs)) "Use -fprof-cafs instead" , make_dep_flag defGhcFlag "no-caf-all" (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs)) "Use -fno-prof-cafs instead" -- NEW profiling flags , make_ord_flag defGhcFlag "fprof-auto" (noArg (\d -> d { profAuto = ProfAutoAll } )) , make_ord_flag defGhcFlag "fprof-auto-top" (noArg (\d -> d { profAuto = ProfAutoTop } )) , make_ord_flag defGhcFlag "fprof-auto-exported" (noArg (\d -> d { profAuto = ProfAutoExports } )) , make_ord_flag defGhcFlag "fprof-auto-calls" (noArg (\d -> d { profAuto = ProfAutoCalls } )) , make_ord_flag defGhcFlag "fno-prof-auto" (noArg (\d -> d { profAuto = NoProfAuto } )) ------ Compiler flags ----------------------------------------------- , make_ord_flag defGhcFlag "fasm" (NoArg (setObjTarget HscAsm)) , make_ord_flag defGhcFlag "fvia-c" (NoArg (deprecate $ "The -fvia-c flag does nothing; " ++ "it will be removed in a future GHC release")) , make_ord_flag defGhcFlag "fvia-C" (NoArg (deprecate $ "The -fvia-C flag does nothing; " ++ "it will be removed in a future GHC release")) , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjTarget HscLlvm)) , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> d { ghcLink=NoLink }) >> setTarget HscNothing)) , make_ord_flag defFlag "fbyte-code" (noArgM $ \dflags -> do setTarget HscInterpreted pure $ gopt_set dflags Opt_ByteCode) , make_ord_flag defFlag "fobject-code" $ NoArg $ do dflags <- liftEwM getCmdLineState setTarget $ defaultObjectTarget dflags , make_dep_flag defFlag "fglasgow-exts" (NoArg enableGlasgowExts) "Use individual extensions instead" , make_dep_flag defFlag "fno-glasgow-exts" (NoArg disableGlasgowExts) "Use individual extensions instead" , make_ord_flag defFlag "Wunused-binds" (NoArg enableUnusedBinds) , make_ord_flag defFlag "Wno-unused-binds" (NoArg disableUnusedBinds) , make_ord_flag defHiddenFlag "fwarn-unused-binds" (NoArg enableUnusedBinds) , make_ord_flag defHiddenFlag "fno-warn-unused-binds" (NoArg disableUnusedBinds) ------ Safe Haskell flags ------------------------------------------- , make_ord_flag defFlag "fpackage-trust" (NoArg setPackageTrust) , make_ord_flag defFlag "fno-safe-infer" (noArg (\d -> d { safeInfer = False })) , make_ord_flag defFlag "fno-safe-haskell" (NoArg (setSafeHaskell Sf_Ignore)) ------ position independent flags ---------------------------------- , make_ord_flag defGhcFlag "fPIC" (NoArg (setGeneralFlag Opt_PIC)) , make_ord_flag defGhcFlag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC)) , make_ord_flag defGhcFlag "fPIE" (NoArg (setGeneralFlag Opt_PIC)) , make_ord_flag defGhcFlag "fno-PIE" (NoArg (unSetGeneralFlag Opt_PIC)) ------ Debugging flags ---------------------------------------------- , make_ord_flag defGhcFlag "g" (OptIntSuffix setDebugLevel) ] ++ map (mkFlag turnOn "" setGeneralFlag ) negatableFlagsDeps ++ map (mkFlag turnOff "no-" unSetGeneralFlag ) negatableFlagsDeps ++ map (mkFlag turnOn "d" setGeneralFlag ) dFlagsDeps ++ map (mkFlag turnOff "dno-" unSetGeneralFlag ) dFlagsDeps ++ map (mkFlag turnOn "f" setGeneralFlag ) fFlagsDeps ++ map (mkFlag turnOff "fno-" unSetGeneralFlag ) fFlagsDeps ++ map (mkFlag turnOn "W" setWarningFlag ) wWarningFlagsDeps ++ map (mkFlag turnOff "Wno-" unSetWarningFlag ) wWarningFlagsDeps ++ map (mkFlag turnOn "Werror=" setWErrorFlag ) wWarningFlagsDeps ++ map (mkFlag turnOn "Wwarn=" unSetFatalWarningFlag ) wWarningFlagsDeps ++ map (mkFlag turnOn "Wno-error=" unSetFatalWarningFlag ) wWarningFlagsDeps ++ map (mkFlag turnOn "fwarn-" setWarningFlag . hideFlag) wWarningFlagsDeps ++ map (mkFlag turnOff "fno-warn-" unSetWarningFlag . hideFlag) wWarningFlagsDeps ++ [ (NotDeprecated, unrecognisedWarning "W"), (Deprecated, unrecognisedWarning "fwarn-"), (Deprecated, unrecognisedWarning "fno-warn-") ] ++ [ make_ord_flag defFlag "Werror=compat" (NoArg (mapM_ setWErrorFlag minusWcompatOpts)) , make_ord_flag defFlag "Wno-error=compat" (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) , make_ord_flag defFlag "Wwarn=compat" (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) ] ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlagsDeps ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlagsDeps ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlagsDeps ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlagsDeps ++ map (mkFlag turnOn "X" setLanguage ) languageFlagsDeps ++ map (mkFlag turnOn "X" setSafeHaskell ) safeHaskellFlagsDeps ++ [ make_dep_flag defFlag "XGenerics" (NoArg $ return ()) ("it does nothing; look into -XDefaultSignatures " ++ "and -XDeriveGeneric for generic programming support.") , make_dep_flag defFlag "XNoGenerics" (NoArg $ return ()) ("it does nothing; look into -XDefaultSignatures and " ++ "-XDeriveGeneric for generic programming support.") ] -- | This is where we handle unrecognised warning flags. We only issue a warning -- if -Wunrecognised-warning-flags is set. See #11429 for context. unrecognisedWarning :: String -> Flag (CmdLineP DynFlags) unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action) where action :: String -> EwM (CmdLineP DynFlags) () action flag = do f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState when f $ addFlagWarn Cmd.ReasonUnrecognisedFlag $ "unrecognised warning flag: -" ++ prefix ++ flag -- See Note [Supporting CLI completion] package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] package_flags_deps = [ ------- Packages ---------------------------------------------------- make_ord_flag defFlag "package-db" (HasArg (addPkgConfRef . PkgConfFile)) , make_ord_flag defFlag "clear-package-db" (NoArg clearPkgConf) , make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgConf) , make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgConf) , make_ord_flag defFlag "global-package-db" (NoArg (addPkgConfRef GlobalPkgConf)) , make_ord_flag defFlag "user-package-db" (NoArg (addPkgConfRef UserPkgConf)) -- backwards compat with GHC<=7.4 : , make_dep_flag defFlag "package-conf" (HasArg $ addPkgConfRef . PkgConfFile) "Use -package-db instead" , make_dep_flag defFlag "no-user-package-conf" (NoArg removeUserPkgConf) "Use -no-user-package-db instead" , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> do upd (setUnitId name)) -- TODO: Since we JUST deprecated -- -this-package-key, let's keep this -- undeprecated for another cycle. -- Deprecate this eventually. -- deprecate "Use -this-unit-id instead") , make_dep_flag defGhcFlag "this-package-key" (HasArg $ upd . setUnitId) "Use -this-unit-id instead" , make_ord_flag defGhcFlag "this-unit-id" (hasArg setUnitId) , make_ord_flag defFlag "package" (HasArg exposePackage) , make_ord_flag defFlag "plugin-package-id" (HasArg exposePluginPackageId) , make_ord_flag defFlag "plugin-package" (HasArg exposePluginPackage) , make_ord_flag defFlag "package-id" (HasArg exposePackageId) , make_ord_flag defFlag "hide-package" (HasArg hidePackage) , make_ord_flag defFlag "hide-all-packages" (NoArg (setGeneralFlag Opt_HideAllPackages)) , make_ord_flag defFlag "hide-all-plugin-packages" (NoArg (setGeneralFlag Opt_HideAllPluginPackages)) , make_ord_flag defFlag "package-env" (HasArg setPackageEnv) , make_ord_flag defFlag "ignore-package" (HasArg ignorePackage) , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead" , make_ord_flag defFlag "distrust-all-packages" (NoArg (setGeneralFlag Opt_DistrustAllPackages)) , make_ord_flag defFlag "trust" (HasArg trustPackage) , make_ord_flag defFlag "distrust" (HasArg distrustPackage) ] where setPackageEnv env = upd $ \s -> s { packageEnv = Just env } -- | Make a list of flags for shell completion. -- Filter all available flags into two groups, for interactive GHC vs all other. flagsForCompletion :: Bool -> [String] flagsForCompletion isInteractive = [ '-':flagName flag | flag <- flagsAll , modeFilter (flagGhcMode flag) ] where modeFilter AllModes = True modeFilter OnlyGhci = isInteractive modeFilter OnlyGhc = not isInteractive modeFilter HiddenFlag = False 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 data FlagSpec flag = FlagSpec { flagSpecName :: String -- ^ Flag in string form , flagSpecFlag :: flag -- ^ Flag in internal form , flagSpecAction :: (TurnOnFlag -> DynP ()) -- ^ Extra action to run when the flag is found -- Typically, emit a warning or error , flagSpecGhcMode :: GhcFlagMode -- ^ In which ghc mode the flag has effect } -- | Define a new flag. flagSpec :: String -> flag -> (Deprecation, FlagSpec flag) flagSpec name flag = flagSpec' name flag nop -- | Define a new flag with an effect. flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) -> (Deprecation, FlagSpec flag) flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes) -- | Define a new deprecated flag with an effect. depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String -> (Deprecation, FlagSpec flag) depFlagSpecOp name flag act dep = (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep))) -- | Define a new deprecated flag. depFlagSpec :: String -> flag -> String -> (Deprecation, FlagSpec flag) depFlagSpec name flag dep = depFlagSpecOp name flag nop dep -- | Define a new deprecated flag with an effect where the deprecation message -- depends on the flag value depFlagSpecOp' :: String -> flag -> (TurnOnFlag -> DynP ()) -> (TurnOnFlag -> String) -> (Deprecation, FlagSpec flag) depFlagSpecOp' name flag act dep = (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f)) AllModes) -- | Define a new deprecated flag where the deprecation message -- depends on the flag value depFlagSpec' :: String -> flag -> (TurnOnFlag -> String) -> (Deprecation, FlagSpec flag) depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep -- | Define a new deprecated flag where the deprecation message -- is shown depending on the flag value depFlagSpecCond :: String -> flag -> (TurnOnFlag -> Bool) -> String -> (Deprecation, FlagSpec flag) depFlagSpecCond name flag cond dep = (Deprecated, FlagSpec name flag (\f -> when (cond f) $ deprecate dep) AllModes) -- | Define a new flag for GHCi. flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag) flagGhciSpec name flag = flagGhciSpec' name flag nop -- | Define a new flag for GHCi with an effect. flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) -> (Deprecation, FlagSpec flag) flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci) -- | Define a new flag invisible to CLI completion. flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag) flagHiddenSpec name flag = flagHiddenSpec' name flag nop -- | Define a new flag invisible to CLI completion with an effect. flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) -> (Deprecation, FlagSpec flag) flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act HiddenFlag) -- | Hide a 'FlagSpec' from being displayed in @--show-options@. -- -- This is for example useful for flags that are obsolete, but should not -- (yet) be deprecated for compatibility reasons. hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a) hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag }) mkFlag :: TurnOnFlag -- ^ True <=> it should be turned on -> String -- ^ The flag prefix -> (flag -> DynP ()) -- ^ What to do when the flag is found -> (Deprecation, FlagSpec flag) -- ^ Specification of -- this particular flag -> (Deprecation, Flag (CmdLineP DynFlags)) mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode)) = (dep, Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode) deprecatedForExtension :: String -> TurnOnFlag -> String deprecatedForExtension lang turn_on = "use -X" ++ flag ++ " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead" where flag | turn_on = lang | otherwise = "No" ++ lang useInstead :: String -> String -> TurnOnFlag -> String useInstead prefix flag turn_on = "Use " ++ prefix ++ no ++ flag ++ " instead" where no = if turn_on then "" else "no-" nop :: TurnOnFlag -> DynP () nop _ = return () -- | Find the 'FlagSpec' for a 'WarningFlag'. flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag) flagSpecOf flag = listToMaybe $ filter check wWarningFlags where check fs = flagSpecFlag fs == flag -- | These @-W\@ flags can all be reversed with @-Wno-\@ wWarningFlags :: [FlagSpec WarningFlag] wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps) wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)] wWarningFlagsDeps = [ -- See Note [Updating flag description in the User's Guide] -- See Note [Supporting CLI completion] -- Please keep the list of flags below sorted alphabetically flagSpec "alternative-layout-rule-transitional" Opt_WarnAlternativeLayoutRuleTransitional, depFlagSpec "auto-orphans" Opt_WarnAutoOrphans "it has no effect", flagSpec "cpp-undef" Opt_WarnCPPUndef, flagSpec "unbanged-strict-patterns" Opt_WarnUnbangedStrictPatterns, flagSpec "deferred-type-errors" Opt_WarnDeferredTypeErrors, flagSpec "deferred-out-of-scope-variables" Opt_WarnDeferredOutOfScopeVariables, flagSpec "deprecations" Opt_WarnWarningsDeprecations, flagSpec "deprecated-flags" Opt_WarnDeprecatedFlags, flagSpec "deriving-defaults" Opt_WarnDerivingDefaults, flagSpec "deriving-typeable" Opt_WarnDerivingTypeable, flagSpec "dodgy-exports" Opt_WarnDodgyExports, flagSpec "dodgy-foreign-imports" Opt_WarnDodgyForeignImports, flagSpec "dodgy-imports" Opt_WarnDodgyImports, flagSpec "empty-enumerations" Opt_WarnEmptyEnumerations, depFlagSpec "duplicate-constraints" Opt_WarnDuplicateConstraints "it is subsumed by -Wredundant-constraints", flagSpec "redundant-constraints" Opt_WarnRedundantConstraints, flagSpec "duplicate-exports" Opt_WarnDuplicateExports, depFlagSpec "hi-shadowing" Opt_WarnHiShadows "it is not used, and was never implemented", flagSpec "inaccessible-code" Opt_WarnInaccessibleCode, flagSpec "implicit-prelude" Opt_WarnImplicitPrelude, depFlagSpec "implicit-kind-vars" Opt_WarnImplicitKindVars "it is now an error", flagSpec "incomplete-patterns" Opt_WarnIncompletePatterns, flagSpec "incomplete-record-updates" Opt_WarnIncompletePatternsRecUpd, flagSpec "incomplete-uni-patterns" Opt_WarnIncompleteUniPatterns, flagSpec "inline-rule-shadowing" Opt_WarnInlineRuleShadowing, flagSpec "identities" Opt_WarnIdentities, flagSpec "missing-fields" Opt_WarnMissingFields, flagSpec "missing-import-lists" Opt_WarnMissingImportList, flagSpec "missing-export-lists" Opt_WarnMissingExportList, depFlagSpec "missing-local-sigs" Opt_WarnMissingLocalSignatures "it is replaced by -Wmissing-local-signatures", flagSpec "missing-local-signatures" Opt_WarnMissingLocalSignatures, flagSpec "missing-methods" Opt_WarnMissingMethods, flagSpec "missing-monadfail-instances" Opt_WarnMissingMonadFailInstances, flagSpec "semigroup" Opt_WarnSemigroup, flagSpec "missing-signatures" Opt_WarnMissingSignatures, depFlagSpec "missing-exported-sigs" Opt_WarnMissingExportedSignatures "it is replaced by -Wmissing-exported-signatures", flagSpec "missing-exported-signatures" Opt_WarnMissingExportedSignatures, flagSpec "monomorphism-restriction" Opt_WarnMonomorphism, flagSpec "name-shadowing" Opt_WarnNameShadowing, flagSpec "noncanonical-monad-instances" Opt_WarnNonCanonicalMonadInstances, depFlagSpec "noncanonical-monadfail-instances" Opt_WarnNonCanonicalMonadInstances "fail is no longer a method of Monad", flagSpec "noncanonical-monoid-instances" Opt_WarnNonCanonicalMonoidInstances, flagSpec "orphans" Opt_WarnOrphans, flagSpec "overflowed-literals" Opt_WarnOverflowedLiterals, flagSpec "overlapping-patterns" Opt_WarnOverlappingPatterns, flagSpec "missed-specialisations" Opt_WarnMissedSpecs, flagSpec "missed-specializations" Opt_WarnMissedSpecs, flagSpec "all-missed-specialisations" Opt_WarnAllMissedSpecs, flagSpec "all-missed-specializations" Opt_WarnAllMissedSpecs, flagSpec' "safe" Opt_WarnSafe setWarnSafe, flagSpec "trustworthy-safe" Opt_WarnTrustworthySafe, flagSpec "inferred-safe-imports" Opt_WarnInferredSafeImports, flagSpec "missing-safe-haskell-mode" Opt_WarnMissingSafeHaskellMode, flagSpec "tabs" Opt_WarnTabs, flagSpec "type-defaults" Opt_WarnTypeDefaults, flagSpec "typed-holes" Opt_WarnTypedHoles, flagSpec "partial-type-signatures" Opt_WarnPartialTypeSignatures, flagSpec "unrecognised-pragmas" Opt_WarnUnrecognisedPragmas, flagSpec' "unsafe" Opt_WarnUnsafe setWarnUnsafe, flagSpec "unsupported-calling-conventions" Opt_WarnUnsupportedCallingConventions, flagSpec "unsupported-llvm-version" Opt_WarnUnsupportedLlvmVersion, flagSpec "missed-extra-shared-lib" Opt_WarnMissedExtraSharedLib, flagSpec "unticked-promoted-constructors" Opt_WarnUntickedPromotedConstructors, flagSpec "unused-do-bind" Opt_WarnUnusedDoBind, flagSpec "unused-foralls" Opt_WarnUnusedForalls, flagSpec "unused-imports" Opt_WarnUnusedImports, flagSpec "unused-local-binds" Opt_WarnUnusedLocalBinds, flagSpec "unused-matches" Opt_WarnUnusedMatches, flagSpec "unused-pattern-binds" Opt_WarnUnusedPatternBinds, flagSpec "unused-top-binds" Opt_WarnUnusedTopBinds, flagSpec "unused-type-patterns" Opt_WarnUnusedTypePatterns, flagSpec "unused-record-wildcards" Opt_WarnUnusedRecordWildcards, flagSpec "redundant-record-wildcards" Opt_WarnRedundantRecordWildcards, flagSpec "warnings-deprecations" Opt_WarnWarningsDeprecations, flagSpec "wrong-do-bind" Opt_WarnWrongDoBind, flagSpec "missing-pattern-synonym-signatures" Opt_WarnMissingPatternSynonymSignatures, flagSpec "missing-deriving-strategies" Opt_WarnMissingDerivingStrategies, flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints, flagSpec "missing-home-modules" Opt_WarnMissingHomeModules, flagSpec "unrecognised-warning-flags" Opt_WarnUnrecognisedWarningFlags, flagSpec "star-binder" Opt_WarnStarBinder, flagSpec "star-is-type" Opt_WarnStarIsType, flagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang, flagSpec "partial-fields" Opt_WarnPartialFields, flagSpec "prepositive-qualified-module" Opt_WarnPrepositiveQualifiedModule, flagSpec "unused-packages" Opt_WarnUnusedPackages, flagSpec "compat-unqualified-imports" Opt_WarnCompatUnqualifiedImports ] -- | These @-\@ flags can all be reversed with @-no-\@ negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] negatableFlagsDeps = [ flagGhciSpec "ignore-dot-ghci" Opt_IgnoreDotGhci ] -- | These @-d\@ flags can all be reversed with @-dno-\@ dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] dFlagsDeps = [ -- See Note [Updating flag description in the User's Guide] -- See Note [Supporting CLI completion] -- Please keep the list of flags below sorted alphabetically flagSpec "ppr-case-as-let" Opt_PprCaseAsLet, depFlagSpec' "ppr-ticks" Opt_PprShowTicks (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)), flagSpec "suppress-ticks" Opt_SuppressTicks, depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts (useInstead "-d" "suppress-stg-exts"), flagSpec "suppress-stg-exts" Opt_SuppressStgExts, flagSpec "suppress-coercions" Opt_SuppressCoercions, flagSpec "suppress-idinfo" Opt_SuppressIdInfo, flagSpec "suppress-unfoldings" Opt_SuppressUnfoldings, flagSpec "suppress-module-prefixes" Opt_SuppressModulePrefixes, flagSpec "suppress-timestamps" Opt_SuppressTimestamps, flagSpec "suppress-type-applications" Opt_SuppressTypeApplications, flagSpec "suppress-type-signatures" Opt_SuppressTypeSignatures, flagSpec "suppress-uniques" Opt_SuppressUniques, flagSpec "suppress-var-kinds" Opt_SuppressVarKinds ] -- | These @-f\@ flags can all be reversed with @-fno-\@ fFlags :: [FlagSpec GeneralFlag] fFlags = map snd fFlagsDeps fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] fFlagsDeps = [ -- See Note [Updating flag description in the User's Guide] -- See Note [Supporting CLI completion] -- Please keep the list of flags below sorted alphabetically flagSpec "asm-shortcutting" Opt_AsmShortcutting, flagGhciSpec "break-on-error" Opt_BreakOnError, flagGhciSpec "break-on-exception" Opt_BreakOnException, flagSpec "building-cabal-package" Opt_BuildingCabalPackage, flagSpec "call-arity" Opt_CallArity, flagSpec "exitification" Opt_Exitification, flagSpec "case-merge" Opt_CaseMerge, flagSpec "case-folding" Opt_CaseFolding, flagSpec "cmm-elim-common-blocks" Opt_CmmElimCommonBlocks, flagSpec "cmm-sink" Opt_CmmSink, flagSpec "cse" Opt_CSE, flagSpec "stg-cse" Opt_StgCSE, flagSpec "stg-lift-lams" Opt_StgLiftLams, flagSpec "cpr-anal" Opt_CprAnal, flagSpec "defer-diagnostics" Opt_DeferDiagnostics, flagSpec "defer-type-errors" Opt_DeferTypeErrors, flagSpec "defer-typed-holes" Opt_DeferTypedHoles, flagSpec "defer-out-of-scope-variables" Opt_DeferOutOfScopeVariables, flagSpec "diagnostics-show-caret" Opt_DiagnosticsShowCaret, flagSpec "dicts-cheap" Opt_DictsCheap, flagSpec "dicts-strict" Opt_DictsStrict, flagSpec "dmd-tx-dict-sel" Opt_DmdTxDictSel, flagSpec "do-eta-reduction" Opt_DoEtaReduction, flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, flagSpec "eager-blackholing" Opt_EagerBlackHoling, flagSpec "embed-manifest" Opt_EmbedManifest, flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings, flagSpec "error-spans" Opt_ErrorSpans, flagSpec "excess-precision" Opt_ExcessPrecision, flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings, flagSpec "external-dynamic-refs" Opt_ExternalDynamicRefs, flagSpec "external-interpreter" Opt_ExternalInterpreter, flagSpec "flat-cache" Opt_FlatCache, flagSpec "float-in" Opt_FloatIn, flagSpec "force-recomp" Opt_ForceRecomp, flagSpec "ignore-optim-changes" Opt_IgnoreOptimChanges, flagSpec "ignore-hpc-changes" Opt_IgnoreHpcChanges, flagSpec "full-laziness" Opt_FullLaziness, flagSpec "fun-to-thunk" Opt_FunToThunk, flagSpec "gen-manifest" Opt_GenManifest, flagSpec "ghci-history" Opt_GhciHistory, flagSpec "ghci-leak-check" Opt_GhciLeakCheck, flagSpec "validate-ide-info" Opt_ValidateHie, flagGhciSpec "local-ghci-history" Opt_LocalGhciHistory, flagGhciSpec "no-it" Opt_NoIt, flagSpec "ghci-sandbox" Opt_GhciSandbox, flagSpec "helpful-errors" Opt_HelpfulErrors, flagSpec "hpc" Opt_Hpc, flagSpec "ignore-asserts" Opt_IgnoreAsserts, flagSpec "ignore-interface-pragmas" Opt_IgnoreInterfacePragmas, flagGhciSpec "implicit-import-qualified" Opt_ImplicitImportQualified, flagSpec "irrefutable-tuples" Opt_IrrefutableTuples, flagSpec "keep-going" Opt_KeepGoing, flagSpec "kill-absence" Opt_KillAbsence, flagSpec "kill-one-shot" Opt_KillOneShot, flagSpec "late-dmd-anal" Opt_LateDmdAnal, flagSpec "late-specialise" Opt_LateSpecialise, flagSpec "liberate-case" Opt_LiberateCase, flagHiddenSpec "llvm-tbaa" Opt_LlvmTBAA, flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage, flagSpec "loopification" Opt_Loopification, flagSpec "block-layout-cfg" Opt_CfgBlocklayout, flagSpec "block-layout-weightless" Opt_WeightlessBlocklayout, flagSpec "omit-interface-pragmas" Opt_OmitInterfacePragmas, flagSpec "omit-yields" Opt_OmitYields, flagSpec "optimal-applicative-do" Opt_OptimalApplicativeDo, flagSpec "pedantic-bottoms" Opt_PedanticBottoms, flagSpec "pre-inlining" Opt_SimplPreInlining, flagGhciSpec "print-bind-contents" Opt_PrintBindContents, flagGhciSpec "print-bind-result" Opt_PrintBindResult, flagGhciSpec "print-evld-with-show" Opt_PrintEvldWithShow, flagSpec "print-explicit-foralls" Opt_PrintExplicitForalls, flagSpec "print-explicit-kinds" Opt_PrintExplicitKinds, flagSpec "print-explicit-coercions" Opt_PrintExplicitCoercions, flagSpec "print-explicit-runtime-reps" Opt_PrintExplicitRuntimeReps, flagSpec "print-equality-relations" Opt_PrintEqualityRelations, flagSpec "print-axiom-incomps" Opt_PrintAxiomIncomps, flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax, flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms, flagSpec "print-potential-instances" Opt_PrintPotentialInstances, flagSpec "print-typechecker-elaboration" Opt_PrintTypecheckerElaboration, flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, flagSpec "prof-count-entries" Opt_ProfCountEntries, flagSpec "regs-graph" Opt_RegsGraph, flagSpec "regs-iterative" Opt_RegsIterative, depFlagSpec' "rewrite-rules" Opt_EnableRewriteRules (useInstead "-f" "enable-rewrite-rules"), flagSpec "shared-implib" Opt_SharedImplib, flagSpec "spec-constr" Opt_SpecConstr, flagSpec "spec-constr-keen" Opt_SpecConstrKeen, flagSpec "specialise" Opt_Specialise, flagSpec "specialize" Opt_Specialise, flagSpec "specialise-aggressively" Opt_SpecialiseAggressively, flagSpec "specialize-aggressively" Opt_SpecialiseAggressively, flagSpec "cross-module-specialise" Opt_CrossModuleSpecialise, flagSpec "cross-module-specialize" Opt_CrossModuleSpecialise, flagSpec "static-argument-transformation" Opt_StaticArgumentTransformation, flagSpec "strictness" Opt_Strictness, flagSpec "use-rpaths" Opt_RPath, flagSpec "write-interface" Opt_WriteInterface, flagSpec "write-ide-info" Opt_WriteHie, flagSpec "unbox-small-strict-fields" Opt_UnboxSmallStrictFields, flagSpec "unbox-strict-fields" Opt_UnboxStrictFields, flagSpec "version-macros" Opt_VersionMacros, flagSpec "worker-wrapper" Opt_WorkerWrapper, flagSpec "solve-constant-dicts" Opt_SolveConstantDicts, flagSpec "catch-bottoms" Opt_CatchBottoms, flagSpec "alignment-sanitisation" Opt_AlignmentSanitisation, flagSpec "num-constant-folding" Opt_NumConstantFolding, flagSpec "show-warning-groups" Opt_ShowWarnGroups, flagSpec "hide-source-paths" Opt_HideSourcePaths, flagSpec "show-loaded-modules" Opt_ShowLoadedModules, flagSpec "whole-archive-hs-libs" Opt_WholeArchiveHsLibs, flagSpec "keep-cafs" Opt_KeepCAFs ] ++ fHoleFlags -- | These @-f\@ flags have to do with the typed-hole error message or -- the valid hole fits in that message. See Note [Valid hole fits include ...] -- in the TcHoleErrors module. These flags can all be reversed with -- @-fno-\@ fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)] fHoleFlags = [ flagSpec "show-hole-constraints" Opt_ShowHoleConstraints, depFlagSpec' "show-valid-substitutions" Opt_ShowValidHoleFits (useInstead "-f" "show-valid-hole-fits"), flagSpec "show-valid-hole-fits" Opt_ShowValidHoleFits, -- Sorting settings flagSpec "sort-valid-hole-fits" Opt_SortValidHoleFits, flagSpec "sort-by-size-hole-fits" Opt_SortBySizeHoleFits, flagSpec "sort-by-subsumption-hole-fits" Opt_SortBySubsumHoleFits, flagSpec "abstract-refinement-hole-fits" Opt_AbstractRefHoleFits, -- Output format settings flagSpec "show-hole-matches-of-hole-fits" Opt_ShowMatchesOfHoleFits, flagSpec "show-provenance-of-hole-fits" Opt_ShowProvOfHoleFits, flagSpec "show-type-of-hole-fits" Opt_ShowTypeOfHoleFits, flagSpec "show-type-app-of-hole-fits" Opt_ShowTypeAppOfHoleFits, flagSpec "show-type-app-vars-of-hole-fits" Opt_ShowTypeAppVarsOfHoleFits, flagSpec "show-docs-of-hole-fits" Opt_ShowDocsOfHoleFits, flagSpec "unclutter-valid-hole-fits" Opt_UnclutterValidHoleFits ] -- | These @-f\@ flags can all be reversed with @-fno-\@ fLangFlags :: [FlagSpec LangExt.Extension] fLangFlags = map snd fLangFlagsDeps fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] fLangFlagsDeps = [ -- See Note [Updating flag description in the User's Guide] -- See Note [Supporting CLI completion] depFlagSpecOp' "th" LangExt.TemplateHaskell checkTemplateHaskellOk (deprecatedForExtension "TemplateHaskell"), depFlagSpec' "fi" LangExt.ForeignFunctionInterface (deprecatedForExtension "ForeignFunctionInterface"), depFlagSpec' "ffi" LangExt.ForeignFunctionInterface (deprecatedForExtension "ForeignFunctionInterface"), depFlagSpec' "arrows" LangExt.Arrows (deprecatedForExtension "Arrows"), depFlagSpec' "implicit-prelude" LangExt.ImplicitPrelude (deprecatedForExtension "ImplicitPrelude"), depFlagSpec' "bang-patterns" LangExt.BangPatterns (deprecatedForExtension "BangPatterns"), depFlagSpec' "monomorphism-restriction" LangExt.MonomorphismRestriction (deprecatedForExtension "MonomorphismRestriction"), depFlagSpec' "mono-pat-binds" LangExt.MonoPatBinds (deprecatedForExtension "MonoPatBinds"), depFlagSpec' "extended-default-rules" LangExt.ExtendedDefaultRules (deprecatedForExtension "ExtendedDefaultRules"), depFlagSpec' "implicit-params" LangExt.ImplicitParams (deprecatedForExtension "ImplicitParams"), depFlagSpec' "scoped-type-variables" LangExt.ScopedTypeVariables (deprecatedForExtension "ScopedTypeVariables"), depFlagSpec' "allow-overlapping-instances" LangExt.OverlappingInstances (deprecatedForExtension "OverlappingInstances"), depFlagSpec' "allow-undecidable-instances" LangExt.UndecidableInstances (deprecatedForExtension "UndecidableInstances"), depFlagSpec' "allow-incoherent-instances" LangExt.IncoherentInstances (deprecatedForExtension "IncoherentInstances") ] supportedLanguages :: [String] supportedLanguages = map (flagSpecName . snd) languageFlagsDeps supportedLanguageOverlays :: [String] supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps supportedExtensions :: PlatformMini -> [String] supportedExtensions targetPlatformMini = concatMap toFlagSpecNamePair xFlags where toFlagSpecNamePair flg -- IMPORTANT! Make sure that `ghc --supported-extensions` omits -- "TemplateHaskell"/"QuasiQuotes" when it's known not to work out of the -- box. See also GHC #11102 and #16331 for more details about -- the rationale | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell = [noName] | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes = [noName] | otherwise = [name, noName] where isAIX = platformMini_os targetPlatformMini == OSAIX noName = "No" ++ name name = flagSpecName flg supportedLanguagesAndExtensions :: PlatformMini -> [String] supportedLanguagesAndExtensions targetPlatformMini = supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions targetPlatformMini -- | These -X flags cannot be reversed with -XNo languageFlagsDeps :: [(Deprecation, FlagSpec Language)] languageFlagsDeps = [ flagSpec "Haskell98" Haskell98, flagSpec "Haskell2010" Haskell2010 ] -- | These -X flags cannot be reversed with -XNo -- They are used to place hard requirements on what GHC Haskell language -- features can be used. safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)] safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe] where mkF flag = flagSpec (show flag) flag -- | These -X flags can all be reversed with -XNo xFlags :: [FlagSpec LangExt.Extension] xFlags = map snd xFlagsDeps xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] xFlagsDeps = [ -- See Note [Updating flag description in the User's Guide] -- See Note [Supporting CLI completion] -- See Note [Adding a language extension] -- Please keep the list of flags below sorted alphabetically flagSpec "AllowAmbiguousTypes" LangExt.AllowAmbiguousTypes, flagSpec "AlternativeLayoutRule" LangExt.AlternativeLayoutRule, flagSpec "AlternativeLayoutRuleTransitional" LangExt.AlternativeLayoutRuleTransitional, flagSpec "Arrows" LangExt.Arrows, depFlagSpecCond "AutoDeriveTypeable" LangExt.AutoDeriveTypeable id ("Typeable instances are created automatically " ++ "for all types since GHC 8.2."), flagSpec "BangPatterns" LangExt.BangPatterns, flagSpec "BinaryLiterals" LangExt.BinaryLiterals, flagSpec "CApiFFI" LangExt.CApiFFI, flagSpec "CPP" LangExt.Cpp, flagSpec "CUSKs" LangExt.CUSKs, flagSpec "ConstrainedClassMethods" LangExt.ConstrainedClassMethods, flagSpec "ConstraintKinds" LangExt.ConstraintKinds, flagSpec "DataKinds" LangExt.DataKinds, depFlagSpecCond "DatatypeContexts" LangExt.DatatypeContexts id ("It was widely considered a misfeature, " ++ "and has been removed from the Haskell language."), flagSpec "DefaultSignatures" LangExt.DefaultSignatures, flagSpec "DeriveAnyClass" LangExt.DeriveAnyClass, flagSpec "DeriveDataTypeable" LangExt.DeriveDataTypeable, flagSpec "DeriveFoldable" LangExt.DeriveFoldable, flagSpec "DeriveFunctor" LangExt.DeriveFunctor, flagSpec "DeriveGeneric" LangExt.DeriveGeneric, flagSpec "DeriveLift" LangExt.DeriveLift, flagSpec "DeriveTraversable" LangExt.DeriveTraversable, flagSpec "DerivingStrategies" LangExt.DerivingStrategies, flagSpec "DerivingVia" LangExt.DerivingVia, flagSpec "DisambiguateRecordFields" LangExt.DisambiguateRecordFields, flagSpec "DoAndIfThenElse" LangExt.DoAndIfThenElse, flagSpec "BlockArguments" LangExt.BlockArguments, depFlagSpec' "DoRec" LangExt.RecursiveDo (deprecatedForExtension "RecursiveDo"), flagSpec "DuplicateRecordFields" LangExt.DuplicateRecordFields, flagSpec "EmptyCase" LangExt.EmptyCase, flagSpec "EmptyDataDecls" LangExt.EmptyDataDecls, flagSpec "EmptyDataDeriving" LangExt.EmptyDataDeriving, flagSpec "ExistentialQuantification" LangExt.ExistentialQuantification, flagSpec "ExplicitForAll" LangExt.ExplicitForAll, flagSpec "ExplicitNamespaces" LangExt.ExplicitNamespaces, flagSpec "ExtendedDefaultRules" LangExt.ExtendedDefaultRules, flagSpec "FlexibleContexts" LangExt.FlexibleContexts, flagSpec "FlexibleInstances" LangExt.FlexibleInstances, flagSpec "ForeignFunctionInterface" LangExt.ForeignFunctionInterface, flagSpec "FunctionalDependencies" LangExt.FunctionalDependencies, flagSpec "GADTSyntax" LangExt.GADTSyntax, flagSpec "GADTs" LangExt.GADTs, flagSpec "GHCForeignImportPrim" LangExt.GHCForeignImportPrim, flagSpec' "GeneralizedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving setGenDeriving, flagSpec' "GeneralisedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving setGenDeriving, flagSpec "ImplicitParams" LangExt.ImplicitParams, flagSpec "ImplicitPrelude" LangExt.ImplicitPrelude, flagSpec "ImportQualifiedPost" LangExt.ImportQualifiedPost, flagSpec "ImpredicativeTypes" LangExt.ImpredicativeTypes, flagSpec' "IncoherentInstances" LangExt.IncoherentInstances setIncoherentInsts, flagSpec "TypeFamilyDependencies" LangExt.TypeFamilyDependencies, flagSpec "InstanceSigs" LangExt.InstanceSigs, flagSpec "ApplicativeDo" LangExt.ApplicativeDo, flagSpec "InterruptibleFFI" LangExt.InterruptibleFFI, flagSpec "JavaScriptFFI" LangExt.JavaScriptFFI, flagSpec "KindSignatures" LangExt.KindSignatures, flagSpec "LambdaCase" LangExt.LambdaCase, flagSpec "LiberalTypeSynonyms" LangExt.LiberalTypeSynonyms, flagSpec "MagicHash" LangExt.MagicHash, flagSpec "MonadComprehensions" LangExt.MonadComprehensions, depFlagSpec "MonadFailDesugaring" LangExt.MonadFailDesugaring "MonadFailDesugaring is now the default behavior", flagSpec "MonoLocalBinds" LangExt.MonoLocalBinds, depFlagSpecCond "MonoPatBinds" LangExt.MonoPatBinds id "Experimental feature now removed; has no effect", flagSpec "MonomorphismRestriction" LangExt.MonomorphismRestriction, flagSpec "MultiParamTypeClasses" LangExt.MultiParamTypeClasses, flagSpec "MultiWayIf" LangExt.MultiWayIf, flagSpec "NumericUnderscores" LangExt.NumericUnderscores, flagSpec "NPlusKPatterns" LangExt.NPlusKPatterns, flagSpec "NamedFieldPuns" LangExt.RecordPuns, flagSpec "NamedWildCards" LangExt.NamedWildCards, flagSpec "NegativeLiterals" LangExt.NegativeLiterals, flagSpec "HexFloatLiterals" LangExt.HexFloatLiterals, flagSpec "NondecreasingIndentation" LangExt.NondecreasingIndentation, depFlagSpec' "NullaryTypeClasses" LangExt.NullaryTypeClasses (deprecatedForExtension "MultiParamTypeClasses"), flagSpec "NumDecimals" LangExt.NumDecimals, depFlagSpecOp "OverlappingInstances" LangExt.OverlappingInstances setOverlappingInsts "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS", flagSpec "OverloadedLabels" LangExt.OverloadedLabels, flagSpec "OverloadedLists" LangExt.OverloadedLists, flagSpec "OverloadedStrings" LangExt.OverloadedStrings, flagSpec "PackageImports" LangExt.PackageImports, flagSpec "ParallelArrays" LangExt.ParallelArrays, flagSpec "ParallelListComp" LangExt.ParallelListComp, flagSpec "PartialTypeSignatures" LangExt.PartialTypeSignatures, flagSpec "PatternGuards" LangExt.PatternGuards, depFlagSpec' "PatternSignatures" LangExt.ScopedTypeVariables (deprecatedForExtension "ScopedTypeVariables"), flagSpec "PatternSynonyms" LangExt.PatternSynonyms, flagSpec "PolyKinds" LangExt.PolyKinds, flagSpec "PolymorphicComponents" LangExt.RankNTypes, flagSpec "QuantifiedConstraints" LangExt.QuantifiedConstraints, flagSpec "PostfixOperators" LangExt.PostfixOperators, flagSpec "QuasiQuotes" LangExt.QuasiQuotes, flagSpec "Rank2Types" LangExt.RankNTypes, flagSpec "RankNTypes" LangExt.RankNTypes, flagSpec "RebindableSyntax" LangExt.RebindableSyntax, depFlagSpec' "RecordPuns" LangExt.RecordPuns (deprecatedForExtension "NamedFieldPuns"), flagSpec "RecordWildCards" LangExt.RecordWildCards, flagSpec "RecursiveDo" LangExt.RecursiveDo, flagSpec "RelaxedLayout" LangExt.RelaxedLayout, depFlagSpecCond "RelaxedPolyRec" LangExt.RelaxedPolyRec not "You can't turn off RelaxedPolyRec any more", flagSpec "RoleAnnotations" LangExt.RoleAnnotations, flagSpec "ScopedTypeVariables" LangExt.ScopedTypeVariables, flagSpec "StandaloneDeriving" LangExt.StandaloneDeriving, flagSpec "StarIsType" LangExt.StarIsType, flagSpec "StaticPointers" LangExt.StaticPointers, flagSpec "Strict" LangExt.Strict, flagSpec "StrictData" LangExt.StrictData, flagSpec' "TemplateHaskell" LangExt.TemplateHaskell checkTemplateHaskellOk, flagSpec "TemplateHaskellQuotes" LangExt.TemplateHaskellQuotes, flagSpec "StandaloneKindSignatures" LangExt.StandaloneKindSignatures, flagSpec "TraditionalRecordSyntax" LangExt.TraditionalRecordSyntax, flagSpec "TransformListComp" LangExt.TransformListComp, flagSpec "TupleSections" LangExt.TupleSections, flagSpec "TypeApplications" LangExt.TypeApplications, flagSpec "TypeInType" LangExt.TypeInType, flagSpec "TypeFamilies" LangExt.TypeFamilies, flagSpec "TypeOperators" LangExt.TypeOperators, flagSpec "TypeSynonymInstances" LangExt.TypeSynonymInstances, flagSpec "UnboxedTuples" LangExt.UnboxedTuples, flagSpec "UnboxedSums" LangExt.UnboxedSums, flagSpec "UndecidableInstances" LangExt.UndecidableInstances, flagSpec "UndecidableSuperClasses" LangExt.UndecidableSuperClasses, flagSpec "UnicodeSyntax" LangExt.UnicodeSyntax, flagSpec "UnliftedFFITypes" LangExt.UnliftedFFITypes, flagSpec "UnliftedNewtypes" LangExt.UnliftedNewtypes, flagSpec "ViewPatterns" LangExt.ViewPatterns ] defaultFlags :: Settings -> [GeneralFlag] defaultFlags settings -- See Note [Updating flag description in the User's Guide] = [ Opt_AutoLinkPackages, Opt_DiagnosticsShowCaret, Opt_EmbedManifest, Opt_FlatCache, Opt_GenManifest, Opt_GhciHistory, Opt_GhciSandbox, Opt_HelpfulErrors, Opt_KeepHiFiles, Opt_KeepOFiles, Opt_OmitYields, Opt_PrintBindContents, Opt_ProfCountEntries, Opt_RPath, Opt_SharedImplib, Opt_SimplPreInlining, Opt_VersionMacros ] ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] -- The default -O0 options ++ default_PIC platform ++ concatMap (wayGeneralFlags platform) (defaultWays settings) ++ validHoleFitDefaults where platform = sTargetPlatform settings -- | These are the default settings for the display and sorting of valid hole -- fits in typed-hole error messages. See Note [Valid hole fits include ...] -- in the TcHoleErrors module. validHoleFitDefaults :: [GeneralFlag] validHoleFitDefaults = [ Opt_ShowTypeAppOfHoleFits , Opt_ShowTypeOfHoleFits , Opt_ShowProvOfHoleFits , Opt_ShowMatchesOfHoleFits , Opt_ShowValidHoleFits , Opt_SortValidHoleFits , Opt_SortBySizeHoleFits , Opt_ShowHoleConstraints ] validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] validHoleFitsImpliedGFlags = [ (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) ] default_PIC :: Platform -> [GeneralFlag] default_PIC platform = case (platformOS platform, platformArch platform) of (OSDarwin, ArchX86_64) -> [Opt_PIC] (OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in -- OpenBSD since 5.3 release -- (1 May 2013) we need to -- always generate PIC. See -- #10597 for more -- information. _ -> [] -- 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) ] ++ validHoleFitsImpliedGFlags -- 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) -- Standalone kind signatures are a replacement for CUSKs. , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs) -- 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) ] -- Note [When is StarIsType enabled] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- The StarIsType extension determines whether to treat '*' as a regular type -- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType -- programs expect '*' to be synonymous with 'Type', so by default StarIsType is -- enabled. -- -- Programs that use TypeOperators might expect to repurpose '*' for -- multiplication or another binary operation, but making TypeOperators imply -- NoStarIsType caused too much breakage on Hackage. -- -- Note [Documenting optimisation flags] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- If you change the list of flags enabled for particular optimisation levels -- please remember to update the User's Guide. The relevant file is: -- -- docs/users_guide/using-optimisation.rst -- -- Make sure to note whether a flag is implied by -O0, -O or -O2. optLevelFlags :: [([Int], GeneralFlag)] optLevelFlags -- see Note [Documenting optimisation flags] = [ ([0,1,2], Opt_DoLambdaEtaExpansion) , ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0] , ([0,1,2], Opt_DmdTxDictSel) , ([0,1,2], Opt_LlvmTBAA) , ([0], Opt_IgnoreInterfacePragmas) , ([0], Opt_OmitInterfacePragmas) , ([1,2], Opt_CallArity) , ([1,2], Opt_Exitification) , ([1,2], Opt_CaseMerge) , ([1,2], Opt_CaseFolding) , ([1,2], Opt_CmmElimCommonBlocks) , ([2], Opt_AsmShortcutting) , ([1,2], Opt_CmmSink) , ([1,2], Opt_CSE) , ([1,2], Opt_StgCSE) , ([2], Opt_StgLiftLams) , ([1,2], Opt_EnableRewriteRules) -- Off for -O0; see Note [Scoping for Builtin rules] -- in PrelRules , ([1,2], Opt_FloatIn) , ([1,2], Opt_FullLaziness) , ([1,2], Opt_IgnoreAsserts) , ([1,2], Opt_Loopification) , ([1,2], Opt_CfgBlocklayout) -- Experimental , ([1,2], Opt_Specialise) , ([1,2], Opt_CrossModuleSpecialise) , ([1,2], Opt_Strictness) , ([1,2], Opt_UnboxSmallStrictFields) , ([1,2], Opt_CprAnal) , ([1,2], Opt_WorkerWrapper) , ([1,2], Opt_SolveConstantDicts) , ([1,2], Opt_NumConstantFolding) , ([2], Opt_LiberateCase) , ([2], Opt_SpecConstr) -- , ([2], Opt_RegsGraph) -- RegsGraph suffers performance regression. See #7679 -- , ([2], Opt_StaticArgumentTransformation) -- Static Argument Transformation needs investigation. See #9374 ] {- Note [Eta-reduction in -O0] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #11562 showed an example which tripped an ASSERT in CoreToStg; a function was marked as MayHaveCafRefs when in fact it obviously didn't. Reason was: * Eta reduction wasn't happening in the simplifier, but it was happening in CorePrep, on $fBla = MkDict (/\a. K a) * Result: rhsIsStatic told TidyPgm that $fBla might have CAF refs but the eta-reduced version (MkDict K) obviously doesn't Simple solution: just let the simplifier do eta-reduction even in -O0. After all, CorePrep does it unconditionally! Not a big deal, but removes an assertion failure. -} -- ----------------------------------------------------------------------------- -- Standard sets of warning options -- Note [Documenting warning flags] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- If you change the list of warning enabled by default -- please remember to update the User's Guide. The relevant file is: -- -- docs/users_guide/using-warnings.rst -- | Warning groups. -- -- As all warnings are in the Weverything set, it is ignored when -- displaying to the user which group a warning is in. warningGroups :: [(String, [WarningFlag])] warningGroups = [ ("compat", minusWcompatOpts) , ("unused-binds", unusedBindsFlags) , ("default", standardWarnings) , ("extra", minusWOpts) , ("all", minusWallOpts) , ("everything", minusWeverythingOpts) ] -- | Warning group hierarchies, where there is an explicit inclusion -- relation. -- -- Each inner list is a hierarchy of warning groups, ordered from -- smallest to largest, where each group is a superset of the one -- before it. -- -- Separating this from 'warningGroups' allows for multiple -- hierarchies with no inherent relation to be defined. -- -- The special-case Weverything group is not included. warningHierarchies :: [[String]] warningHierarchies = hierarchies ++ map (:[]) rest where hierarchies = [["default", "extra", "all"]] rest = filter (`notElem` "everything" : concat hierarchies) $ map fst warningGroups -- | Find the smallest group in every hierarchy which a warning -- belongs to, excluding Weverything. smallestGroups :: WarningFlag -> [String] smallestGroups flag = mapMaybe go warningHierarchies where -- Because each hierarchy is arranged from smallest to largest, -- the first group we find in a hierarchy which contains the flag -- is the smallest. go (group:rest) = fromMaybe (go rest) $ do flags <- lookup group warningGroups guard (flag `elem` flags) pure (Just group) go [] = Nothing -- | Warnings enabled unless specified otherwise standardWarnings :: [WarningFlag] standardWarnings -- see Note [Documenting warning flags] = [ Opt_WarnOverlappingPatterns, Opt_WarnWarningsDeprecations, Opt_WarnDeprecatedFlags, Opt_WarnDeferredTypeErrors, Opt_WarnTypedHoles, Opt_WarnDeferredOutOfScopeVariables, Opt_WarnPartialTypeSignatures, Opt_WarnUnrecognisedPragmas, Opt_WarnDuplicateExports, Opt_WarnDerivingDefaults, Opt_WarnOverflowedLiterals, Opt_WarnEmptyEnumerations, Opt_WarnMissingFields, Opt_WarnMissingMethods, Opt_WarnWrongDoBind, Opt_WarnUnsupportedCallingConventions, Opt_WarnDodgyForeignImports, Opt_WarnInlineRuleShadowing, Opt_WarnAlternativeLayoutRuleTransitional, Opt_WarnUnsupportedLlvmVersion, Opt_WarnMissedExtraSharedLib, Opt_WarnTabs, Opt_WarnUnrecognisedWarningFlags, Opt_WarnSimplifiableClassConstraints, Opt_WarnStarBinder, Opt_WarnInaccessibleCode, Opt_WarnSpaceAfterBang ] -- | Things you get with -W minusWOpts :: [WarningFlag] minusWOpts = standardWarnings ++ [ Opt_WarnUnusedTopBinds, Opt_WarnUnusedLocalBinds, Opt_WarnUnusedPatternBinds, Opt_WarnUnusedMatches, Opt_WarnUnusedForalls, Opt_WarnUnusedImports, Opt_WarnIncompletePatterns, Opt_WarnDodgyExports, Opt_WarnDodgyImports, Opt_WarnUnbangedStrictPatterns ] -- | Things you get with -Wall minusWallOpts :: [WarningFlag] minusWallOpts = minusWOpts ++ [ Opt_WarnTypeDefaults, Opt_WarnNameShadowing, Opt_WarnMissingSignatures, Opt_WarnHiShadows, Opt_WarnOrphans, Opt_WarnUnusedDoBind, Opt_WarnTrustworthySafe, Opt_WarnUntickedPromotedConstructors, Opt_WarnMissingPatternSynonymSignatures, Opt_WarnUnusedRecordWildcards, Opt_WarnRedundantRecordWildcards ] -- | Things you get with -Weverything, i.e. *all* known warnings flags minusWeverythingOpts :: [WarningFlag] minusWeverythingOpts = [ toEnum 0 .. ] -- | Things you get with -Wcompat. -- -- This is intended to group together warnings that will be enabled by default -- at some point in the future, so that library authors eager to make their -- code future compatible to fix issues before they even generate warnings. minusWcompatOpts :: [WarningFlag] minusWcompatOpts = [ Opt_WarnMissingMonadFailInstances , Opt_WarnSemigroup , Opt_WarnNonCanonicalMonoidInstances , Opt_WarnStarIsType , Opt_WarnCompatUnqualifiedImports ] enableUnusedBinds :: DynP () enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags disableUnusedBinds :: DynP () disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags -- Things you get with -Wunused-binds unusedBindsFlags :: [WarningFlag] unusedBindsFlags = [ Opt_WarnUnusedTopBinds , Opt_WarnUnusedLocalBinds , Opt_WarnUnusedPatternBinds ] enableGlasgowExts :: DynP () enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls mapM_ setExtensionFlag glasgowExtsFlags disableGlasgowExts :: DynP () disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls mapM_ unSetExtensionFlag glasgowExtsFlags -- Please keep what_glasgow_exts_does.rst up to date with this list glasgowExtsFlags :: [LangExt.Extension] glasgowExtsFlags = [ LangExt.ConstrainedClassMethods , LangExt.DeriveDataTypeable , LangExt.DeriveFoldable , LangExt.DeriveFunctor , LangExt.DeriveGeneric , LangExt.DeriveTraversable , LangExt.EmptyDataDecls , LangExt.ExistentialQuantification , LangExt.ExplicitNamespaces , LangExt.FlexibleContexts , LangExt.FlexibleInstances , LangExt.ForeignFunctionInterface , LangExt.FunctionalDependencies , LangExt.GeneralizedNewtypeDeriving , LangExt.ImplicitParams , LangExt.KindSignatures , LangExt.LiberalTypeSynonyms , LangExt.MagicHash , LangExt.MultiParamTypeClasses , LangExt.ParallelListComp , LangExt.PatternGuards , LangExt.PostfixOperators , LangExt.RankNTypes , LangExt.RecursiveDo , LangExt.ScopedTypeVariables , LangExt.StandaloneDeriving , LangExt.TypeOperators , LangExt.TypeSynonymInstances , LangExt.UnboxedTuples , LangExt.UnicodeSyntax , LangExt.UnliftedFFITypes ] foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt -- | Was the runtime system built with profiling enabled? rtsIsProfiled :: Bool rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 -- Consult the RTS to find whether GHC itself has been built with -- dynamic linking. This can't be statically known at compile-time, -- because we build both the static and dynamic versions together with -- -dynamic-too. foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO CInt dynamicGhc :: Bool dynamicGhc = unsafeDupablePerformIO rtsIsDynamicIO /= 0 setWarnSafe :: Bool -> DynP () setWarnSafe True = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l }) setWarnSafe False = return () setWarnUnsafe :: Bool -> DynP () setWarnUnsafe True = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l }) setWarnUnsafe False = return () setPackageTrust :: DynP () setPackageTrust = do setGeneralFlag Opt_PackageTrust l <- getCurLoc upd $ \d -> d { pkgTrustOnLoc = l } setGenDeriving :: TurnOnFlag -> DynP () setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) setGenDeriving False = return () setOverlappingInsts :: TurnOnFlag -> DynP () setOverlappingInsts False = return () setOverlappingInsts True = do l <- getCurLoc upd (\d -> d { overlapInstLoc = l }) setIncoherentInsts :: TurnOnFlag -> DynP () setIncoherentInsts False = return () setIncoherentInsts True = do l <- getCurLoc upd (\d -> d { incoherentOnLoc = l }) checkTemplateHaskellOk :: TurnOnFlag -> DynP () checkTemplateHaskellOk _turn_on = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l }) {- ********************************************************************** %* * DynFlags constructors %* * %********************************************************************* -} type DynP = EwM (CmdLineP DynFlags) upd :: (DynFlags -> DynFlags) -> DynP () upd f = liftEwM (do dflags <- getCmdLineState putCmdLineState $! f dflags) updM :: (DynFlags -> DynP DynFlags) -> DynP () updM f = do dflags <- liftEwM getCmdLineState dflags' <- f dflags liftEwM $ putCmdLineState $! dflags' --------------- Constructor functions for OptKind ----------------- noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) noArg fn = NoArg (upd fn) noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) noArgM fn = NoArg (updM fn) hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) hasArg fn = HasArg (upd . fn) sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) sepArg fn = SepArg (upd . fn) intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) intSuffix fn = IntSuffix (\n -> upd (fn n)) intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) intSuffixM fn = IntSuffix (\n -> updM (fn n)) floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) floatSuffix fn = FloatSuffix (\n -> upd (fn n)) optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags) setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) -------------------------- addWay :: Way -> DynP () addWay w = upd (addWay' w) addWay' :: Way -> DynFlags -> DynFlags addWay' w dflags0 = let platform = targetPlatform dflags0 dflags1 = dflags0 { ways = w : ways dflags0 } dflags2 = foldr setGeneralFlag' dflags1 (wayGeneralFlags platform w) dflags3 = foldr unSetGeneralFlag' dflags2 (wayUnsetGeneralFlags platform w) in dflags3 removeWayDyn :: DynP () removeWayDyn = upd (\dfs -> dfs { ways = filter (WayDyn /=) (ways dfs) }) -------------------------- setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP () setGeneralFlag f = upd (setGeneralFlag' f) unSetGeneralFlag f = upd (unSetGeneralFlag' f) setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps where deps = [ if turn_on then setGeneralFlag' d else unSetGeneralFlag' d | (f', turn_on, d) <- impliedGFlags, f' == f ] -- When you set f, set the ones it implies -- NB: use setGeneralFlag recursively, in case the implied flags -- implies further flags unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps where deps = [ if turn_on then setGeneralFlag' d else unSetGeneralFlag' d | (f', turn_on, d) <- impliedOffGFlags, f' == f ] -- In general, when you un-set f, we don't un-set the things it implies. -- There are however some exceptions, e.g., -fno-strictness implies -- -fno-worker-wrapper. -- -- NB: use unSetGeneralFlag' recursively, in case the implied off flags -- imply further flags. -------------------------- setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () setWarningFlag f = upd (\dfs -> wopt_set dfs f) unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP () setFatalWarningFlag f = upd (\dfs -> wopt_set_fatal dfs f) unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f) setWErrorFlag :: WarningFlag -> DynP () setWErrorFlag flag = do { setWarningFlag flag ; setFatalWarningFlag flag } -------------------------- setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP () setExtensionFlag f = upd (setExtensionFlag' f) unSetExtensionFlag f = upd (unSetExtensionFlag' f) setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps where deps = [ if turn_on then setExtensionFlag' d else unSetExtensionFlag' d | (f', turn_on, d) <- impliedXFlags, f' == f ] -- When you set f, set the ones it implies -- NB: use setExtensionFlag recursively, in case the implied flags -- implies further flags unSetExtensionFlag' f dflags = xopt_unset dflags f -- When you un-set f, however, we don't un-set the things it implies -- (except for -fno-glasgow-exts, which is treated specially) -------------------------- alterFileSettings :: (FileSettings -> FileSettings) -> DynFlags -> DynFlags alterFileSettings f dynFlags = dynFlags { fileSettings = f (fileSettings dynFlags) } alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } -------------------------- setDumpFlag' :: DumpFlag -> DynP () setDumpFlag' dump_flag = do upd (\dfs -> dopt_set dfs dump_flag) when want_recomp forceRecompile where -- Certain dumpy-things are really interested in what's going -- on during recompilation checking, so in those cases we -- don't want to turn it off. want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace, Opt_D_dump_hi_diffs, Opt_D_no_debug_output] forceRecompile :: DynP () -- Whenver we -ddump, force recompilation (by switching off the -- recompilation checker), else you don't see the dump! However, -- don't switch it off in --make mode, else *everything* gets -- recompiled which probably isn't what you want forceRecompile = do dfs <- liftEwM getCmdLineState when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp) where force_recomp dfs = isOneShot (ghcMode dfs) setVerboseCore2Core :: DynP () setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core setVerbosity :: Maybe Int -> DynP () setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) setDebugLevel :: Maybe Int -> DynP () setDebugLevel mb_n = upd (\dfs -> dfs{ debugLevel = mb_n `orElse` 2 }) data PkgConfRef = GlobalPkgConf | UserPkgConf | PkgConfFile FilePath deriving Eq addPkgConfRef :: PkgConfRef -> DynP () addPkgConfRef p = upd $ \s -> s { packageDBFlags = PackageDB p : packageDBFlags s } removeUserPkgConf :: DynP () removeUserPkgConf = upd $ \s -> s { packageDBFlags = NoUserPackageDB : packageDBFlags s } removeGlobalPkgConf :: DynP () removeGlobalPkgConf = upd $ \s -> s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s } clearPkgConf :: DynP () clearPkgConf = upd $ \s -> s { packageDBFlags = ClearPackageDBs : packageDBFlags s } parsePackageFlag :: String -- the flag -> ReadP PackageArg -- type of argument -> String -- string to parse -> PackageFlag parsePackageFlag flag arg_parse str = case filter ((=="").snd) (readP_to_S parse str) of [(r, "")] -> r _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str) where doc = flag ++ " " ++ str parse = do pkg_arg <- tok arg_parse let mk_expose = ExposePackage doc pkg_arg ( do _ <- tok $ string "with" fmap (mk_expose . ModRenaming True) parseRns <++ fmap (mk_expose . ModRenaming False) parseRns <++ return (mk_expose (ModRenaming True []))) parseRns = do _ <- tok $ R.char '(' rns <- tok $ sepBy parseItem (tok $ R.char ',') _ <- tok $ R.char ')' return rns parseItem = do orig <- tok $ parseModuleName (do _ <- tok $ string "as" new <- tok $ parseModuleName return (orig, new) +++ return (orig, orig)) tok m = m >>= \x -> skipSpaces >> return x exposePackage, exposePackageId, hidePackage, exposePluginPackage, exposePluginPackageId, ignorePackage, trustPackage, distrustPackage :: String -> DynP () exposePackage p = upd (exposePackage' p) exposePackageId p = upd (\s -> s{ packageFlags = parsePackageFlag "-package-id" parseUnitIdArg p : packageFlags s }) exposePluginPackage p = upd (\s -> s{ pluginPackageFlags = parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s }) exposePluginPackageId p = upd (\s -> s{ pluginPackageFlags = parsePackageFlag "-plugin-package-id" parseUnitIdArg p : pluginPackageFlags s }) hidePackage p = upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) ignorePackage p = upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s }) trustPackage p = exposePackage p >> -- both trust and distrust also expose a package upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s }) distrustPackage p = exposePackage p >> upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s }) exposePackage' :: String -> DynFlags -> DynFlags exposePackage' p dflags = dflags { packageFlags = parsePackageFlag "-package" parsePackageArg p : packageFlags dflags } parsePackageArg :: ReadP PackageArg parsePackageArg = fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_.")) parseUnitIdArg :: ReadP PackageArg parseUnitIdArg = fmap UnitIdArg parseUnitId setUnitId :: String -> DynFlags -> DynFlags setUnitId p d = d { thisInstalledUnitId = stringToInstalledUnitId p } -- | Given a 'ModuleName' of a signature in the home library, find -- out how it is instantiated. E.g., the canonical form of -- A in @p[A=q[]:A]@ is @q[]:A@. canonicalizeHomeModule :: DynFlags -> ModuleName -> Module canonicalizeHomeModule dflags mod_name = case lookup mod_name (thisUnitIdInsts dflags) of Nothing -> mkModule (thisPackage dflags) mod_name Just mod -> mod canonicalizeModuleIfHome :: DynFlags -> Module -> Module canonicalizeModuleIfHome dflags mod = if thisPackage dflags == moduleUnitId mod then canonicalizeHomeModule dflags (moduleName mod) else mod -- If we're linking a binary, then only targets that produce object -- code are allowed (requests for other target types are ignored). setTarget :: HscTarget -> DynP () setTarget l = upd $ \ dfs -> if ghcLink dfs /= LinkBinary || isObjectTarget l then dfs{ hscTarget = l } else dfs -- Changes the target only if we're compiling object code. This is -- used by -fasm and -fllvm, which switch from one to the other, but -- not from bytecode to object-code. The idea is that -fasm/-fllvm -- can be safely used in an OPTIONS_GHC pragma. setObjTarget :: HscTarget -> DynP () setObjTarget l = updM set where set dflags | isObjectTarget (hscTarget dflags) = return $ dflags { hscTarget = l } | otherwise = return dflags setOptLevel :: Int -> DynFlags -> DynP DynFlags setOptLevel n dflags = return (updOptLevel n dflags) checkOptLevel :: Int -> DynFlags -> Either String DynFlags checkOptLevel n dflags | hscTarget dflags == HscInterpreted && n > 0 = Left "-O conflicts with --interactive; -O ignored." | otherwise = Right dflags setMainIs :: String -> DynP () setMainIs arg | not (null main_fn) && isLower (head main_fn) -- The arg looked like "Foo.Bar.baz" = upd $ \d -> d { mainFunIs = Just main_fn, mainModIs = mkModule mainUnitId (mkModuleName main_mod) } | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" = upd $ \d -> d { mainModIs = mkModule mainUnitId (mkModuleName arg) } | otherwise -- The arg looked like "baz" = upd $ \d -> d { mainFunIs = Just arg } where (main_mod, main_fn) = splitLongestPrefix arg (== '.') addLdInputs :: Option -> DynFlags -> DynFlags addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]} -- ----------------------------------------------------------------------------- -- Load dynflags from environment files. setFlagsFromEnvFile :: FilePath -> String -> DynP () setFlagsFromEnvFile envfile content = do setGeneralFlag Opt_HideAllPackages parseEnvFile envfile content parseEnvFile :: FilePath -> String -> DynP () parseEnvFile envfile = mapM_ parseEntry . lines where parseEntry str = case words str of ("package-db": _) -> addPkgConfRef (PkgConfFile (envdir db)) -- relative package dbs are interpreted relative to the env file where envdir = takeDirectory envfile db = drop 11 str ["clear-package-db"] -> clearPkgConf ["global-package-db"] -> addPkgConfRef GlobalPkgConf ["user-package-db"] -> addPkgConfRef UserPkgConf ["package-id", pkgid] -> exposePackageId pkgid (('-':'-':_):_) -> return () -- comments -- and the original syntax introduced in 7.10: [pkgid] -> exposePackageId pkgid [] -> return () _ -> throwGhcException $ CmdLineError $ "Can't parse environment file entry: " ++ envfile ++ ": " ++ str ----------------------------------------------------------------------------- -- Paths & Libraries addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP () -- -i on its own deletes the import paths addImportPath "" = upd (\s -> s{importPaths = []}) addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) addLibraryPath p = upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) addIncludePath p = upd (\s -> s{includePaths = addGlobalInclude (includePaths s) (splitPathList p)}) addFrameworkPath p = upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p}) #if !defined(mingw32_HOST_OS) split_marker :: Char split_marker = ':' -- not configurable (ToDo) #endif splitPathList :: String -> [String] splitPathList s = filter notNull (splitUp s) -- empty paths are ignored: there might be a trailing -- ':' in the initial list, for example. Empty paths can -- cause confusion when they are translated into -I options -- for passing to gcc. where #if !defined(mingw32_HOST_OS) splitUp xs = split split_marker xs #else -- Windows: 'hybrid' support for DOS-style paths in directory lists. -- -- That is, if "foo:bar:baz" is used, this interpreted as -- consisting of three entries, 'foo', 'bar', 'baz'. -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar" -- -- Notice that no attempt is made to fully replace the 'standard' -- split marker ':' with the Windows / DOS one, ';'. The reason being -- that this will cause too much breakage for users & ':' will -- work fine even with DOS paths, if you're not insisting on being silly. -- So, use either. splitUp [] = [] splitUp (x:':':div:xs) | div `elem` dir_markers = ((x:':':div:p): splitUp rs) where (p,rs) = findNextPath xs -- we used to check for existence of the path here, but that -- required the IO monad to be threaded through the command-line -- parser which is quite inconvenient. The splitUp xs = cons p (splitUp rs) where (p,rs) = findNextPath xs cons "" xs = xs cons x xs = x:xs -- will be called either when we've consumed nought or the -- ":/" part of a DOS path, so splitting is just a Q of -- finding the next split marker. findNextPath xs = case break (`elem` split_markers) xs of (p, _:ds) -> (p, ds) (p, xs) -> (p, xs) split_markers :: [Char] split_markers = [':', ';'] dir_markers :: [Char] dir_markers = ['/', '\\'] #endif -- ----------------------------------------------------------------------------- -- tmpDir, where we store temporary files. setTmpDir :: FilePath -> DynFlags -> DynFlags setTmpDir dir = alterFileSettings $ \s -> s { fileSettings_tmpDir = normalise dir } -- we used to fix /cygdrive/c/.. on Windows, but this doesn't -- seem necessary now --SDM 7/2/2008 ----------------------------------------------------------------------------- -- RTS opts setRtsOpts :: String -> DynP () setRtsOpts arg = upd $ \ d -> d {rtsOpts = Just arg} setRtsOptsEnabled :: RtsOptsEnabled -> DynP () setRtsOptsEnabled arg = upd $ \ d -> d {rtsOptsEnabled = arg} ----------------------------------------------------------------------------- -- Hpc stuff setOptHpcDir :: String -> DynP () setOptHpcDir arg = upd $ \ d -> d {hpcDir = arg} ----------------------------------------------------------------------------- -- Via-C compilation stuff -- There are some options that we need to pass to gcc when compiling -- Haskell code via C, but are only supported by recent versions of -- gcc. The configure script decides which of these options we need, -- and puts them in the "settings" file in $topdir. The advantage of -- having these in a separate file is that the file can be created at -- install-time depending on the available gcc version, and even -- re-generated later if gcc is upgraded. -- -- The options below are not dependent on the version of gcc, only the -- platform. picCCOpts :: DynFlags -> [String] picCCOpts dflags = pieOpts ++ picOpts where picOpts = case platformOS (targetPlatform dflags) of OSDarwin -- Apple prefers to do things the other way round. -- PIC is on by default. -- -mdynamic-no-pic: -- Turn off PIC code generation. -- -fno-common: -- Don't generate "common" symbols - these are unwanted -- in dynamic libraries. | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"] | otherwise -> ["-mdynamic-no-pic"] OSMinGW32 -- no -fPIC for Windows | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"] | otherwise -> [] _ -- we need -fPIC for C files when we are compiling with -dynamic, -- otherwise things like stub.c files don't get compiled -- correctly. They need to reference data in the Haskell -- objects, but can't without -fPIC. See -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code | gopt Opt_PIC dflags || WayDyn `elem` ways dflags -> ["-fPIC", "-U__PIC__", "-D__PIC__"] -- gcc may be configured to have PIC on by default, let's be -- explicit here, see #15847 | otherwise -> ["-fno-PIC"] pieOpts | gopt Opt_PICExecutable dflags = ["-pie"] -- See Note [No PIE when linking] | toolSettings_ccSupportsNoPie (toolSettings dflags) = ["-no-pie"] | otherwise = [] {- Note [No PIE while linking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by default in their gcc builds. This is incompatible with -r as it implies that we are producing an executable. Consequently, we must manually pass -no-pie to gcc when joining object files or linking dynamic libraries. Unless, of course, the user has explicitly requested a PIE executable with -pie. See #12759. -} picPOpts :: DynFlags -> [String] picPOpts dflags | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"] | otherwise = [] -- ----------------------------------------------------------------------------- -- Compiler Info compilerInfo :: DynFlags -> [(String, String)] compilerInfo dflags = -- We always make "Project name" be first to keep parsing in -- other languages simple, i.e. when looking for other fields, -- you don't have to worry whether there is a leading '[' or not ("Project name", cProjectName) -- Next come the settings, so anything else can be overridden -- in the settings file (as "lookup" uses the first match for the -- key) : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags)) (rawSettings dflags) ++ [("Project version", projectVersion dflags), ("Project Git commit id", cProjectGitCommitId), ("Booter version", cBooterVersion), ("Stage", cStage), ("Build platform", cBuildPlatformString), ("Host platform", cHostPlatformString), ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), ("Object splitting supported", showBool False), ("Have native code generator", showBool $ platformMisc_ghcWithNativeCodeGen $ platformMisc dflags), -- Whether or not we support @-dynamic-too@ ("Support dynamic-too", showBool $ not isWindows), -- Whether or not we support the @-j@ flag with @--make@. ("Support parallel --make", "YES"), -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in -- installed package info. ("Support reexported-modules", "YES"), -- Whether or not we support extended @-package foo (Foo)@ syntax. ("Support thinning and renaming package flags", "YES"), -- Whether or not we support Backpack. ("Support Backpack", "YES"), -- If true, we require that the 'id' field in installed package info -- match what is passed to the @-this-unit-id@ flag for modules -- built in it ("Requires unified installed package IDs", "YES"), -- Whether or not we support the @-this-package-key@ flag. Prefer -- "Uses unit IDs" over it. ("Uses package keys", "YES"), -- Whether or not we support the @-this-unit-id@ flag ("Uses unit IDs", "YES"), -- Whether or not GHC compiles libraries as dynamic by default ("Dynamic by default", showBool $ dYNAMIC_BY_DEFAULT dflags), -- Whether or not GHC was compiled using -dynamic ("GHC Dynamic", showBool dynamicGhc), -- Whether or not GHC was compiled using -prof ("GHC Profiled", showBool rtsIsProfiled), ("Debug on", showBool debugIsOn), ("LibDir", topDir dflags), -- The path of the global package database used by GHC ("Global Package DB", systemPackageConfig dflags) ] where showBool True = "YES" showBool False = "NO" isWindows = platformOS (targetPlatform dflags) == OSMinGW32 expandDirectories :: FilePath -> Maybe FilePath -> String -> String expandDirectories topd mtoold = expandToolDir mtoold . expandTopDir topd -- Produced by deriveConstants #include "GHCConstantsHaskellWrappers.hs" bLOCK_SIZE_W :: DynFlags -> Int bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags wORD_SIZE_IN_BITS :: DynFlags -> Int wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8 wordAlignment :: DynFlags -> Alignment wordAlignment dflags = alignmentOf (wORD_SIZE dflags) tAG_MASK :: DynFlags -> Int tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 mAX_PTR_TAG :: DynFlags -> Int mAX_PTR_TAG = tAG_MASK -- Might be worth caching these in targetPlatform? tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: DynFlags -> Integer tARGET_MIN_INT dflags = case platformWordSize (targetPlatform dflags) of PW4 -> toInteger (minBound :: Int32) PW8 -> toInteger (minBound :: Int64) tARGET_MAX_INT dflags = case platformWordSize (targetPlatform dflags) of PW4 -> toInteger (maxBound :: Int32) PW8 -> toInteger (maxBound :: Int64) tARGET_MAX_WORD dflags = case platformWordSize (targetPlatform dflags) of PW4 -> toInteger (maxBound :: Word32) PW8 -> toInteger (maxBound :: Word64) {- ----------------------------------------------------------------------------- Note [DynFlags consistency] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are a number of number of DynFlags configurations which either do not make sense or lead to unimplemented or buggy codepaths in the compiler. makeDynFlagsConsistent is responsible for verifying the validity of a set of DynFlags, fixing any issues, and reporting them back to the caller. GHCi and -O --------------- When using optimization, the compiler can introduce several things (such as unboxed tuples) into the intermediate code, which GHCi later chokes on since the bytecode interpreter can't handle this (and while this is arguably a bug these aren't handled, there are no plans to fix it.) While the driver pipeline always checks for this particular erroneous combination when parsing flags, we also need to check when we update the flags; this is because API clients may parse flags but update the DynFlags afterwords, before finally running code inside a session (see T10052 and #10052). -} -- | Resolve any internal inconsistencies in a set of 'DynFlags'. -- Returns the consistent 'DynFlags' as well as a list of warnings -- to report to the user. makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Located String]) -- Whenever makeDynFlagsConsistent does anything, it starts over, to -- ensure that a later change doesn't invalidate an earlier check. -- Be careful not to introduce potential loops! makeDynFlagsConsistent dflags -- Disable -dynamic-too on Windows (#8228, #7134, #5987) | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags = let dflags' = gopt_unset dflags Opt_BuildDynamicToo warn = "-dynamic-too is not supported on Windows" in loop dflags' warn | hscTarget dflags == HscC && not (platformUnregisterised (targetPlatform dflags)) = if platformMisc_ghcWithNativeCodeGen $ platformMisc dflags then let dflags' = dflags { hscTarget = HscAsm } warn = "Compiler not unregisterised, so using native code generator rather than compiling via C" in loop dflags' warn else let dflags' = dflags { hscTarget = HscLlvm } warn = "Compiler not unregisterised, so using LLVM rather than compiling via C" in loop dflags' warn | gopt Opt_Hpc dflags && hscTarget dflags == HscInterpreted = let dflags' = gopt_unset dflags Opt_Hpc warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc." in loop dflags' warn | hscTarget dflags `elem` [HscAsm, HscLlvm] && platformUnregisterised (targetPlatform dflags) = loop (dflags { hscTarget = HscC }) "Compiler unregisterised, so compiling via C" | hscTarget dflags == HscAsm && not (platformMisc_ghcWithNativeCodeGen $ platformMisc dflags) = let dflags' = dflags { hscTarget = HscLlvm } warn = "No native code generator, so using LLVM" in loop dflags' warn | not (osElfTarget os) && gopt Opt_PIE dflags = loop (gopt_unset dflags Opt_PIE) "Position-independent only supported on ELF platforms" | os == OSDarwin && arch == ArchX86_64 && not (gopt Opt_PIC dflags) = loop (gopt_set dflags Opt_PIC) "Enabling -fPIC as it is always on for this platform" | Left err <- checkOptLevel (optLevel dflags) dflags = loop (updOptLevel 0 dflags) err | LinkInMemory <- ghcLink dflags , not (gopt Opt_ExternalInterpreter dflags) , rtsIsProfiled , isObjectTarget (hscTarget dflags) , WayProf `notElem` ways dflags = loop dflags{ways = WayProf : ways dflags} "Enabling -prof, because -fobject-code is enabled and GHCi is profiled" | otherwise = (dflags, []) where loc = mkGeneralSrcSpan (fsLit "when making flags consistent") loop updated_dflags warning = case makeDynFlagsConsistent updated_dflags of (dflags', ws) -> (dflags', L loc warning : ws) platform = targetPlatform dflags arch = platformArch platform os = platformOS platform -------------------------------------------------------------------------- -- Do not use unsafeGlobalDynFlags! -- -- unsafeGlobalDynFlags is a hack, necessary because we need to be able -- to show SDocs when tracing, but we don't always have DynFlags -- available. -- -- Do not use it if you can help it. You may get the wrong value, or this -- panic! -- | This is the value that 'unsafeGlobalDynFlags' takes before it is -- initialized. defaultGlobalDynFlags :: DynFlags defaultGlobalDynFlags = (defaultDynFlags settings llvmConfig) { verbosity = 2 } where settings = panic "v_unsafeGlobalDynFlags: settings not initialised" llvmConfig = panic "v_unsafeGlobalDynFlags: llvmConfig not initialised" #if GHC_STAGE < 2 GLOBAL_VAR(v_unsafeGlobalDynFlags, defaultGlobalDynFlags, DynFlags) #else SHARED_GLOBAL_VAR( v_unsafeGlobalDynFlags , getOrSetLibHSghcGlobalDynFlags , "getOrSetLibHSghcGlobalDynFlags" , defaultGlobalDynFlags , DynFlags ) #endif unsafeGlobalDynFlags :: DynFlags unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags setUnsafeGlobalDynFlags :: DynFlags -> IO () setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags -- ----------------------------------------------------------------------------- -- SSE and AVX -- TODO: Instead of using a separate predicate (i.e. isSse2Enabled) to -- check if SSE is enabled, we might have x86-64 imply the -msse2 -- flag. data SseVersion = SSE1 | SSE2 | SSE3 | SSE4 | SSE42 deriving (Eq, Ord) isSseEnabled :: DynFlags -> Bool isSseEnabled dflags = case platformArch (targetPlatform dflags) of ArchX86_64 -> True ArchX86 -> True _ -> False isSse2Enabled :: DynFlags -> Bool isSse2Enabled dflags = case platformArch (targetPlatform dflags) of -- We Assume SSE1 and SSE2 operations are available on both -- x86 and x86_64. Historically we didn't default to SSE2 and -- SSE1 on x86, which results in defacto nondeterminism for how -- rounding behaves in the associated x87 floating point instructions -- because variations in the spill/fpu stack placement of arguments for -- operations would change the precision and final result of what -- would otherwise be the same expressions with respect to single or -- double precision IEEE floating point computations. ArchX86_64 -> True ArchX86 -> True _ -> False isSse4_2Enabled :: DynFlags -> Bool isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42 isAvxEnabled :: DynFlags -> Bool isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags isAvx2Enabled :: DynFlags -> Bool isAvx2Enabled dflags = avx2 dflags || avx512f dflags isAvx512cdEnabled :: DynFlags -> Bool isAvx512cdEnabled dflags = avx512cd dflags isAvx512erEnabled :: DynFlags -> Bool isAvx512erEnabled dflags = avx512er dflags isAvx512fEnabled :: DynFlags -> Bool isAvx512fEnabled dflags = avx512f dflags isAvx512pfEnabled :: DynFlags -> Bool isAvx512pfEnabled dflags = avx512pf dflags -- ----------------------------------------------------------------------------- -- BMI2 data BmiVersion = BMI1 | BMI2 deriving (Eq, Ord) isBmiEnabled :: DynFlags -> Bool isBmiEnabled dflags = case platformArch (targetPlatform dflags) of ArchX86_64 -> bmiVersion dflags >= Just BMI1 ArchX86 -> bmiVersion dflags >= Just BMI1 _ -> False isBmi2Enabled :: DynFlags -> Bool isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of ArchX86_64 -> bmiVersion dflags >= Just BMI2 ArchX86 -> bmiVersion dflags >= Just BMI2 _ -> False -- ----------------------------------------------------------------------------- -- Linker/compiler information -- LinkerInfo contains any extra options needed by the system linker. data LinkerInfo = GnuLD [Option] | GnuGold [Option] | LlvmLLD [Option] | DarwinLD [Option] | SolarisLD [Option] | AixLD [Option] | UnknownLD deriving Eq -- CompilerInfo tells us which C compiler we're using data CompilerInfo = GCC | Clang | AppleClang | AppleClang51 | UnknownCC deriving Eq -- ----------------------------------------------------------------------------- -- RTS hooks -- Convert sizes like "3.5M" into integers decodeSize :: String -> Integer decodeSize str | c == "" = truncate n | c == "K" || c == "k" = truncate (n * 1000) | c == "M" || c == "m" = truncate (n * 1000 * 1000) | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) | otherwise = throwGhcException (CmdLineError ("can't decode size: " ++ str)) where (m, c) = span pred str n = readRational m pred c = isDigit c || c == '.' foreign import ccall unsafe "ghc_lib_parser_setHeapSize" setHeapSize :: Int -> IO () foreign import ccall unsafe "ghc_lib_parser_enableTimingStats" enableTimingStats :: IO () -- ----------------------------------------------------------------------------- -- Types for managing temporary files. -- -- these are here because FilesToClean is used in DynFlags -- | A collection of files that must be deleted before ghc exits. -- The current collection -- is stored in an IORef in DynFlags, 'filesToClean'. data FilesToClean = FilesToClean { ftcGhcSession :: !(Set FilePath), -- ^ Files that will be deleted at the end of runGhc(T) ftcCurrentModule :: !(Set FilePath) -- ^ Files that will be deleted the next time -- 'FileCleanup.cleanCurrentModuleTempFiles' is called, or otherwise at the -- end of the session. } -- | An empty FilesToClean emptyFilesToClean :: FilesToClean emptyFilesToClean = FilesToClean Set.empty Set.empty ghc-lib-parser-8.10.2.20200808/compiler/utils/Encoding.hs0000644000000000000000000003655313713635745020557 0ustar0000000000000000{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -O2 #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow, 1997-2006 -- -- Character encodings -- -- ----------------------------------------------------------------------------- module Encoding ( -- * UTF-8 utf8DecodeChar#, utf8PrevChar, utf8CharStart, utf8DecodeChar, utf8DecodeByteString, utf8DecodeStringLazy, utf8EncodeChar, utf8EncodeString, utf8EncodedLength, countUTF8Chars, -- * Z-encoding zEncodeString, zDecodeString, -- * Base62-encoding toBase62, toBase62Padded ) where import GhcPrelude import Foreign import Foreign.ForeignPtr.Unsafe import Data.Char import qualified Data.Char as Char import Numeric import GHC.IO import Data.ByteString (ByteString) import qualified Data.ByteString.Internal as BS import GHC.Exts -- ----------------------------------------------------------------------------- -- UTF-8 -- We can't write the decoder as efficiently as we'd like without -- resorting to unboxed extensions, unfortunately. I tried to write -- an IO version of this function, but GHC can't eliminate boxed -- results from an IO-returning function. -- -- We assume we can ignore overflow when parsing a multibyte character here. -- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences -- before decoding them (see StringBuffer.hs). {-# INLINE utf8DecodeChar# #-} utf8DecodeChar# :: Addr# -> (# Char#, Int# #) utf8DecodeChar# a# = let !ch0 = word2Int# (indexWord8OffAddr# a# 0#) in case () of _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #) | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) -> let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +# (ch1 -# 0x80#)), 2# #) | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) -> let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +# ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +# (ch2 -# 0x80#)), 3# #) | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) -> let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else let !ch3 = word2Int# (indexWord8OffAddr# a# 3#) in if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +# ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +# ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#) +# (ch3 -# 0x80#)), 4# #) | otherwise -> fail 1# where -- all invalid sequences end up here: fail :: Int# -> (# Char#, Int# #) fail nBytes# = (# '\0'#, nBytes# #) -- '\xFFFD' would be the usual replacement character, but -- that's a valid symbol in Haskell, so will result in a -- confusing parse error later on. Instead we use '\0' which -- will signal a lexer error immediately. utf8DecodeChar :: Ptr Word8 -> (Char, Int) utf8DecodeChar (Ptr a#) = case utf8DecodeChar# a# of (# c#, nBytes# #) -> ( C# c#, I# nBytes# ) -- UTF-8 is cleverly designed so that we can always figure out where -- the start of the current character is, given any position in a -- stream. This function finds the start of the previous character, -- assuming there *is* a previous character. utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8) utf8PrevChar p = utf8CharStart (p `plusPtr` (-1)) utf8CharStart :: Ptr Word8 -> IO (Ptr Word8) utf8CharStart p = go p where go p = do w <- peek p if w >= 0x80 && w < 0xC0 then go (p `plusPtr` (-1)) else return p utf8DecodeByteString :: ByteString -> [Char] utf8DecodeByteString (BS.PS ptr offset len) = utf8DecodeStringLazy ptr offset len utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char] utf8DecodeStringLazy fptr offset len = unsafeDupablePerformIO $ unpack start where !start = unsafeForeignPtrToPtr fptr `plusPtr` offset !end = start `plusPtr` len unpack p | p >= end = touchForeignPtr fptr >> return [] | otherwise = case utf8DecodeChar# (unPtr p) of (# c#, nBytes# #) -> do rest <- unsafeDupableInterleaveIO $ unpack (p `plusPtr#` nBytes#) return (C# c# : rest) countUTF8Chars :: Ptr Word8 -> Int -> IO Int countUTF8Chars ptr len = go ptr 0 where !end = ptr `plusPtr` len go p !n | p >= end = return n | otherwise = do case utf8DecodeChar# (unPtr p) of (# _, nBytes# #) -> go (p `plusPtr#` nBytes#) (n+1) unPtr :: Ptr a -> Addr# unPtr (Ptr a) = a plusPtr# :: Ptr a -> Int# -> Ptr a plusPtr# ptr nBytes# = ptr `plusPtr` (I# nBytes#) utf8EncodeChar :: Char -> Ptr Word8 -> IO (Ptr Word8) utf8EncodeChar c ptr = let x = ord c in case () of _ | x > 0 && x <= 0x007f -> do poke ptr (fromIntegral x) return (ptr `plusPtr` 1) -- NB. '\0' is encoded as '\xC0\x80', not '\0'. This is so that we -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8). | x <= 0x07ff -> do poke ptr (fromIntegral (0xC0 .|. ((x `shiftR` 6) .&. 0x1F))) pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x .&. 0x3F))) return (ptr `plusPtr` 2) | x <= 0xffff -> do poke ptr (fromIntegral (0xE0 .|. (x `shiftR` 12) .&. 0x0F)) pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x `shiftR` 6) .&. 0x3F)) pokeElemOff ptr 2 (fromIntegral (0x80 .|. (x .&. 0x3F))) return (ptr `plusPtr` 3) | otherwise -> do poke ptr (fromIntegral (0xF0 .|. (x `shiftR` 18))) pokeElemOff ptr 1 (fromIntegral (0x80 .|. ((x `shiftR` 12) .&. 0x3F))) pokeElemOff ptr 2 (fromIntegral (0x80 .|. ((x `shiftR` 6) .&. 0x3F))) pokeElemOff ptr 3 (fromIntegral (0x80 .|. (x .&. 0x3F))) return (ptr `plusPtr` 4) utf8EncodeString :: Ptr Word8 -> String -> IO () utf8EncodeString ptr str = go ptr str where go !_ [] = return () go ptr (c:cs) = do ptr' <- utf8EncodeChar c ptr go ptr' cs utf8EncodedLength :: String -> Int utf8EncodedLength str = go 0 str where go !n [] = n go n (c:cs) | ord c > 0 && ord c <= 0x007f = go (n+1) cs | ord c <= 0x07ff = go (n+2) cs | ord c <= 0xffff = go (n+3) cs | otherwise = go (n+4) cs -- ----------------------------------------------------------------------------- -- The Z-encoding {- This is the main name-encoding and decoding function. It encodes any string into a string that is acceptable as a C name. This is done right before we emit a symbol name into the compiled C or asm code. Z-encoding of strings is cached in the FastString interface, so we never encode the same string more than once. The basic encoding scheme is this. * Tuples (,,,) are coded as Z3T * Alphabetic characters (upper and lower) and digits all translate to themselves; except 'Z', which translates to 'ZZ' and 'z', which translates to 'zz' We need both so that we can preserve the variable/tycon distinction * Most other printable characters translate to 'zx' or 'Zx' for some alphabetic character x * The others translate as 'znnnU' where 'nnn' is the decimal number of the character Before After -------------------------- Trak Trak foo_wib foozuwib > zg >1 zg1 foo# foozh foo## foozhzh foo##1 foozhzh1 fooZ fooZZ :+ ZCzp () Z0T 0-tuple (,,,,) Z5T 5-tuple (# #) Z1H unboxed 1-tuple (note the space) (#,,,,#) Z5H unboxed 5-tuple (NB: There is no Z1T nor Z0H.) -} type UserString = String -- As the user typed it type EncodedString = String -- Encoded form zEncodeString :: UserString -> EncodedString zEncodeString cs = case maybe_tuple cs of Just n -> n -- Tuples go to Z2T etc Nothing -> go cs where go [] = [] go (c:cs) = encode_digit_ch c ++ go' cs go' [] = [] go' (c:cs) = encode_ch c ++ go' cs unencodedChar :: Char -> Bool -- True for chars that don't need encoding unencodedChar 'Z' = False unencodedChar 'z' = False unencodedChar c = c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z' || c >= '0' && c <= '9' -- If a digit is at the start of a symbol then we need to encode it. -- Otherwise package names like 9pH-0.1 give linker errors. encode_digit_ch :: Char -> EncodedString encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c encode_digit_ch c | otherwise = encode_ch c encode_ch :: Char -> EncodedString encode_ch c | unencodedChar c = [c] -- Common case first -- Constructors encode_ch '(' = "ZL" -- Needed for things like (,), and (->) encode_ch ')' = "ZR" -- For symmetry with ( encode_ch '[' = "ZM" encode_ch ']' = "ZN" encode_ch ':' = "ZC" encode_ch 'Z' = "ZZ" -- Variables encode_ch 'z' = "zz" encode_ch '&' = "za" encode_ch '|' = "zb" encode_ch '^' = "zc" encode_ch '$' = "zd" encode_ch '=' = "ze" encode_ch '>' = "zg" encode_ch '#' = "zh" encode_ch '.' = "zi" encode_ch '<' = "zl" encode_ch '-' = "zm" encode_ch '!' = "zn" encode_ch '+' = "zp" encode_ch '\'' = "zq" encode_ch '\\' = "zr" encode_ch '/' = "zs" encode_ch '*' = "zt" encode_ch '_' = "zu" encode_ch '%' = "zv" encode_ch c = encode_as_unicode_char c encode_as_unicode_char :: Char -> EncodedString encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str else '0':hex_str where hex_str = showHex (ord c) "U" -- ToDo: we could improve the encoding here in various ways. -- eg. strings of unicode characters come out as 'z1234Uz5678U', we -- could remove the 'U' in the middle (the 'z' works as a separator). zDecodeString :: EncodedString -> UserString zDecodeString [] = [] zDecodeString ('Z' : d : rest) | isDigit d = decode_tuple d rest | otherwise = decode_upper d : zDecodeString rest zDecodeString ('z' : d : rest) | isDigit d = decode_num_esc d rest | otherwise = decode_lower d : zDecodeString rest zDecodeString (c : rest) = c : zDecodeString rest decode_upper, decode_lower :: Char -> Char decode_upper 'L' = '(' decode_upper 'R' = ')' decode_upper 'M' = '[' decode_upper 'N' = ']' decode_upper 'C' = ':' decode_upper 'Z' = 'Z' decode_upper ch = {-pprTrace "decode_upper" (char ch)-} ch decode_lower 'z' = 'z' decode_lower 'a' = '&' decode_lower 'b' = '|' decode_lower 'c' = '^' decode_lower 'd' = '$' decode_lower 'e' = '=' decode_lower 'g' = '>' decode_lower 'h' = '#' decode_lower 'i' = '.' decode_lower 'l' = '<' decode_lower 'm' = '-' decode_lower 'n' = '!' decode_lower 'p' = '+' decode_lower 'q' = '\'' decode_lower 'r' = '\\' decode_lower 's' = '/' decode_lower 't' = '*' decode_lower 'u' = '_' decode_lower 'v' = '%' decode_lower ch = {-pprTrace "decode_lower" (char ch)-} ch -- Characters not having a specific code are coded as z224U (in hex) decode_num_esc :: Char -> EncodedString -> UserString decode_num_esc d rest = go (digitToInt d) rest where go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest go n ('U' : rest) = chr n : zDecodeString rest go n other = error ("decode_num_esc: " ++ show n ++ ' ':other) decode_tuple :: Char -> EncodedString -> UserString decode_tuple d rest = go (digitToInt d) rest where -- NB. recurse back to zDecodeString after decoding the tuple, because -- the tuple might be embedded in a longer name. go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest go 0 ('T':rest) = "()" ++ zDecodeString rest go n ('T':rest) = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest go 1 ('H':rest) = "(# #)" ++ zDecodeString rest go n ('H':rest) = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest go n other = error ("decode_tuple: " ++ show n ++ ' ':other) {- Tuples are encoded as Z3T or Z3H for 3-tuples or unboxed 3-tuples respectively. No other encoding starts Z * "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple) There are no unboxed 0-tuples. * "()" is the tycon for a boxed 0-tuple. There are no boxed 1-tuples. -} maybe_tuple :: UserString -> Maybe EncodedString maybe_tuple "(# #)" = Just("Z1H") maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H") _ -> Nothing maybe_tuple "()" = Just("Z0T") maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of (n, ')' : _) -> Just ('Z' : shows (n+1) "T") _ -> Nothing maybe_tuple _ = Nothing count_commas :: Int -> String -> (Int, String) count_commas n (',' : cs) = count_commas (n+1) cs count_commas n cs = (n,cs) {- ************************************************************************ * * Base 62 * * ************************************************************************ Note [Base 62 encoding 128-bit integers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Instead of base-62 encoding a single 128-bit integer (ceil(21.49) characters), we'll base-62 a pair of 64-bit integers (2 * ceil(10.75) characters). Luckily for us, it's the same number of characters! -} -------------------------------------------------------------------------- -- Base 62 -- The base-62 code is based off of 'locators' -- ((c) Operational Dynamics Consulting, BSD3 licensed) -- | Size of a 64-bit word when written as a base-62 string word64Base62Len :: Int word64Base62Len = 11 -- | Converts a 64-bit word into a base-62 string toBase62Padded :: Word64 -> String toBase62Padded w = pad ++ str where pad = replicate len '0' len = word64Base62Len - length str -- 11 == ceil(64 / lg 62) str = toBase62 w toBase62 :: Word64 -> String toBase62 w = showIntAtBase 62 represent w "" where represent :: Int -> Char represent x | x < 10 = Char.chr (48 + x) | x < 36 = Char.chr (65 + x - 10) | x < 62 = Char.chr (97 + x - 36) | otherwise = error "represent (base 62): impossible!" ghc-lib-parser-8.10.2.20200808/compiler/utils/EnumSet.hs0000644000000000000000000000152713713635745020402 0ustar0000000000000000-- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum' -- things. module EnumSet ( EnumSet , member , insert , delete , toList , fromList , empty ) where import GhcPrelude import qualified Data.IntSet as IntSet newtype EnumSet a = EnumSet IntSet.IntSet member :: Enum a => a -> EnumSet a -> Bool member x (EnumSet s) = IntSet.member (fromEnum x) s insert :: Enum a => a -> EnumSet a -> EnumSet a insert x (EnumSet s) = EnumSet $ IntSet.insert (fromEnum x) s delete :: Enum a => a -> EnumSet a -> EnumSet a delete x (EnumSet s) = EnumSet $ IntSet.delete (fromEnum x) s toList :: Enum a => EnumSet a -> [a] toList (EnumSet s) = map toEnum $ IntSet.toList s fromList :: Enum a => [a] -> EnumSet a fromList = EnumSet . IntSet.fromList . map fromEnum empty :: EnumSet a empty = EnumSet IntSet.empty ghc-lib-parser-8.10.2.20200808/compiler/main/ErrUtils.hs0000644000000000000000000010353513713635745020361 0ustar0000000000000000{- (c) The AQUA Project, Glasgow University, 1994-1998 \section[ErrsUtils]{Utilities for error reporting} -} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RecordWildCards #-} module ErrUtils ( -- * Basic types Validity(..), andValid, allValid, isValid, getInvalids, orValid, Severity(..), -- * Messages ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason, ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary, WarnMsg, MsgDoc, Messages, ErrorMessages, WarningMessages, unionMessages, errMsgSpan, errMsgContext, errorsFound, isEmptyMessages, isWarnMsgFatal, warningsToMessages, -- ** Formatting pprMessageBag, pprErrMsgBagWithLoc, pprLocErrMsg, printBagOfErrors, formatErrDoc, -- ** Construction emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning, mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, mkLongWarnMsg, -- * Utilities doIfSet, doIfSet_dyn, getCaretDiagnostic, -- * Dump files dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer, mkDumpDoc, dumpSDoc, dumpSDocForUser, dumpSDocWithStyle, -- * Issuing messages during compilation putMsg, printInfoForUser, printOutputForUser, logInfo, logOutput, errorMsg, warningMsg, fatalErrorMsg, fatalErrorMsg'', compilationProgressMsg, showPass, withTiming, withTimingSilent, withTimingD, withTimingSilentD, debugTraceMsg, ghcExit, prettyPrintGhcErrors, traceCmd ) where #include "GhclibHsVersions.h" import GhcPrelude import Bag import Exception import Outputable import Panic import qualified PprColour as Col import SrcLoc import DynFlags import FastString (unpackFS) import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) import Json import System.Directory import System.Exit ( ExitCode(..), exitWith ) import System.FilePath ( takeDirectory, () ) import Data.List import qualified Data.Set as Set import Data.IORef import Data.Maybe ( fromMaybe ) import Data.Ord import Data.Time import Debug.Trace import Control.Monad import Control.Monad.IO.Class import System.IO import System.IO.Error ( catchIOError ) import GHC.Conc ( getAllocationCounter ) import System.CPUTime ------------------------- type MsgDoc = SDoc ------------------------- data Validity = IsValid -- ^ Everything is fine | NotValid MsgDoc -- ^ A problem, and some indication of why isValid :: Validity -> Bool isValid IsValid = True isValid (NotValid {}) = False andValid :: Validity -> Validity -> Validity andValid IsValid v = v andValid v _ = v -- | If they aren't all valid, return the first allValid :: [Validity] -> Validity allValid [] = IsValid allValid (v : vs) = v `andValid` allValid vs getInvalids :: [Validity] -> [MsgDoc] getInvalids vs = [d | NotValid d <- vs] orValid :: Validity -> Validity -> Validity orValid IsValid _ = IsValid orValid _ v = v -- ----------------------------------------------------------------------------- -- Basic error messages: just render a message with a source location. type Messages = (WarningMessages, ErrorMessages) type WarningMessages = Bag WarnMsg type ErrorMessages = Bag ErrMsg unionMessages :: Messages -> Messages -> Messages unionMessages (warns1, errs1) (warns2, errs2) = (warns1 `unionBags` warns2, errs1 `unionBags` errs2) data ErrMsg = ErrMsg { errMsgSpan :: SrcSpan, errMsgContext :: PrintUnqualified, errMsgDoc :: ErrDoc, -- | This has the same text as errDocImportant . errMsgDoc. errMsgShortString :: String, errMsgSeverity :: Severity, errMsgReason :: WarnReason } -- The SrcSpan is used for sorting errors into line-number order -- | Categorise error msgs by their importance. This is so each section can -- be rendered visually distinct. See Note [Error report] for where these come -- from. data ErrDoc = ErrDoc { -- | Primary error msg. errDocImportant :: [MsgDoc], -- | Context e.g. \"In the second argument of ...\". errDocContext :: [MsgDoc], -- | Supplementary information, e.g. \"Relevant bindings include ...\". errDocSupplementary :: [MsgDoc] } errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc errDoc = ErrDoc type WarnMsg = ErrMsg data Severity = SevOutput | SevFatal | SevInteractive | SevDump -- ^ Log message intended for compiler developers -- No file/line/column stuff | SevInfo -- ^ Log messages intended for end users. -- No file/line/column stuff. | SevWarning | SevError -- ^ SevWarning and SevError are used for warnings and errors -- o The message has a file/line/column heading, -- plus "warning:" or "error:", -- added by mkLocMessags -- o Output is intended for end users deriving Show instance ToJson Severity where json s = JSString (show s) instance Show ErrMsg where show em = errMsgShortString em pprMessageBag :: Bag MsgDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) -- | Make an unannotated error message with location info. mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc mkLocMessage = mkLocMessageAnn Nothing -- | Make a possibly annotated error message with location info. mkLocMessageAnn :: Maybe String -- ^ optional annotation -> Severity -- ^ severity -> SrcSpan -- ^ location -> MsgDoc -- ^ message -> MsgDoc -- Always print the location, even if it is unhelpful. Error messages -- are supposed to be in a standard format, and one without a location -- would look strange. Better to say explicitly "". mkLocMessageAnn ann severity locn msg = sdocWithDynFlags $ \dflags -> let locn' = if gopt Opt_ErrorSpans dflags then ppr locn else ppr (srcSpanStart locn) sevColour = getSeverityColour severity (colScheme dflags) -- Add optional information optAnn = case ann of Nothing -> text "" Just i -> text " [" <> coloured sevColour (text i) <> text "]" -- Add prefixes, like Foo.hs:34: warning: -- header = locn' <> colon <+> coloured sevColour sevText <> optAnn in coloured (Col.sMessage (colScheme dflags)) (hang (coloured (Col.sHeader (colScheme dflags)) header) 4 msg) where sevText = case severity of SevWarning -> text "warning:" SevError -> text "error:" SevFatal -> text "fatal:" _ -> empty getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour getSeverityColour SevWarning = Col.sWarning getSeverityColour SevError = Col.sError getSeverityColour SevFatal = Col.sFatal getSeverityColour _ = const mempty getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty getCaretDiagnostic severity (RealSrcSpan span) = do caretDiagnostic <$> getSrcLine (srcSpanFile span) row where getSrcLine fn i = getLine i (unpackFS fn) `catchIOError` \_ -> pure Nothing getLine i fn = do -- StringBuffer has advantages over readFile: -- (a) no lazy IO, otherwise IO exceptions may occur in pure code -- (b) always UTF-8, rather than some system-dependent encoding -- (Haskell source code must be UTF-8 anyway) content <- hGetStringBuffer fn case atLine i content of Just at_line -> pure $ case lines (fix <$> lexemeToString at_line (len at_line)) of srcLine : _ -> Just srcLine _ -> Nothing _ -> pure Nothing -- allow user to visibly see that their code is incorrectly encoded -- (StringBuffer.nextChar uses \0 to represent undecodable characters) fix '\0' = '\xfffd' fix c = c row = srcSpanStartLine span rowStr = show row multiline = row /= srcSpanEndLine span caretDiagnostic Nothing = empty caretDiagnostic (Just srcLineWithNewline) = sdocWithDynFlags $ \ dflags -> let sevColour = getSeverityColour severity (colScheme dflags) marginColour = Col.sMargin (colScheme dflags) in coloured marginColour (text marginSpace) <> text ("\n") <> coloured marginColour (text marginRow) <> text (" " ++ srcLinePre) <> coloured sevColour (text srcLineSpan) <> text (srcLinePost ++ "\n") <> coloured marginColour (text marginSpace) <> coloured sevColour (text (" " ++ caretLine)) where -- expand tabs in a device-independent manner #13664 expandTabs tabWidth i s = case s of "" -> "" '\t' : cs -> replicate effectiveWidth ' ' ++ expandTabs tabWidth (i + effectiveWidth) cs c : cs -> c : expandTabs tabWidth (i + 1) cs where effectiveWidth = tabWidth - i `mod` tabWidth srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline) start = srcSpanStartCol span - 1 end | multiline = length srcLine | otherwise = srcSpanEndCol span - 1 width = max 1 (end - start) marginWidth = length rowStr marginSpace = replicate marginWidth ' ' ++ " |" marginRow = rowStr ++ " |" (srcLinePre, srcLineRest) = splitAt start srcLine (srcLineSpan, srcLinePost) = splitAt width srcLineRest caretEllipsis | multiline = "..." | otherwise = "" caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg makeIntoWarning reason err = err { errMsgSeverity = SevWarning , errMsgReason = reason } -- ----------------------------------------------------------------------------- -- Collecting up messages for later ordering and printing. mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg mk_err_msg dflags sev locn print_unqual doc = ErrMsg { errMsgSpan = locn , errMsgContext = print_unqual , errMsgDoc = doc , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc)) , errMsgSeverity = sev , errMsgReason = NoReason } mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg mkErrDoc dflags = mk_err_msg dflags SevError mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg -- ^ A long (multi-line) error message mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg -- ^ A short (one-line) error message mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg -- ^ Variant that doesn't care about qualified/unqualified names mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra]) mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] []) mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] []) mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra]) mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] []) mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] []) ---------------- emptyMessages :: Messages emptyMessages = (emptyBag, emptyBag) isEmptyMessages :: Messages -> Bool isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs errorsFound :: DynFlags -> Messages -> Bool errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) warningsToMessages :: DynFlags -> WarningMessages -> Messages warningsToMessages dflags = partitionBagWith $ \warn -> case isWarnMsgFatal dflags warn of Nothing -> Left warn Just err_reason -> Right warn{ errMsgSeverity = SevError , errMsgReason = ErrReason err_reason } printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () printBagOfErrors dflags bag_of_errors = sequence_ [ let style = mkErrStyle dflags unqual in putLogMsg dflags reason sev s style (formatErrDoc dflags doc) | ErrMsg { errMsgSpan = s, errMsgDoc = doc, errMsgSeverity = sev, errMsgReason = reason, errMsgContext = unqual } <- sortMsgBag (Just dflags) bag_of_errors ] formatErrDoc :: DynFlags -> ErrDoc -> SDoc formatErrDoc dflags (ErrDoc important context supplementary) = case msgs of [msg] -> vcat msg _ -> vcat $ map starred msgs where msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags)) [important, context, supplementary] starred = (bullet<+>) . vcat pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc] pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ] pprLocErrMsg :: ErrMsg -> SDoc pprLocErrMsg (ErrMsg { errMsgSpan = s , errMsgDoc = doc , errMsgSeverity = sev , errMsgContext = unqual }) = sdocWithDynFlags $ \dflags -> withPprStyle (mkErrStyle dflags unqual) $ mkLocMessage sev s (formatErrDoc dflags doc) sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg] sortMsgBag dflags = maybeLimit . sortBy (maybeFlip cmp) . bagToList where maybeFlip :: (a -> a -> b) -> (a -> a -> b) maybeFlip | fromMaybe False (fmap reverseErrors dflags) = flip | otherwise = id cmp = comparing errMsgSpan maybeLimit = case join (fmap maxErrors dflags) of Nothing -> id Just err_limit -> take err_limit ghcExit :: DynFlags -> Int -> IO () ghcExit dflags val | val == 0 = exitWith ExitSuccess | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n") exitWith (ExitFailure val) doIfSet :: Bool -> IO () -> IO () doIfSet flag action | flag = action | otherwise = return () doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO() doIfSet_dyn dflags flag action | gopt flag dflags = action | otherwise = return () -- ----------------------------------------------------------------------------- -- Dumping dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO () dumpIfSet dflags flag hdr doc | not flag = return () | otherwise = putLogMsg dflags NoReason SevDump noSrcSpan (defaultDumpStyle dflags) (mkDumpDoc hdr doc) -- | a wrapper around 'dumpSDoc'. -- First check whether the dump flag is set -- Do nothing if it is unset dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO () dumpIfSet_dyn dflags flag hdr doc = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc -- | a wrapper around 'dumpSDoc'. -- First check whether the dump flag is set -- Do nothing if it is unset -- -- Unlike 'dumpIfSet_dyn', -- has a printer argument but no header argument dumpIfSet_dyn_printer :: PrintUnqualified -> DynFlags -> DumpFlag -> SDoc -> IO () dumpIfSet_dyn_printer printer dflags flag doc = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc mkDumpDoc :: String -> SDoc -> SDoc mkDumpDoc hdr doc = vcat [blankLine, line <+> text hdr <+> line, doc, blankLine] where line = text (replicate 20 '=') -- | Run an action with the handle of a 'DumpFlag' if we are outputting to a -- file, otherwise 'Nothing'. withDumpFileHandle :: DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO () withDumpFileHandle dflags flag action = do let mFile = chooseDumpFile dflags flag case mFile of Just fileName -> do let gdref = generatedDumps dflags gd <- readIORef gdref let append = Set.member fileName gd mode = if append then AppendMode else WriteMode unless append $ writeIORef gdref (Set.insert fileName gd) createDirectoryIfMissing True (takeDirectory fileName) withFile fileName mode $ \handle -> do -- We do not want the dump file to be affected by -- environment variables, but instead to always use -- UTF8. See: -- https://gitlab.haskell.org/ghc/ghc/issues/10762 hSetEncoding handle utf8 action (Just handle) Nothing -> action Nothing dumpSDoc, dumpSDocForUser :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO () -- | A wrapper around 'dumpSDocWithStyle' which uses 'PprDump' style. dumpSDoc dflags print_unqual = dumpSDocWithStyle dump_style dflags where dump_style = mkDumpStyle dflags print_unqual -- | A wrapper around 'dumpSDocWithStyle' which uses 'PprUser' style. dumpSDocForUser dflags print_unqual = dumpSDocWithStyle user_style dflags where user_style = mkUserStyle dflags print_unqual AllTheWay -- | Write out a dump. -- If --dump-to-file is set then this goes to a file. -- otherwise emit to stdout. -- -- When @hdr@ is empty, we print in a more compact format (no separators and -- blank lines) -- -- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@ -- is used; it is not used to decide whether to dump the output dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO () dumpSDocWithStyle sty dflags flag hdr doc = withDumpFileHandle dflags flag writeDump where -- write dump to file writeDump (Just handle) = do doc' <- if null hdr then return doc else do t <- getCurrentTime let timeStamp = if (gopt Opt_SuppressTimestamps dflags) then empty else text (show t) let d = timeStamp $$ blankLine $$ doc return $ mkDumpDoc hdr d defaultLogActionHPrintDoc dflags handle doc' sty -- write the dump to stdout writeDump Nothing = do let (doc', severity) | null hdr = (doc, SevOutput) | otherwise = (mkDumpDoc hdr doc, SevDump) putLogMsg dflags NoReason severity noSrcSpan sty doc' -- | Choose where to put a dump file based on DynFlags -- chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath chooseDumpFile dflags flag | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file , Just prefix <- getPrefix = Just $ setDir (prefix ++ (beautifyDumpName flag)) | otherwise = Nothing where getPrefix -- dump file location is being forced -- by the --ddump-file-prefix flag. | Just prefix <- dumpPrefixForce dflags = Just prefix -- dump file location chosen by DriverPipeline.runPipeline | Just prefix <- dumpPrefix dflags = Just prefix -- we haven't got a place to put a dump file. | otherwise = Nothing setDir f = case dumpDir dflags of Just d -> d f Nothing -> f -- | Build a nice file name from name of a 'DumpFlag' constructor beautifyDumpName :: DumpFlag -> String beautifyDumpName Opt_D_th_dec_file = "th.hs" beautifyDumpName flag = let str = show flag suff = case stripPrefix "Opt_D_" str of Just x -> x Nothing -> panic ("Bad flag name: " ++ str) dash = map (\c -> if c == '_' then '-' else c) suff in dash -- ----------------------------------------------------------------------------- -- Outputting messages from the compiler -- We want all messages to go through one place, so that we can -- redirect them if necessary. For example, when GHC is used as a -- library we might want to catch all messages that GHC tries to -- output and do something else with them. ifVerbose :: DynFlags -> Int -> IO () -> IO () ifVerbose dflags val act | verbosity dflags >= val = act | otherwise = return () errorMsg :: DynFlags -> MsgDoc -> IO () errorMsg dflags msg = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg warningMsg :: DynFlags -> MsgDoc -> IO () warningMsg dflags msg = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg fatalErrorMsg :: DynFlags -> MsgDoc -> IO () fatalErrorMsg dflags msg = putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg fatalErrorMsg'' :: FatalMessager -> String -> IO () fatalErrorMsg'' fm msg = fm msg compilationProgressMsg :: DynFlags -> String -> IO () compilationProgressMsg dflags msg = do traceEventIO $ "GHC progress: " ++ msg ifVerbose dflags 1 $ logOutput dflags (defaultUserStyle dflags) (text msg) showPass :: DynFlags -> String -> IO () showPass dflags what = ifVerbose dflags 2 $ logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon) data PrintTimings = PrintTimings | DontPrintTimings deriving (Eq, Show) -- | Time a compilation phase. -- -- When timings are enabled (e.g. with the @-v2@ flag), the allocations -- and CPU time used by the phase will be reported to stderr. Consider -- a typical usage: -- @withTiming getDynFlags (text "simplify") force PrintTimings pass@. -- When timings are enabled the following costs are included in the -- produced accounting, -- -- - The cost of executing @pass@ to a result @r@ in WHNF -- - The cost of evaluating @force r@ to WHNF (e.g. @()@) -- -- The choice of the @force@ function depends upon the amount of forcing -- desired; the goal here is to ensure that the cost of evaluating the result -- is, to the greatest extent possible, included in the accounting provided by -- 'withTiming'. Often the pass already sufficiently forces its result during -- construction; in this case @const ()@ is a reasonable choice. -- In other cases, it is necessary to evaluate the result to normal form, in -- which case something like @Control.DeepSeq.rnf@ is appropriate. -- -- To avoid adversely affecting compiler performance when timings are not -- requested, the result is only forced when timings are enabled. -- -- See Note [withTiming] for more. withTiming :: MonadIO m => DynFlags -- ^ DynFlags -> SDoc -- ^ The name of the phase -> (a -> ()) -- ^ A function to force the result -- (often either @const ()@ or 'rnf') -> m a -- ^ The body of the phase to be timed -> m a withTiming dflags what force action = withTiming' dflags what force PrintTimings action -- | Like withTiming but get DynFlags from the Monad. withTimingD :: (MonadIO m, HasDynFlags m) => SDoc -- ^ The name of the phase -> (a -> ()) -- ^ A function to force the result -- (often either @const ()@ or 'rnf') -> m a -- ^ The body of the phase to be timed -> m a withTimingD what force action = do dflags <- getDynFlags withTiming' dflags what force PrintTimings action -- | Same as 'withTiming', but doesn't print timings in the -- console (when given @-vN@, @N >= 2@ or @-ddump-timings@). -- -- See Note [withTiming] for more. withTimingSilent :: MonadIO m => DynFlags -- ^ DynFlags -> SDoc -- ^ The name of the phase -> (a -> ()) -- ^ A function to force the result -- (often either @const ()@ or 'rnf') -> m a -- ^ The body of the phase to be timed -> m a withTimingSilent dflags what force action = withTiming' dflags what force DontPrintTimings action -- | Same as 'withTiming', but doesn't print timings in the -- console (when given @-vN@, @N >= 2@ or @-ddump-timings@) -- and gets the DynFlags from the given Monad. -- -- See Note [withTiming] for more. withTimingSilentD :: (MonadIO m, HasDynFlags m) => SDoc -- ^ The name of the phase -> (a -> ()) -- ^ A function to force the result -- (often either @const ()@ or 'rnf') -> m a -- ^ The body of the phase to be timed -> m a withTimingSilentD what force action = do dflags <- getDynFlags withTiming' dflags what force DontPrintTimings action -- | Worker for 'withTiming' and 'withTimingSilent'. withTiming' :: MonadIO m => DynFlags -- ^ A means of getting a 'DynFlags' (often -- 'getDynFlags' will work here) -> SDoc -- ^ The name of the phase -> (a -> ()) -- ^ A function to force the result -- (often either @const ()@ or 'rnf') -> PrintTimings -- ^ Whether to print the timings -> m a -- ^ The body of the phase to be timed -> m a withTiming' dflags what force_result prtimings action = do if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags then do whenPrintTimings $ logInfo dflags (defaultUserStyle dflags) $ text "***" <+> what <> colon eventBegins dflags what alloc0 <- liftIO getAllocationCounter start <- liftIO getCPUTime !r <- action () <- pure $ force_result r eventEnds dflags what end <- liftIO getCPUTime alloc1 <- liftIO getAllocationCounter -- recall that allocation counter counts down let alloc = alloc0 - alloc1 time = realToFrac (end - start) * 1e-9 when (verbosity dflags >= 2 && prtimings == PrintTimings) $ liftIO $ logInfo dflags (defaultUserStyle dflags) (text "!!!" <+> what <> colon <+> text "finished in" <+> doublePrec 2 time <+> text "milliseconds" <> comma <+> text "allocated" <+> doublePrec 3 (realToFrac alloc / 1024 / 1024) <+> text "megabytes") whenPrintTimings $ dumpIfSet_dyn dflags Opt_D_dump_timings "" $ text $ showSDocOneLine dflags $ hsep [ what <> colon , text "alloc=" <> ppr alloc , text "time=" <> doublePrec 3 time ] pure r else action where whenPrintTimings = liftIO . when (prtimings == PrintTimings) eventBegins dflags w = do whenPrintTimings $ traceMarkerIO (eventBeginsDoc dflags w) liftIO $ traceEventIO (eventEndsDoc dflags w) eventEnds dflags w = do whenPrintTimings $ traceMarkerIO (eventEndsDoc dflags w) liftIO $ traceEventIO (eventEndsDoc dflags w) eventBeginsDoc dflags w = showSDocOneLine dflags $ text "GHC:started:" <+> w eventEndsDoc dflags w = showSDocOneLine dflags $ text "GHC:finished:" <+> w debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () debugTraceMsg dflags val msg = ifVerbose dflags val $ logInfo dflags (defaultDumpStyle dflags) msg putMsg :: DynFlags -> MsgDoc -> IO () putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () printInfoForUser dflags print_unqual msg = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () printOutputForUser dflags print_unqual msg = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO () logInfo dflags sty msg = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO () -- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' logOutput dflags sty msg = putLogMsg dflags NoReason SevOutput noSrcSpan sty msg prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a prettyPrintGhcErrors dflags = ghandle $ \e -> case e of PprPanic str doc -> pprDebugAndThen dflags panic (text str) doc PprSorry str doc -> pprDebugAndThen dflags sorry (text str) doc PprProgramError str doc -> pprDebugAndThen dflags pgmError (text str) doc _ -> liftIO $ throwIO e -- | Checks if given 'WarnMsg' is a fatal warning. isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag) isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag} = if wopt_fatal wflag dflags then Just (Just wflag) else Nothing isWarnMsgFatal dflags _ = if gopt Opt_WarnIsError dflags then Just Nothing else Nothing traceCmd :: DynFlags -> String -> String -> IO a -> IO a -- trace the command (at two levels of verbosity) traceCmd dflags phase_name cmd_line action = do { let verb = verbosity dflags ; showPass dflags phase_name ; debugTraceMsg dflags 3 (text cmd_line) ; case flushErr dflags of FlushErr io -> io -- And run it! ; action `catchIO` handle_exn verb } where handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') ; debugTraceMsg dflags 2 (text "Failed:" <+> text cmd_line <+> text (show exn)) ; throwGhcExceptionIO (ProgramError (show exn))} {- Note [withTiming] ~~~~~~~~~~~~~~~~~~~~ For reference: withTiming :: MonadIO => m DynFlags -- how to get the DynFlags -> SDoc -- label for the computation we're timing -> (a -> ()) -- how to evaluate the result -> PrintTimings -- whether to report the timings when passed -- -v2 or -ddump-timings -> m a -- computation we're timing -> m a withTiming lets you run an action while: (1) measuring the CPU time it took and reporting that on stderr (when PrintTimings is passed), (2) emitting start/stop events to GHC's event log, with the label given as an argument. Evaluation of the result ------------------------ 'withTiming' takes as an argument a function of type 'a -> ()', whose purpose is to evaluate the result "sufficiently". A given pass might return an 'm a' for some monad 'm' and result type 'a', but where the 'a' is complex enough that evaluating it to WHNF barely scratches its surface and leaves many complex and time-consuming computations unevaluated. Those would only be forced by the next pass, and the time needed to evaluate them would be mis-attributed to that next pass. A more appropriate function would be one that deeply evaluates the result, so as to assign the time spent doing it to the pass we're timing. Note: as hinted at above, the time spent evaluating the application of the forcing function to the result is included in the timings reported by 'withTiming'. How we use it ------------- We measure the time and allocations of various passes in GHC's pipeline by just wrapping the whole pass with 'withTiming'. This also materializes by having a label for each pass in the eventlog, where each pass is executed in one go, during a continuous time window. However, from STG onwards, the pipeline uses streams to emit groups of STG/Cmm/etc declarations one at a time, and process them until we get to assembly code generation. This means that the execution of those last few passes is interleaved and that we cannot measure how long they take by just wrapping the whole thing with 'withTiming'. Instead we wrap the processing of each individual stream element, all along the codegen pipeline, using the appropriate label for the pass to which this processing belongs. That generates a lot more data but allows us to get fine-grained timings about all the passes and we can easily compute totals withh tools like ghc-events-analyze (see below). Producing an eventlog for GHC ----------------------------- To actually produce the eventlog, you need an eventlog-capable GHC build: With Hadrian: $ hadrian/build.sh -j "stage1.ghc-bin.ghc.link.opts += -eventlog" With Make: $ make -j GhcStage2HcOpts+=-eventlog You can then produce an eventlog when compiling say hello.hs by simply doing: If GHC was built by Hadrian: $ _build/stage1/bin/ghc -ddump-timings hello.hs -o hello +RTS -l If GHC was built with Make: $ inplace/bin/ghc-stage2 -ddump-timing hello.hs -o hello +RTS -l You could alternatively use -v (with N >= 2) instead of -ddump-timings, to ask GHC to report timings (on stderr and the eventlog). This will write the eventlog to ./ghc.eventlog in both cases. You can then visualize it or look at the totals for each label by using ghc-events-analyze, threadscope or any other eventlog consumer. Illustrating with ghc-events-analyze: $ ghc-events-analyze --timed --timed-txt --totals \ --start "GHC:started:" --stop "GHC:finished:" \ ghc.eventlog This produces ghc.timed.txt (all event timestamps), ghc.timed.svg (visualisation of the execution through the various labels) and ghc.totals.txt (total time spent in each label). -} ghc-lib-parser-8.10.2.20200808/compiler/utils/Exception.hs0000644000000000000000000000524413713635745020760 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-deprecations #-} module Exception ( module Control.Exception, module Exception ) where import GhcPrelude import Control.Exception import Control.Monad.IO.Class catchIO :: IO a -> (IOException -> IO a) -> IO a catchIO = Control.Exception.catch handleIO :: (IOException -> IO a) -> IO a -> IO a handleIO = flip catchIO tryIO :: IO a -> IO (Either IOException a) tryIO = try -- | A monad that can catch exceptions. A minimal definition -- requires a definition of 'gcatch'. -- -- Implementations on top of 'IO' should implement 'gmask' to -- eventually call the primitive 'Control.Exception.mask'. -- These are used for -- implementations that support asynchronous exceptions. The default -- implementations of 'gbracket' and 'gfinally' use 'gmask' -- thus rarely require overriding. -- class MonadIO m => ExceptionMonad m where -- | Generalised version of 'Control.Exception.catch', allowing an arbitrary -- exception handling monad instead of just 'IO'. gcatch :: Exception e => m a -> (e -> m a) -> m a -- | Generalised version of 'Control.Exception.mask_', allowing an arbitrary -- exception handling monad instead of just 'IO'. gmask :: ((m a -> m a) -> m b) -> m b -- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary -- exception handling monad instead of just 'IO'. gbracket :: m a -> (a -> m b) -> (a -> m c) -> m c -- | Generalised version of 'Control.Exception.finally', allowing an arbitrary -- exception handling monad instead of just 'IO'. gfinally :: m a -> m b -> m a gbracket before after thing = gmask $ \restore -> do a <- before r <- restore (thing a) `gonException` after a _ <- after a return r a `gfinally` sequel = gmask $ \restore -> do r <- restore a `gonException` sequel _ <- sequel return r instance ExceptionMonad IO where gcatch = Control.Exception.catch gmask f = mask (\x -> f x) gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a) gtry act = gcatch (act >>= \a -> return (Right a)) (\e -> return (Left e)) -- | Generalised version of 'Control.Exception.handle', allowing an arbitrary -- exception handling monad instead of just 'IO'. ghandle :: (ExceptionMonad m, Exception e) => (e -> m a) -> m a -> m a ghandle = flip gcatch -- | Always executes the first argument. If this throws an exception the -- second argument is executed and the exception is raised again. gonException :: (ExceptionMonad m) => m a -> m b -> m a gonException ioA cleanup = ioA `gcatch` \e -> do _ <- cleanup liftIO $ throwIO (e :: SomeException) ghc-lib-parser-8.10.2.20200808/compiler/utils/FV.hs0000644000000000000000000001532213713635745017333 0ustar0000000000000000{- (c) Bartosz Nitka, Facebook 2015 Utilities for efficiently and deterministically computing free variables. -} {-# LANGUAGE BangPatterns #-} module FV ( -- * Deterministic free vars computations FV, InterestingVarFun, -- * Running the computations fvVarListVarSet, fvVarList, fvVarSet, fvDVarSet, -- ** Manipulating those computations unitFV, emptyFV, mkFVs, unionFV, unionsFV, delFV, delFVs, filterFV, mapUnionFV, ) where import GhcPrelude import Var import VarSet -- | Predicate on possible free variables: returns @True@ iff the variable is -- interesting type InterestingVarFun = Var -> Bool -- Note [Deterministic FV] -- ~~~~~~~~~~~~~~~~~~~~~~~ -- When computing free variables, the order in which you get them affects -- the results of floating and specialization. If you use UniqFM to collect -- them and then turn that into a list, you get them in nondeterministic -- order as described in Note [Deterministic UniqFM] in UniqDFM. -- A naive algorithm for free variables relies on merging sets of variables. -- Merging costs O(n+m) for UniqFM and for UniqDFM there's an additional log -- factor. It's cheaper to incrementally add to a list and use a set to check -- for duplicates. type FV = InterestingVarFun -- Used for filtering sets as we build them -> VarSet -- Locally bound variables -> ([Var], VarSet) -- List to preserve ordering and set to check for membership, -- so that the list doesn't have duplicates -- For explanation of why using `VarSet` is not deterministic see -- Note [Deterministic UniqFM] in UniqDFM. -> ([Var], VarSet) -- Note [FV naming conventions] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- To get the performance and determinism that FV provides, FV computations -- need to built up from smaller FV computations and then evaluated with -- one of `fvVarList`, `fvDVarSet`, `fvVarListVarSet`. That means the functions -- returning FV need to be exported. -- -- The conventions are: -- -- a) non-deterministic functions: -- * a function that returns VarSet -- e.g. `tyVarsOfType` -- b) deterministic functions: -- * a worker that returns FV -- e.g. `tyFVsOfType` -- * a function that returns [Var] -- e.g. `tyVarsOfTypeList` -- * a function that returns DVarSet -- e.g. `tyVarsOfTypeDSet` -- -- Where tyVarsOfType, tyVarsOfTypeList, tyVarsOfTypeDSet are implemented -- in terms of the worker evaluated with fvVarSet, fvVarList, fvDVarSet -- respectively. -- | Run a free variable computation, returning a list of distinct free -- variables in deterministic order and a non-deterministic set containing -- those variables. fvVarListVarSet :: FV -> ([Var], VarSet) fvVarListVarSet fv = fv (const True) emptyVarSet ([], emptyVarSet) -- | Run a free variable computation, returning a list of distinct free -- variables in deterministic order. fvVarList :: FV -> [Var] fvVarList = fst . fvVarListVarSet -- | Run a free variable computation, returning a deterministic set of free -- variables. Note that this is just a wrapper around the version that -- returns a deterministic list. If you need a list you should use -- `fvVarList`. fvDVarSet :: FV -> DVarSet fvDVarSet = mkDVarSet . fst . fvVarListVarSet -- | Run a free variable computation, returning a non-deterministic set of -- free variables. Don't use if the set will be later converted to a list -- and the order of that list will impact the generated code. fvVarSet :: FV -> VarSet fvVarSet = snd . fvVarListVarSet -- Note [FV eta expansion] -- ~~~~~~~~~~~~~~~~~~~~~~~ -- Let's consider an eta-reduced implementation of freeVarsOf using FV: -- -- freeVarsOf (App a b) = freeVarsOf a `unionFV` freeVarsOf b -- -- If GHC doesn't eta-expand it, after inlining unionFV we end up with -- -- freeVarsOf = \x -> -- case x of -- App a b -> \fv_cand in_scope acc -> -- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc -- -- which has to create a thunk, resulting in more allocations. -- -- On the other hand if it is eta-expanded: -- -- freeVarsOf (App a b) fv_cand in_scope acc = -- (freeVarsOf a `unionFV` freeVarsOf b) fv_cand in_scope acc -- -- after inlining unionFV we have: -- -- freeVarsOf = \x fv_cand in_scope acc -> -- case x of -- App a b -> -- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc -- -- which saves allocations. -- -- GHC when presented with knowledge about all the call sites, correctly -- eta-expands in this case. Unfortunately due to the fact that freeVarsOf gets -- exported to be composed with other functions, GHC doesn't have that -- information and has to be more conservative here. -- -- Hence functions that get exported and return FV need to be manually -- eta-expanded. See also #11146. -- | Add a variable - when free, to the returned free variables. -- Ignores duplicates and respects the filtering function. unitFV :: Id -> FV unitFV var fv_cand in_scope acc@(have, haveSet) | var `elemVarSet` in_scope = acc | var `elemVarSet` haveSet = acc | fv_cand var = (var:have, extendVarSet haveSet var) | otherwise = acc {-# INLINE unitFV #-} -- | Return no free variables. emptyFV :: FV emptyFV _ _ acc = acc {-# INLINE emptyFV #-} -- | Union two free variable computations. unionFV :: FV -> FV -> FV unionFV fv1 fv2 fv_cand in_scope acc = fv1 fv_cand in_scope $! fv2 fv_cand in_scope $! acc {-# INLINE unionFV #-} -- | Mark the variable as not free by putting it in scope. delFV :: Var -> FV -> FV delFV var fv fv_cand !in_scope acc = fv fv_cand (extendVarSet in_scope var) acc {-# INLINE delFV #-} -- | Mark many free variables as not free. delFVs :: VarSet -> FV -> FV delFVs vars fv fv_cand !in_scope acc = fv fv_cand (in_scope `unionVarSet` vars) acc {-# INLINE delFVs #-} -- | Filter a free variable computation. filterFV :: InterestingVarFun -> FV -> FV filterFV fv_cand2 fv fv_cand1 in_scope acc = fv (\v -> fv_cand1 v && fv_cand2 v) in_scope acc {-# INLINE filterFV #-} -- | Map a free variable computation over a list and union the results. mapUnionFV :: (a -> FV) -> [a] -> FV mapUnionFV _f [] _fv_cand _in_scope acc = acc mapUnionFV f (a:as) fv_cand in_scope acc = mapUnionFV f as fv_cand in_scope $! f a fv_cand in_scope $! acc {-# INLINABLE mapUnionFV #-} -- | Union many free variable computations. unionsFV :: [FV] -> FV unionsFV fvs fv_cand in_scope acc = mapUnionFV id fvs fv_cand in_scope acc {-# INLINE unionsFV #-} -- | Add multiple variables - when free, to the returned free variables. -- Ignores duplicates and respects the filtering function. mkFVs :: [Var] -> FV mkFVs vars fv_cand in_scope acc = mapUnionFV unitFV vars fv_cand in_scope acc {-# INLINE mkFVs #-} ghc-lib-parser-8.10.2.20200808/compiler/types/FamInstEnv.hs0000644000000000000000000023035413713635745021042 0ustar0000000000000000-- (c) The University of Glasgow 2006 -- -- FamInstEnv: Type checked family instance declarations {-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns, TupleSections, DeriveFunctor #-} module FamInstEnv ( FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, pprFamInst, pprFamInsts, mkImportedFamInst, FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, extendFamInstEnv, extendFamInstEnvList, famInstEnvElts, famInstEnvSize, familyInstances, -- * CoAxioms mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom, mkNewTypeCoAxiom, FamInstMatch(..), lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, isDominatedBy, apartnessCheck, -- Injectivity InjectivityCheckResult(..), lookupFamInstEnvInjectivityConflicts, injectiveBranches, -- Normalisation topNormaliseType, topNormaliseType_maybe, normaliseType, normaliseTcApp, normaliseTcArgs, reduceTyFamApp_maybe, -- Flattening flattenTys ) where #include "GhclibHsVersions.h" import GhcPrelude import Unify import Type import TyCoRep import TyCon import Coercion import CoAxiom import VarSet import VarEnv import Name import PrelNames ( eqPrimTyConKey ) import UniqDFM import Outputable import Maybes import CoreMap import Unique import Util import Var import Pair import SrcLoc import FastString import Control.Monad import Data.List( mapAccumL ) import Data.Array( Array, assocs ) {- ************************************************************************ * * Type checked family instance heads * * ************************************************************************ Note [FamInsts and CoAxioms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * CoAxioms and FamInsts are just like DFunIds and ClsInsts * A CoAxiom is a System-FC thing: it can relate any two types * A FamInst is a Haskell source-language thing, corresponding to a type/data family instance declaration. - The FamInst contains a CoAxiom, which is the evidence for the instance - The LHS of the CoAxiom is always of form F ty1 .. tyn where F is a type family -} data FamInst -- See Note [FamInsts and CoAxioms] = FamInst { fi_axiom :: CoAxiom Unbranched -- The new coercion axiom -- introduced by this family -- instance -- INVARIANT: apart from freshening (see below) -- fi_tvs = cab_tvs of the (single) axiom branch -- fi_cvs = cab_cvs ...ditto... -- fi_tys = cab_lhs ...ditto... -- fi_rhs = cab_rhs ...ditto... , fi_flavor :: FamFlavor -- Everything below here is a redundant, -- cached version of the two things above -- except that the TyVars are freshened , fi_fam :: Name -- Family name -- Used for "rough matching"; same idea as for class instances -- See Note [Rough-match field] in InstEnv , fi_tcs :: [Maybe Name] -- Top of type args -- INVARIANT: fi_tcs = roughMatchTcs fi_tys -- Used for "proper matching"; ditto , fi_tvs :: [TyVar] -- Template tyvars for full match , fi_cvs :: [CoVar] -- Template covars for full match -- Like ClsInsts, these variables are always fresh -- See Note [Template tyvars are fresh] in InstEnv , fi_tys :: [Type] -- The LHS type patterns -- May be eta-reduced; see Note [Eta reduction for data families] , fi_rhs :: Type -- the RHS, with its freshened vars } data FamFlavor = SynFamilyInst -- A synonym family | DataFamilyInst TyCon -- A data family, with its representation TyCon {- Note [Arity of data families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Data family instances might legitimately be over- or under-saturated. Under-saturation has two potential causes: U1) Eta reduction. See Note [Eta reduction for data families]. U2) When the user has specified a return kind instead of written out patterns. Example: data family Sing (a :: k) data instance Sing :: Bool -> Type The data family tycon Sing has an arity of 2, the k and the a. But the data instance has only one pattern, Bool (standing in for k). This instance is equivalent to `data instance Sing (a :: Bool)`, but without the last pattern, we have an under-saturated data family instance. On its own, this example is not compelling enough to add support for under-saturation, but U1 makes this feature more compelling. Over-saturation is also possible: O1) If the data family's return kind is a type variable (see also #12369), an instance might legitimately have more arguments than the family. Example: data family Fix :: (Type -> k) -> k data instance Fix f = MkFix1 (f (Fix f)) data instance Fix f x = MkFix2 (f (Fix f x) x) In the first instance here, the k in the data family kind is chosen to be Type. In the second, it's (Type -> Type). However, we require that any over-saturation is eta-reducible. That is, we require that any extra patterns be bare unrepeated type variables; see Note [Eta reduction for data families]. Accordingly, the FamInst is never over-saturated. Why can we allow such flexibility for data families but not for type families? Because data families can be decomposed -- that is, they are generative and injective. A Type family is neither and so always must be applied to all its arguments. -} -- Obtain the axiom of a family instance famInstAxiom :: FamInst -> CoAxiom Unbranched famInstAxiom = fi_axiom -- Split the left-hand side of the FamInst famInstSplitLHS :: FamInst -> (TyCon, [Type]) famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs }) = (coAxiomTyCon axiom, lhs) -- Get the RHS of the FamInst famInstRHS :: FamInst -> Type famInstRHS = fi_rhs -- Get the family TyCon of the FamInst famInstTyCon :: FamInst -> TyCon famInstTyCon = coAxiomTyCon . famInstAxiom -- Return the representation TyCons introduced by data family instances, if any famInstsRepTyCons :: [FamInst] -> [TyCon] famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis] -- Extracts the TyCon for this *data* (or newtype) instance famInstRepTyCon_maybe :: FamInst -> Maybe TyCon famInstRepTyCon_maybe fi = case fi_flavor fi of DataFamilyInst tycon -> Just tycon SynFamilyInst -> Nothing dataFamInstRepTyCon :: FamInst -> TyCon dataFamInstRepTyCon fi = case fi_flavor fi of DataFamilyInst tycon -> tycon SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) {- ************************************************************************ * * Pretty printing * * ************************************************************************ -} instance NamedThing FamInst where getName = coAxiomName . fi_axiom instance Outputable FamInst where ppr = pprFamInst pprFamInst :: FamInst -> SDoc -- Prints the FamInst as a family instance declaration -- NB: This function, FamInstEnv.pprFamInst, is used only for internal, -- debug printing. See PprTyThing.pprFamInst for printing for the user pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax , fi_tvs = tvs, fi_tys = tys, fi_rhs = rhs }) = hang (ppr_tc_sort <+> text "instance" <+> pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)) 2 (whenPprDebug debug_stuff) where ppr_tc_sort = case flavor of SynFamilyInst -> text "type" DataFamilyInst tycon | isDataTyCon tycon -> text "data" | isNewTyCon tycon -> text "newtype" | isAbstractTyCon tycon -> text "data" | otherwise -> text "WEIRD" <+> ppr tycon debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax , text "Tvs:" <+> ppr tvs , text "LHS:" <+> ppr tys , text "RHS:" <+> ppr rhs ] pprFamInsts :: [FamInst] -> SDoc pprFamInsts finsts = vcat (map pprFamInst finsts) {- Note [Lazy axiom match] ~~~~~~~~~~~~~~~~~~~~~~~ It is Vitally Important that mkImportedFamInst is *lazy* in its axiom parameter. The axiom is loaded lazily, via a forkM, in TcIface. Sometime later, mkImportedFamInst is called using that axiom. However, the axiom may itself depend on entities which are not yet loaded as of the time of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the axiom, a dependency loop spontaneously appears and GHC hangs. The solution is simply for mkImportedFamInst never, ever to look inside of the axiom until everything else is good and ready to do so. We can assume that this readiness has been achieved when some other code pulls on the axiom in the FamInst. Thus, we pattern match on the axiom lazily (in the where clause, not in the parameter list) and we assert the consistency of names there also. -} -- Make a family instance representation from the information found in an -- interface file. In particular, we get the rough match info from the iface -- (instead of computing it here). mkImportedFamInst :: Name -- Name of the family -> [Maybe Name] -- Rough match info -> CoAxiom Unbranched -- Axiom introduced -> FamInst -- Resulting family instance mkImportedFamInst fam mb_tcs axiom = FamInst { fi_fam = fam, fi_tcs = mb_tcs, fi_tvs = tvs, fi_cvs = cvs, fi_tys = tys, fi_rhs = rhs, fi_axiom = axiom, fi_flavor = flavor } where -- See Note [Lazy axiom match] ~(CoAxBranch { cab_lhs = tys , cab_tvs = tvs , cab_cvs = cvs , cab_rhs = rhs }) = coAxiomSingleBranch axiom -- Derive the flavor for an imported FamInst rather disgustingly -- Maybe we should store it in the IfaceFamInst? flavor = case splitTyConApp_maybe rhs of Just (tc, _) | Just ax' <- tyConFamilyCoercion_maybe tc , ax' == axiom -> DataFamilyInst tc _ -> SynFamilyInst {- ************************************************************************ * * FamInstEnv * * ************************************************************************ Note [FamInstEnv] ~~~~~~~~~~~~~~~~~ A FamInstEnv maps a family name to the list of known instances for that family. The same FamInstEnv includes both 'data family' and 'type family' instances. Type families are reduced during type inference, but not data families; the user explains when to use a data family instance by using constructors and pattern matching. Nevertheless it is still useful to have data families in the FamInstEnv: - For finding overlaps and conflicts - For finding the representation type...see FamInstEnv.topNormaliseType and its call site in Simplify - In standalone deriving instance Eq (T [Int]) we need to find the representation type for T [Int] Note [Varying number of patterns for data family axioms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For data families, the number of patterns may vary between instances. For example data family T a b data instance T Int a = T1 a | T2 data instance T Bool [a] = T3 a Then we get a data type for each instance, and an axiom: data TInt a = T1 a | T2 data TBoolList a = T3 a axiom ax7 :: T Int ~ TInt -- Eta-reduced axiom ax8 a :: T Bool [a] ~ TBoolList a These two axioms for T, one with one pattern, one with two; see Note [Eta reduction for data families] Note [FamInstEnv determinism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We turn FamInstEnvs into a list in some places that don't directly affect the ABI. That happens in family consistency checks and when producing output for `:info`. Unfortunately that nondeterminism is nonlocal and it's hard to tell what it affects without following a chain of functions. It's also easy to accidentally make that nondeterminism affect the ABI. Furthermore the envs should be relatively small, so it should be free to use deterministic maps here. Testing with nofib and validate detected no difference between UniqFM and UniqDFM. See Note [Deterministic UniqFM]. -} type FamInstEnv = UniqDFM FamilyInstEnv -- Maps a family to its instances -- See Note [FamInstEnv] -- See Note [FamInstEnv determinism] type FamInstEnvs = (FamInstEnv, FamInstEnv) -- External package inst-env, Home-package inst-env newtype FamilyInstEnv = FamIE [FamInst] -- The instances for a particular family, in any order instance Outputable FamilyInstEnv where ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs) -- INVARIANTS: -- * The fs_tvs are distinct in each FamInst -- of a range value of the map (so we can safely unify them) emptyFamInstEnvs :: (FamInstEnv, FamInstEnv) emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv) emptyFamInstEnv :: FamInstEnv emptyFamInstEnv = emptyUDFM famInstEnvElts :: FamInstEnv -> [FamInst] famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts] -- See Note [FamInstEnv determinism] famInstEnvSize :: FamInstEnv -> Int famInstEnvSize = nonDetFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0 -- It's OK to use nonDetFoldUDFM here since we're just computing the -- size. familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] familyInstances (pkg_fie, home_fie) fam = get home_fie ++ get pkg_fie where get env = case lookupUDFM env fam of Just (FamIE insts) -> insts Nothing -> [] extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv extendFamInstEnvList inst_env fis = foldl' extendFamInstEnv inst_env fis extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm}) = addToUDFM_C add inst_env cls_nm (FamIE [ins_item]) where add (FamIE items) _ = FamIE (ins_item:items) {- ************************************************************************ * * Compatibility * * ************************************************************************ Note [Apartness] ~~~~~~~~~~~~~~~~ In dealing with closed type families, we must be able to check that one type will never reduce to another. This check is called /apartness/. The check is always between a target (which may be an arbitrary type) and a pattern. Here is how we do it: apart(target, pattern) = not (unify(flatten(target), pattern)) where flatten (implemented in flattenTys, below) converts all type-family applications into fresh variables. (See Note [Flattening].) Note [Compatibility] ~~~~~~~~~~~~~~~~~~~~ Two patterns are /compatible/ if either of the following conditions hold: 1) The patterns are apart. 2) The patterns unify with a substitution S, and their right hand sides equal under that substitution. For open type families, only compatible instances are allowed. For closed type families, the story is slightly more complicated. Consider the following: type family F a where F Int = Bool F a = Int g :: Show a => a -> F a g x = length (show x) Should that type-check? No. We need to allow for the possibility that 'a' might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int only when we can be sure that 'a' is not Int. To achieve this, after finding a possible match within the equations, we have to go back to all previous equations and check that, under the substitution induced by the match, other branches are surely apart. (See Note [Apartness].) This is similar to what happens with class instance selection, when we need to guarantee that there is only a match and no unifiers. The exact algorithm is different here because the potentially-overlapping group is closed. As another example, consider this: type family G x where G Int = Bool G a = Double type family H y -- no instances Now, we want to simplify (G (H Char)). We can't, because (H Char) might later simplify to be Int. So, (G (H Char)) is stuck, for now. While everything above is quite sound, it isn't as expressive as we'd like. Consider this: type family J a where J Int = Int J a = a Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if b is instantiated with Int, but the RHSs coincide there, so it's all OK. So, the rule is this: when looking up a branch in a closed type family, we find a branch that matches the target, but then we make sure that the target is apart from every previous *incompatible* branch. We don't check the branches that are compatible with the matching branch, because they are either irrelevant (clause 1 of compatible) or benign (clause 2 of compatible). Note [Compatibility of eta-reduced axioms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In newtype instances of data families we eta-reduce the axioms, See Note [Eta reduction for data families] in FamInstEnv. This means that we sometimes need to test compatibility of two axioms that were eta-reduced to different degrees, e.g.: data family D a b c newtype instance D a Int c = DInt (Maybe a) -- D a Int ~ Maybe -- lhs = [a, Int] newtype instance D Bool Int Char = DIntChar Float -- D Bool Int Char ~ Float -- lhs = [Bool, Int, Char] These are obviously incompatible. We could detect this by saturating (eta-expanding) the shorter LHS with fresh tyvars until the lists are of equal length, but instead we can just remove the tail of the longer list, as those types will simply unify with the freshly introduced tyvars. By doing this, in case the LHS are unifiable, the yielded substitution won't mention the tyvars that appear in the tail we dropped off, and we might try to test equality RHSes of different kinds, but that's fine since this case occurs only for data families, where the RHS is a unique tycon and the equality fails anyway. -} -- See Note [Compatibility] compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) = let (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2 -- See Note [Compatibility of eta-reduced axioms] in case tcUnifyTysFG (const BindMe) commonlhs1 commonlhs2 of SurelyApart -> True Unifiable subst | Type.substTyAddInScope subst rhs1 `eqType` Type.substTyAddInScope subst rhs2 -> True _ -> False -- | Result of testing two type family equations for injectiviy. data InjectivityCheckResult = InjectivityAccepted -- ^ Either RHSs are distinct or unification of RHSs leads to unification of -- LHSs | InjectivityUnified CoAxBranch CoAxBranch -- ^ RHSs unify but LHSs don't unify under that substitution. Relevant for -- closed type families where equation after unification might be -- overlpapped (in which case it is OK if they don't unify). Constructor -- stores axioms after unification. -- | Check whether two type family axioms don't violate injectivity annotation. injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch -> InjectivityCheckResult injectiveBranches injectivity ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) -- See Note [Verifying injectivity annotation], case 1. = let getInjArgs = filterByList injectivity in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification Nothing -> InjectivityAccepted -- RHS are different, so equations are injective. -- This is case 1A from Note [Verifying injectivity annotation] Just subst -> -- RHS unify under a substitution let lhs1Subst = Type.substTys subst (getInjArgs lhs1) lhs2Subst = Type.substTys subst (getInjArgs lhs2) -- If LHSs are equal under the substitution used for RHSs then this pair -- of equations does not violate injectivity annotation. If LHSs are not -- equal under that substitution then this pair of equations violates -- injectivity annotation, but for closed type families it still might -- be the case that one LHS after substitution is unreachable. in if eqTypes lhs1Subst lhs2Subst -- check case 1B1 from Note. then InjectivityAccepted else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1 , cab_rhs = Type.substTy subst rhs1 }) ( ax2 { cab_lhs = Type.substTys subst lhs2 , cab_rhs = Type.substTy subst rhs2 }) -- payload of InjectivityUnified used only for check 1B2, only -- for closed type families -- takes a CoAxiom with unknown branch incompatibilities and computes -- the compatibilities -- See Note [Storing compatibility] in CoAxiom computeAxiomIncomps :: [CoAxBranch] -> [CoAxBranch] computeAxiomIncomps branches = snd (mapAccumL go [] branches) where go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) go prev_brs cur_br = (cur_br : prev_brs, new_br) where new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br } mk_incomps :: [CoAxBranch] -> CoAxBranch -> [CoAxBranch] mk_incomps prev_brs cur_br = filter (not . compatibleBranches cur_br) prev_brs {- ************************************************************************ * * Constructing axioms These functions are here because tidyType / tcUnifyTysFG are not available in CoAxiom Also computeAxiomIncomps is too sophisticated for CoAxiom * * ************************************************************************ Note [Tidy axioms when we build them] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Like types and classes, we build axioms fully quantified over all their variables, and tidy them when we build them. For example, we print out axioms and don't want to print stuff like F k k a b = ... Instead we must tidy those kind variables. See #7524. We could instead tidy when we print, but that makes it harder to get things like injectivity errors to come out right. Danger of Type family equation violates injectivity annotation. Kind variable ‘k’ cannot be inferred from the right-hand side. In the type family equation: PolyKindVars @[k1] @[k2] ('[] @k1) = '[] @k2 Note [Always number wildcard types in CoAxBranch] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following example (from the DataFamilyInstanceLHS test case): data family Sing (a :: k) data instance Sing (_ :: MyKind) where SingA :: Sing A SingB :: Sing B If we're not careful during tidying, then when this program is compiled with -ddump-types, we'll get the following information: COERCION AXIOMS axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _ It's misleading to have a wildcard type appearing on the RHS like that. To avoid this issue, when building a CoAxiom (which is what eventually gets printed above), we tidy all the variables in an env that already contains '_'. Thus, any variable named '_' will be renamed, giving us the nicer output here: COERCION AXIOMS axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1 Which is at least legal syntax. See also Note [CoAxBranch type variables] in CoAxiom; note that we are tidying (changing OccNames only), not freshening, in accordance with that Note. -} -- all axiom roles are Nominal, as this is only used with type families mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars -> [TyVar] -- Extra eta tyvars -> [CoVar] -- possibly stale covars -> [Type] -- LHS patterns -> Type -- RHS -> [Role] -> SrcSpan -> CoAxBranch mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc = CoAxBranch { cab_tvs = tvs' , cab_eta_tvs = eta_tvs' , cab_cvs = cvs' , cab_lhs = tidyTypes env lhs , cab_roles = roles , cab_rhs = tidyType env rhs , cab_loc = loc , cab_incomps = placeHolderIncomps } where (env1, tvs') = tidyVarBndrs init_tidy_env tvs (env2, eta_tvs') = tidyVarBndrs env1 eta_tvs (env, cvs') = tidyVarBndrs env2 cvs -- See Note [Tidy axioms when we build them] -- See also Note [CoAxBranch type variables] in CoAxiom init_occ_env = initTidyOccEnv [mkTyVarOcc "_"] init_tidy_env = mkEmptyTidyEnv init_occ_env -- See Note [Always number wildcard types in CoAxBranch] -- all of the following code is here to avoid mutual dependencies with -- Coercion mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched mkBranchedCoAxiom ax_name fam_tc branches = CoAxiom { co_ax_unique = nameUnique ax_name , co_ax_name = ax_name , co_ax_tc = fam_tc , co_ax_role = Nominal , co_ax_implicit = False , co_ax_branches = manyBranches (computeAxiomIncomps branches) } mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched mkUnbranchedCoAxiom ax_name fam_tc branch = CoAxiom { co_ax_unique = nameUnique ax_name , co_ax_name = ax_name , co_ax_tc = fam_tc , co_ax_role = Nominal , co_ax_implicit = False , co_ax_branches = unbranched (branch { cab_incomps = [] }) } mkSingleCoAxiom :: Role -> Name -> [TyVar] -> [TyVar] -> [CoVar] -> TyCon -> [Type] -> Type -> CoAxiom Unbranched -- Make a single-branch CoAxiom, incluidng making the branch itself -- Used for both type family (Nominal) and data family (Representational) -- axioms, hence passing in the Role mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty = CoAxiom { co_ax_unique = nameUnique ax_name , co_ax_name = ax_name , co_ax_tc = fam_tc , co_ax_role = role , co_ax_implicit = False , co_ax_branches = unbranched (branch { cab_incomps = [] }) } where branch = mkCoAxBranch tvs eta_tvs cvs lhs_tys rhs_ty (map (const Nominal) tvs) (getSrcSpan ax_name) -- | Create a coercion constructor (axiom) suitable for the given -- newtype 'TyCon'. The 'Name' should be that of a new coercion -- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and -- the type the appropriate right hand side of the @newtype@, with -- the free variables a subset of those 'TyVar's. mkNewTypeCoAxiom :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched mkNewTypeCoAxiom name tycon tvs roles rhs_ty = CoAxiom { co_ax_unique = nameUnique name , co_ax_name = name , co_ax_implicit = True -- See Note [Implicit axioms] in TyCon , co_ax_role = Representational , co_ax_tc = tycon , co_ax_branches = unbranched (branch { cab_incomps = [] }) } where branch = mkCoAxBranch tvs [] [] (mkTyVarTys tvs) rhs_ty roles (getSrcSpan name) {- ************************************************************************ * * Looking up a family instance * * ************************************************************************ @lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match. Multiple matches are only possible in case of type families (not data families), and then, it doesn't matter which match we choose (as the instances are guaranteed confluent). We return the matching family instances and the type instance at which it matches. For example, if we lookup 'T [Int]' and have a family instance data instance T [a] = .. desugared to data :R42T a = .. coe :Co:R42T a :: T [a] ~ :R42T a we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'. -} -- when matching a type family application, we get a FamInst, -- and the list of types the axiom should be applied to data FamInstMatch = FamInstMatch { fim_instance :: FamInst , fim_tys :: [Type] , fim_cos :: [Coercion] } -- See Note [Over-saturated matches] instance Outputable FamInstMatch where ppr (FamInstMatch { fim_instance = inst , fim_tys = tys , fim_cos = cos }) = text "match with" <+> parens (ppr inst) <+> ppr tys <+> ppr cos lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst] lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc = get pkg_ie ++ get home_ie where get ie = case lookupUDFM ie fam_tc of Nothing -> [] Just (FamIE fis) -> fis lookupFamInstEnv :: FamInstEnvs -> TyCon -> [Type] -- What we are looking for -> [FamInstMatch] -- Successful matches -- Precondition: the tycon is saturated (or over-saturated) lookupFamInstEnv = lookup_fam_inst_env match where match _ _ tpl_tys tys = tcMatchTys tpl_tys tys lookupFamInstEnvConflicts :: FamInstEnvs -> FamInst -- Putative new instance -> [FamInstMatch] -- Conflicting matches (don't look at the fim_tys field) -- E.g. when we are about to add -- f : type instance F [a] = a->a -- we do (lookupFamInstConflicts f [b]) -- to find conflicting matches -- -- Precondition: the tycon is saturated (or over-saturated) lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) = lookup_fam_inst_env my_unify envs fam tys where (fam, tys) = famInstSplitLHS fam_inst -- In example above, fam tys' = F [b] my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _ = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs, (ppr fam <+> ppr tys) $$ (ppr tpl_tvs <+> ppr tpl_tys) ) -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch then Nothing else Just noSubst -- Note [Family instance overlap conflicts] noSubst = panic "lookupFamInstEnvConflicts noSubst" new_branch = coAxiomSingleBranch new_axiom -------------------------------------------------------------------------------- -- Type family injectivity checking bits -- -------------------------------------------------------------------------------- {- Note [Verifying injectivity annotation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Injectivity means that the RHS of a type family uniquely determines the LHS (see Note [Type inference for type families with injectivity]). The user informs us about injectivity using an injectivity annotation and it is GHC's task to verify that this annotation is correct w.r.t. type family equations. Whenever we see a new equation of a type family we need to make sure that adding this equation to the already known equations of a type family does not violate the injectivity annotation supplied by the user (see Note [Injectivity annotation]). Of course if the type family has no injectivity annotation then no check is required. But if a type family has injectivity annotation we need to make sure that the following conditions hold: 1. For each pair of *different* equations of a type family, one of the following conditions holds: A: RHSs are different. (Check done in FamInstEnv.injectiveBranches) B1: OPEN TYPE FAMILIES: If the RHSs can be unified under some substitution then it must be possible to unify the LHSs under the same substitution. Example: type family FunnyId a = r | r -> a type instance FunnyId Int = Int type instance FunnyId a = a RHSs of these two equations unify under [ a |-> Int ] substitution. Under this substitution LHSs are equal therefore these equations don't violate injectivity annotation. (Check done in FamInstEnv.injectiveBranches) B2: CLOSED TYPE FAMILIES: If the RHSs can be unified under some substitution then either the LHSs unify under the same substitution or the LHS of the latter equation is overlapped by earlier equations. Example 1: type family SwapIntChar a = r | r -> a where SwapIntChar Int = Char SwapIntChar Char = Int SwapIntChar a = a Say we are checking the last two equations. RHSs unify under [ a |-> Int ] substitution but LHSs don't. So we apply the substitution to LHS of last equation and check whether it is overlapped by any of previous equations. Since it is overlapped by the first equation we conclude that pair of last two equations does not violate injectivity annotation. (Check done in TcValidity.checkValidCoAxiom#gather_conflicts) A special case of B is when RHSs unify with an empty substitution ie. they are identical. If any of the above two conditions holds we conclude that the pair of equations does not violate injectivity annotation. But if we find a pair of equations where neither of the above holds we report that this pair violates injectivity annotation because for a given RHS we don't have a unique LHS. (Note that (B) actually implies (A).) Note that we only take into account these LHS patterns that were declared as injective. 2. If an RHS of a type family equation is a bare type variable then all LHS variables (including implicit kind variables) also have to be bare. In other words, this has to be a sole equation of that type family and it has to cover all possible patterns. So for example this definition will be rejected: type family W1 a = r | r -> a type instance W1 [a] = a If it were accepted we could call `W1 [W1 Int]`, which would reduce to `W1 Int` and then by injectivity we could conclude that `[W1 Int] ~ Int`, which is bogus. Checked FamInst.bareTvInRHSViolated. 3. If the RHS of a type family equation is a type family application then the type family is rejected as not injective. This is checked by FamInst.isTFHeaded. 4. If a LHS type variable that is declared as injective is not mentioned in an injective position in the RHS then the type family is rejected as not injective. "Injective position" means either an argument to a type constructor or argument to a type family on injective position. There are subtleties here. See Note [Coverage condition for injective type families] in FamInst. Check (1) must be done for all family instances (transitively) imported. Other checks (2-4) should be done just for locally written equations, as they are checks involving just a single equation, not about interactions. Doing the other checks for imported equations led to #17405, as the behavior of check (4) depends on -XUndecidableInstances (see Note [Coverage condition for injective type families] in FamInst), which may vary between modules. See also Note [Injective type families] in TyCon -} -- | Check whether an open type family equation can be added to already existing -- instance environment without causing conflicts with supplied injectivity -- annotations. Returns list of conflicting axioms (type instance -- declarations). lookupFamInstEnvInjectivityConflicts :: [Bool] -- injectivity annotation for this type family instance -- INVARIANT: list contains at least one True value -> FamInstEnvs -- all type instances seens so far -> FamInst -- new type instance that we're checking -> [CoAxBranch] -- conflicting instance declarations lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie) fam_inst@(FamInst { fi_axiom = new_axiom }) -- See Note [Verifying injectivity annotation]. This function implements -- check (1.B1) for open type families described there. = lookup_inj_fam_conflicts home_ie ++ lookup_inj_fam_conflicts pkg_ie where fam = famInstTyCon fam_inst new_branch = coAxiomSingleBranch new_axiom -- filtering function used by `lookup_inj_fam_conflicts` to check whether -- a pair of equations conflicts with the injectivity annotation. isInjConflict (FamInst { fi_axiom = old_axiom }) | InjectivityAccepted <- injectiveBranches injList (coAxiomSingleBranch old_axiom) new_branch = False -- no conflict | otherwise = True lookup_inj_fam_conflicts ie | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUDFM ie fam = map (coAxiomSingleBranch . fi_axiom) $ filter isInjConflict insts | otherwise = [] -------------------------------------------------------------------------------- -- Type family overlap checking bits -- -------------------------------------------------------------------------------- {- Note [Family instance overlap conflicts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - In the case of data family instances, any overlap is fundamentally a conflict (as these instances imply injective type mappings). - In the case of type family instances, overlap is admitted as long as the right-hand sides of the overlapping rules coincide under the overlap substitution. eg type instance F a Int = a type instance F Int b = b These two overlap on (F Int Int) but then both RHSs are Int, so all is well. We require that they are syntactically equal; anything else would be difficult to test for at this stage. -} ------------------------------------------------------------ -- Might be a one-way match or a unifier type MatchFun = FamInst -- The FamInst template -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst -> [Type] -- Target to match against -> Maybe TCvSubst lookup_fam_inst_env' -- The worker, local to this module :: MatchFun -> FamInstEnv -> TyCon -> [Type] -- What we are looking for -> [FamInstMatch] lookup_fam_inst_env' match_fun ie fam match_tys | isOpenFamilyTyCon fam , Just (FamIE insts) <- lookupUDFM ie fam = find insts -- The common case | otherwise = [] where find [] = [] find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs , fi_tys = tpl_tys }) : rest) -- Fast check for no match, uses the "rough match" fields | instanceCantMatch rough_tcs mb_tcs = find rest -- Proper check | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1 = (FamInstMatch { fim_instance = item , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2 , fim_cos = ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) substCoVars subst tpl_cvs }) : find rest -- No match => try next | otherwise = find rest where (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys -- Precondition: the tycon is saturated (or over-saturated) -- Deal with over-saturation -- See Note [Over-saturated matches] split_tys tpl_tys | isTypeFamilyTyCon fam = pre_rough_split_tys | otherwise = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys rough_tcs = roughMatchTcs match_tys1 in (rough_tcs, match_tys1, match_tys2) (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys pre_rough_split_tys = (roughMatchTcs pre_match_tys1, pre_match_tys1, pre_match_tys2) lookup_fam_inst_env -- The worker, local to this module :: MatchFun -> FamInstEnvs -> TyCon -> [Type] -- What we are looking for -> [FamInstMatch] -- Successful matches -- Precondition: the tycon is saturated (or over-saturated) lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys = lookup_fam_inst_env' match_fun home_ie fam tys ++ lookup_fam_inst_env' match_fun pkg_ie fam tys {- Note [Over-saturated matches] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's ok to look up an over-saturated type constructor. E.g. type family F a :: * -> * type instance F (a,b) = Either (a->b) The type instance gives rise to a newtype TyCon (at a higher kind which you can't do in Haskell!): newtype FPair a b = FP (Either (a->b)) Then looking up (F (Int,Bool) Char) will return a FamInstMatch (FPair, [Int,Bool,Char]) The "extra" type argument [Char] just stays on the end. We handle data families and type families separately here: * For type families, all instances of a type family must have the same arity, so we can precompute the split between the match_tys and the overflow tys. This is done in pre_rough_split_tys. * For data family instances, though, we need to re-split for each instance, because the breakdown might be different for each instance. Why? Because of eta reduction; see Note [Eta reduction for data families]. -} -- checks if one LHS is dominated by a list of other branches -- in other words, if an application would match the first LHS, it is guaranteed -- to match at least one of the others. The RHSs are ignored. -- This algorithm is conservative: -- True -> the LHS is definitely covered by the others -- False -> no information -- It is currently (Oct 2012) used only for generating errors for -- inaccessible branches. If these errors go unreported, no harm done. -- This is defined here to avoid a dependency from CoAxiom to Unify isDominatedBy :: CoAxBranch -> [CoAxBranch] -> Bool isDominatedBy branch branches = or $ map match branches where lhs = coAxBranchLHS branch match (CoAxBranch { cab_lhs = tys }) = isJust $ tcMatchTys tys lhs {- ************************************************************************ * * Choosing an axiom application * * ************************************************************************ The lookupFamInstEnv function does a nice job for *open* type families, but we also need to handle closed ones when normalising a type: -} reduceTyFamApp_maybe :: FamInstEnvs -> Role -- Desired role of result coercion -> TyCon -> [Type] -> Maybe (Coercion, Type) -- Attempt to do a *one-step* reduction of a type-family application -- but *not* newtypes -- Works on type-synonym families always; data-families only if -- the role we seek is representational -- It does *not* normlise the type arguments first, so this may not -- go as far as you want. If you want normalised type arguments, -- use normaliseTcArgs first. -- -- The TyCon can be oversaturated. -- Works on both open and closed families -- -- Always returns a *homogeneous* coercion -- type family reductions are always -- homogeneous reduceTyFamApp_maybe envs role tc tys | Phantom <- role = Nothing | case role of Representational -> isOpenFamilyTyCon tc _ -> isOpenTypeFamilyTyCon tc -- If we seek a representational coercion -- (e.g. the call in topNormaliseType_maybe) then we can -- unwrap data families as well as type-synonym families; -- otherwise only type-synonym families , FamInstMatch { fim_instance = FamInst { fi_axiom = ax } , fim_tys = inst_tys , fim_cos = inst_cos } : _ <- lookupFamInstEnv envs tc tys -- NB: Allow multiple matches because of compatible overlap = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos ty = pSnd (coercionKind co) in Just (co, ty) | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys = let co = mkAxInstCo role ax ind inst_tys inst_cos ty = pSnd (coercionKind co) in Just (co, ty) | Just ax <- isBuiltInSynFamTyCon_maybe tc , Just (coax,ts,ty) <- sfMatchFam ax tys = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts) in Just (co, ty) | otherwise = Nothing -- The axiom can be oversaturated. (Closed families only.) chooseBranch :: CoAxiom Branched -> [Type] -> Maybe (BranchIndex, [Type], [Coercion]) -- found match, with args chooseBranch axiom tys = do { let num_pats = coAxiomNumPats axiom (target_tys, extra_tys) = splitAt num_pats tys branches = coAxiomBranches axiom ; (ind, inst_tys, inst_cos) <- findBranch (unMkBranches branches) target_tys ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) } -- The axiom must *not* be oversaturated findBranch :: Array BranchIndex CoAxBranch -> [Type] -> Maybe (BranchIndex, [Type], [Coercion]) -- coercions relate requested types to returned axiom LHS at role N findBranch branches target_tys = foldr go Nothing (assocs branches) where go :: (BranchIndex, CoAxBranch) -> Maybe (BranchIndex, [Type], [Coercion]) -> Maybe (BranchIndex, [Type], [Coercion]) go (index, branch) other = let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs , cab_lhs = tpl_lhs , cab_incomps = incomps }) = branch in_scope = mkInScopeSet (unionVarSets $ map (tyCoVarsOfTypes . coAxBranchLHS) incomps) -- See Note [Flattening] below flattened_target = flattenTys in_scope target_tys in case tcMatchTys tpl_lhs target_tys of Just subst -- matching worked. now, check for apartness. | apartnessCheck flattened_target branch -> -- matching worked & we're apart from all incompatible branches. -- success ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs) -- failure. keep looking _ -> other -- | Do an apartness check, as described in the "Closed Type Families" paper -- (POPL '14). This should be used when determining if an equation -- ('CoAxBranch') of a closed type family can be used to reduce a certain target -- type family application. apartnessCheck :: [Type] -- ^ /flattened/ target arguments. Make sure -- they're flattened! See Note [Flattening]. -- (NB: This "flat" is a different -- "flat" than is used in TcFlatten.) -> CoAxBranch -- ^ the candidate equation we wish to use -- Precondition: this matches the target -> Bool -- ^ True <=> equation can fire apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps }) = all (isSurelyApart . tcUnifyTysFG (const BindMe) flattened_target . coAxBranchLHS) incomps where isSurelyApart SurelyApart = True isSurelyApart _ = False {- ************************************************************************ * * Looking up a family instance * * ************************************************************************ Note [Normalising types] ~~~~~~~~~~~~~~~~~~~~~~~~ The topNormaliseType function removes all occurrences of type families and newtypes from the top-level structure of a type. normaliseTcApp does the type family lookup and is fairly straightforward. normaliseType is a little more involved. The complication comes from the fact that a type family might be used in the kind of a variable bound in a forall. We wish to remove this type family application, but that means coming up with a fresh variable (with the new kind). Thus, we need a substitution to be built up as we recur through the type. However, an ordinary TCvSubst just won't do: when we hit a type variable whose kind has changed during normalisation, we need both the new type variable *and* the coercion. We could conjure up a new VarEnv with just this property, but a usable substitution environment already exists: LiftingContexts from the liftCoSubst family of functions, defined in Coercion. A LiftingContext maps a type variable to a coercion and a coercion variable to a pair of coercions. Let's ignore coercion variables for now. Because the coercion a type variable maps to contains the destination type (via coercionKind), we don't need to store that destination type separately. Thus, a LiftingContext has what we need: a map from type variables to (Coercion, Type) pairs. We also benefit because we can piggyback on the liftCoSubstVarBndr function to deal with binders. However, I had to modify that function to work with this application. Thus, we now have liftCoSubstVarBndrUsing, which takes a function used to process the kind of the binder. We don't wish to lift the kind, but instead normalise it. So, we pass in a callback function that processes the kind of the binder. After that brilliant explanation of all this, I'm sure you've forgotten the dangling reference to coercion variables. What do we do with those? Nothing at all. The point of normalising types is to remove type family applications, but there's no sense in removing these from coercions. We would just get back a new coercion witnessing the equality between the same types as the original coercion. Because coercions are irrelevant anyway, there is no point in doing this. So, whenever we encounter a coercion, we just say that it won't change. That's what the CoercionTy case is doing within normalise_type. Note [Normalisation and type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to be a bit careful about normalising in the presence of type synonyms (#13035). Suppose S is a type synonym, and we have S t1 t2 If S is family-free (on its RHS) we can just normalise t1 and t2 and reconstruct (S t1' t2'). Expanding S could not reveal any new redexes because type families are saturated. But if S has a type family on its RHS we expand /before/ normalising the args t1, t2. If we normalise t1, t2 first, we'll re-normalise them after expansion, and that can lead to /exponential/ behavour; see #13035. Notice, though, that expanding first can in principle duplicate t1,t2, which might contain redexes. I'm sure you could conjure up an exponential case by that route too, but it hasn't happened in practice yet! -} topNormaliseType :: FamInstEnvs -> Type -> Type topNormaliseType env ty = case topNormaliseType_maybe env ty of Just (_co, ty') -> ty' Nothing -> ty topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Coercion, Type) -- ^ Get rid of *outermost* (or toplevel) -- * type function redex -- * data family redex -- * newtypes -- returning an appropriate Representational coercion. Specifically, if -- topNormaliseType_maybe env ty = Just (co, ty') -- then -- (a) co :: ty ~R ty' -- (b) ty' is not a newtype, and is not a type-family or data-family redex -- -- However, ty' can be something like (Maybe (F ty)), where -- (F ty) is a redex. -- -- Always operates homogeneously: the returned type has the same kind as the -- original type, and the returned coercion is always homogeneous. topNormaliseType_maybe env ty = do { ((co, mkind_co), nty) <- topNormaliseTypeX stepper combine ty ; return $ case mkind_co of MRefl -> (co, nty) MCo kind_co -> let nty_casted = nty `mkCastTy` mkSymCo kind_co final_co = mkCoherenceRightCo Representational nty (mkSymCo kind_co) co in (final_co, nty_casted) } where stepper = unwrapNewTypeStepper' `composeSteppers` tyFamStepper combine (c1, mc1) (c2, mc2) = (c1 `mkTransCo` c2, mc1 `mkTransMCo` mc2) unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN) unwrapNewTypeStepper' rec_nts tc tys = mapStepResult (, MRefl) $ unwrapNewTypeStepper rec_nts tc tys -- second coercion below is the kind coercion relating the original type's kind -- to the normalised type's kind tyFamStepper :: NormaliseStepper (Coercion, MCoercionN) tyFamStepper rec_nts tc tys -- Try to step a type/data family = let (args_co, ntys, res_co) = normaliseTcArgs env Representational tc tys in case reduceTyFamApp_maybe env Representational tc ntys of Just (co, rhs) -> NS_Step rec_nts rhs (args_co `mkTransCo` co, MCo res_co) _ -> NS_Done --------------- normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type) -- See comments on normaliseType for the arguments of this function normaliseTcApp env role tc tys = initNormM env role (tyCoVarsOfTypes tys) $ normalise_tc_app tc tys -- See Note [Normalising types] about the LiftingContext normalise_tc_app :: TyCon -> [Type] -> NormM (Coercion, Type) normalise_tc_app tc tys | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys , not (isFamFreeTyCon tc) -- Expand and try again = -- A synonym with type families in the RHS -- Expand and try again -- See Note [Normalisation and type synonyms] normalise_type (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') | isFamilyTyCon tc = -- A type-family application do { env <- getEnv ; role <- getRole ; (args_co, ntys, res_co) <- normalise_tc_args tc tys ; case reduceTyFamApp_maybe env role tc ntys of Just (first_co, ty') -> do { (rest_co,nty) <- normalise_type ty' ; return (assemble_result role nty (args_co `mkTransCo` first_co `mkTransCo` rest_co) res_co) } _ -> -- No unique matching family instance exists; -- we do not do anything return (assemble_result role (mkTyConApp tc ntys) args_co res_co) } | otherwise = -- A synonym with no type families in the RHS; or data type etc -- Just normalise the arguments and rebuild do { (args_co, ntys, res_co) <- normalise_tc_args tc tys ; role <- getRole ; return (assemble_result role (mkTyConApp tc ntys) args_co res_co) } where assemble_result :: Role -- r, ambient role in NormM monad -> Type -- nty, result type, possibly of changed kind -> Coercion -- orig_ty ~r nty, possibly heterogeneous -> CoercionN -- typeKind(orig_ty) ~N typeKind(nty) -> (Coercion, Type) -- (co :: orig_ty ~r nty_casted, nty_casted) -- where nty_casted has same kind as orig_ty assemble_result r nty orig_to_nty kind_co = ( final_co, nty_old_kind ) where nty_old_kind = nty `mkCastTy` mkSymCo kind_co final_co = mkCoherenceRightCo r nty (mkSymCo kind_co) orig_to_nty --------------- -- | Normalise arguments to a tycon normaliseTcArgs :: FamInstEnvs -- ^ env't with family instances -> Role -- ^ desired role of output coercion -> TyCon -- ^ tc -> [Type] -- ^ tys -> (Coercion, [Type], CoercionN) -- ^ co :: tc tys ~ tc new_tys -- NB: co might not be homogeneous -- last coercion :: kind(tc tys) ~ kind(tc new_tys) normaliseTcArgs env role tc tys = initNormM env role (tyCoVarsOfTypes tys) $ normalise_tc_args tc tys normalise_tc_args :: TyCon -> [Type] -- tc tys -> NormM (Coercion, [Type], CoercionN) -- (co, new_tys), where -- co :: tc tys ~ tc new_tys; might not be homogeneous -- res_co :: typeKind(tc tys) ~N typeKind(tc new_tys) normalise_tc_args tc tys = do { role <- getRole ; (args_cos, nargs, res_co) <- normalise_args (tyConKind tc) (tyConRolesX role tc) tys ; return (mkTyConAppCo role tc args_cos, nargs, res_co) } --------------- normaliseType :: FamInstEnvs -> Role -- desired role of coercion -> Type -> (Coercion, Type) normaliseType env role ty = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty normalise_type :: Type -- old type -> NormM (Coercion, Type) -- (coercion, new type), where -- co :: old-type ~ new_type -- Normalise the input type, by eliminating *all* type-function redexes -- but *not* newtypes (which are visible to the programmer) -- Returns with Refl if nothing happens -- Does nothing to newtypes -- The returned coercion *must* be *homogeneous* -- See Note [Normalising types] -- Try not to disturb type synonyms if possible normalise_type ty = go ty where go (TyConApp tc tys) = normalise_tc_app tc tys go ty@(LitTy {}) = do { r <- getRole ; return (mkReflCo r ty, ty) } go (AppTy ty1 ty2) = go_app_tys ty1 [ty2] go ty@(FunTy { ft_arg = ty1, ft_res = ty2 }) = do { (co1, nty1) <- go ty1 ; (co2, nty2) <- go ty2 ; r <- getRole ; return (mkFunCo r co1 co2, ty { ft_arg = nty1, ft_res = nty2 }) } go (ForAllTy (Bndr tcvar vis) ty) = do { (lc', tv', h, ki') <- normalise_var_bndr tcvar ; (co, nty) <- withLC lc' $ normalise_type ty ; let tv2 = setTyVarKind tv' ki' ; return (mkForAllCo tv' h co, ForAllTy (Bndr tv2 vis) nty) } go (TyVarTy tv) = normalise_tyvar tv go (CastTy ty co) = do { (nco, nty) <- go ty ; lc <- getLC ; let co' = substRightCo lc co ; return (castCoercionKind nco Nominal ty nty co co' , mkCastTy nty co') } go (CoercionTy co) = do { lc <- getLC ; r <- getRole ; let right_co = substRightCo lc co ; return ( mkProofIrrelCo r (liftCoSubst Nominal lc (coercionType co)) co right_co , mkCoercionTy right_co ) } go_app_tys :: Type -- function -> [Type] -- args -> NormM (Coercion, Type) -- cf. TcFlatten.flatten_app_ty_args go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys) go_app_tys fun_ty arg_tys = do { (fun_co, nfun) <- go fun_ty ; case tcSplitTyConApp_maybe nfun of Just (tc, xis) -> do { (second_co, nty) <- go (mkTyConApp tc (xis ++ arg_tys)) -- flatten_app_ty_args avoids redundantly processing the xis, -- but that's a much more performance-sensitive function. -- This type normalisation is not called in a loop. ; return (mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransCo` second_co, nty) } Nothing -> do { (args_cos, nargs, res_co) <- normalise_args (typeKind nfun) (repeat Nominal) arg_tys ; role <- getRole ; let nty = mkAppTys nfun nargs nco = mkAppCos fun_co args_cos nty_casted = nty `mkCastTy` mkSymCo res_co final_co = mkCoherenceRightCo role nty (mkSymCo res_co) nco ; return (final_co, nty_casted) } } normalise_args :: Kind -- of the function -> [Role] -- roles at which to normalise args -> [Type] -- args -> NormM ([Coercion], [Type], Coercion) -- returns (cos, xis, res_co), where each xi is the normalised -- version of the corresponding type, each co is orig_arg ~ xi, -- and the res_co :: kind(f orig_args) ~ kind(f xis) -- NB: The xis might *not* have the same kinds as the input types, -- but the resulting application *will* be well-kinded -- cf. TcFlatten.flatten_args_slow normalise_args fun_ki roles args = do { normed_args <- zipWithM normalise1 roles args ; let (xis, cos, res_co) = simplifyArgsWorker ki_binders inner_ki fvs roles normed_args ; return (map mkSymCo cos, xis, mkSymCo res_co) } where (ki_binders, inner_ki) = splitPiTys fun_ki fvs = tyCoVarsOfTypes args -- flattener conventions are different from ours impedance_match :: NormM (Coercion, Type) -> NormM (Type, Coercion) impedance_match action = do { (co, ty) <- action ; return (ty, mkSymCo co) } normalise1 role ty = impedance_match $ withRole role $ normalise_type ty normalise_tyvar :: TyVar -> NormM (Coercion, Type) normalise_tyvar tv = ASSERT( isTyVar tv ) do { lc <- getLC ; r <- getRole ; return $ case liftCoSubstTyVar lc r tv of Just co -> (co, pSnd $ coercionKind co) Nothing -> (mkReflCo r ty, ty) } where ty = mkTyVarTy tv normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Coercion, Kind) normalise_var_bndr tcvar -- works for both tvar and covar = do { lc1 <- getLC ; env <- getEnv ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal ; return $ liftCoSubstVarBndrUsing callback lc1 tcvar } -- | a monad for the normalisation functions, reading 'FamInstEnvs', -- a 'LiftingContext', and a 'Role'. newtype NormM a = NormM { runNormM :: FamInstEnvs -> LiftingContext -> Role -> a } deriving (Functor) initNormM :: FamInstEnvs -> Role -> TyCoVarSet -- the in-scope variables -> NormM a -> a initNormM env role vars (NormM thing_inside) = thing_inside env lc role where in_scope = mkInScopeSet vars lc = emptyLiftingContext in_scope getRole :: NormM Role getRole = NormM (\ _ _ r -> r) getLC :: NormM LiftingContext getLC = NormM (\ _ lc _ -> lc) getEnv :: NormM FamInstEnvs getEnv = NormM (\ env _ _ -> env) withRole :: Role -> NormM a -> NormM a withRole r thing = NormM $ \ envs lc _old_r -> runNormM thing envs lc r withLC :: LiftingContext -> NormM a -> NormM a withLC lc thing = NormM $ \ envs _old_lc r -> runNormM thing envs lc r instance Monad NormM where ma >>= fmb = NormM $ \env lc r -> let a = runNormM ma env lc r in runNormM (fmb a) env lc r instance Applicative NormM where pure x = NormM $ \ _ _ _ -> x (<*>) = ap {- ************************************************************************ * * Flattening * * ************************************************************************ Note [Flattening] ~~~~~~~~~~~~~~~~~ As described in "Closed type families with overlapping equations" http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf we need to flatten core types before unifying them, when checking for "surely-apart" against earlier equations of a closed type family. Flattening means replacing all top-level uses of type functions with fresh variables, *taking care to preserve sharing*. That is, the type (Either (F a b) (F a b)) should flatten to (Either c c), never (Either c d). Here is a nice example of why it's all necessary: type family F a b where F Int Bool = Char F a b = Double type family G a -- open, no instances How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match, while the second equation does. But, before reducing, we must make sure that the target can never become (F Int Bool). Well, no matter what G Float becomes, it certainly won't become *both* Int and Bool, so indeed we're safe reducing (F (G Float) (G Float)) to Double. This is necessary not only to get more reductions (which we might be willing to give up on), but for substitutivity. If we have (F x x), we can see that (F x x) can reduce to Double. So, it had better be the case that (F blah blah) can reduce to Double, no matter what (blah) is! Flattening as done below ensures this. The algorithm works by building up a TypeMap TyVar, mapping type family applications to fresh variables. This mapping must be threaded through all the function calls, as any entry in the mapping must be propagated to all future nodes in the tree. The algorithm also must track the set of in-scope variables, in order to make fresh variables as it flattens. (We are far from a source of fresh Uniques.) See Wrinkle 2, below. There are wrinkles, of course: 1. The flattening algorithm must account for the possibility of inner `forall`s. (A `forall` seen here can happen only because of impredicativity. However, the flattening operation is an algorithm in Core, which is impredicative.) Suppose we have (forall b. F b) -> (forall b. F b). Of course, those two bs are entirely unrelated, and so we should certainly not flatten the two calls F b to the same variable. Instead, they must be treated separately. We thus carry a substitution that freshens variables; we must apply this substitution (in `coreFlattenTyFamApp`) before looking up an application in the environment. Note that the range of the substitution contains only TyVars, never anything else. For the sake of efficiency, we only apply this substitution when absolutely necessary. Namely: * We do not perform the substitution at all if it is empty. * We only need to worry about the arguments of a type family that are within the arity of said type family, so we can get away with not applying the substitution to any oversaturated type family arguments. * Importantly, we do /not/ achieve this substitution by recursively flattening the arguments, as this would be wrong. Consider `F (G a)`, where F and G are type families. We might decide that `F (G a)` flattens to `beta`. Later, the substitution is non-empty (but does not map `a`) and so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course, `F gamma` is unknown, and so we flatten it to `delta`, but it really should have been `beta`! Argh! Moral of the story: instead of flattening the arguments, just substitute them directly. 2. There are two different reasons we might add a variable to the in-scope set as we work: A. We have just invented a new flattening variable. B. We have entered a `forall`. Annoying here is that in-scope variable source (A) must be threaded through the calls. For example, consider (F b -> forall c. F c). Suppose that, when flattening F b, we invent a fresh variable c. Now, when we encounter (forall c. F c), we need to know c is already in scope so that we locally rename c to c'. However, if we don't thread through the in-scope set from one argument of (->) to the other, we won't know this and might get very confused. In contrast, source (B) increases only as we go deeper, as in-scope sets normally do. However, even here we must be careful. The TypeMap TyVar that contains mappings from type family applications to freshened variables will be threaded through both sides of (forall b. F b) -> (forall b. F b). We thus must make sure that the two `b`s don't get renamed to the same b1. (If they did, then looking up `F b1` would yield the same flatten var for each.) So, even though `forall`-bound variables should really be in the in-scope set only when they are in scope, we retain these variables even outside of their scope. This ensures that, if we enounter a fresh `forall`-bound b, we will rename it to b2, not b1. Note that keeping a larger in-scope set than strictly necessary is always OK, as in-scope sets are only ever used to avoid collisions. Sadly, the freshening substitution described in (1) really musn't bind variables outside of their scope: note that its domain is the *unrenamed* variables. This means that the substitution gets "pushed down" (like a reader monad) while the in-scope set gets threaded (like a state monad). Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst; instead, we just carry a TvSubstEnv down, tying it to the InScopeSet traveling separately as necessary. 3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k: type family F ty_1 ... ty_k :: res_k It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a flattening skolem. But we must instead flatten it to `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the type family. Why is this better? Consider the following concrete example from #16995: type family Param :: Type -> Type type family LookupParam (a :: Type) :: Type where LookupParam (f Char) = Bool LookupParam x = Int foo :: LookupParam (Param ()) foo = 42 In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if `alpha` is apart from `f Char`, so it won't fall through to the second equation. But since the `Param` type family has arity 0, we can instead flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is apart from `f Char`, permitting the second equation to be reached. Not only does this allow more programs to be accepted, it's also important for correctness. Not doing this was the root cause of the Core Lint error in #16995. flattenTys is defined here because of module dependencies. -} data FlattenEnv = FlattenEnv { fe_type_map :: TypeMap TyVar -- domain: exactly-saturated type family applications -- range: fresh variables , fe_in_scope :: InScopeSet } -- See Note [Flattening] emptyFlattenEnv :: InScopeSet -> FlattenEnv emptyFlattenEnv in_scope = FlattenEnv { fe_type_map = emptyTypeMap , fe_in_scope = in_scope } updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) } flattenTys :: InScopeSet -> [Type] -> [Type] -- See Note [Flattening] -- NB: the returned types may mention fresh type variables, -- arising from the flattening. We don't return the -- mapping from those fresh vars to the ty-fam -- applications they stand for (we could, but no need) flattenTys in_scope tys = snd $ coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys coreFlattenTys :: TvSubstEnv -> FlattenEnv -> [Type] -> (FlattenEnv, [Type]) coreFlattenTys subst = mapAccumL (coreFlattenTy subst) coreFlattenTy :: TvSubstEnv -> FlattenEnv -> Type -> (FlattenEnv, Type) coreFlattenTy subst = go where go env ty | Just ty' <- coreView ty = go env ty' go env (TyVarTy tv) | Just ty <- lookupVarEnv subst tv = (env, ty) | otherwise = let (env', ki) = go env (tyVarKind tv) in (env', mkTyVarTy $ setTyVarKind tv ki) go env (AppTy ty1 ty2) = let (env1, ty1') = go env ty1 (env2, ty2') = go env1 ty2 in (env2, AppTy ty1' ty2') go env (TyConApp tc tys) -- NB: Don't just check if isFamilyTyCon: this catches *data* families, -- which are generative and thus can be preserved during flattening | not (isGenerativeTyCon tc Nominal) = coreFlattenTyFamApp subst env tc tys | otherwise = let (env', tys') = coreFlattenTys subst env tys in (env', mkTyConApp tc tys') go env ty@(FunTy { ft_arg = ty1, ft_res = ty2 }) = let (env1, ty1') = go env ty1 (env2, ty2') = go env1 ty2 in (env2, ty { ft_arg = ty1', ft_res = ty2' }) go env (ForAllTy (Bndr tv vis) ty) = let (env1, subst', tv') = coreFlattenVarBndr subst env tv (env2, ty') = coreFlattenTy subst' env1 ty in (env2, ForAllTy (Bndr tv' vis) ty') go env ty@(LitTy {}) = (env, ty) go env (CastTy ty co) = let (env1, ty') = go env ty (env2, co') = coreFlattenCo subst env1 co in (env2, CastTy ty' co') go env (CoercionTy co) = let (env', co') = coreFlattenCo subst env co in (env', CoercionTy co') -- when flattening, we don't care about the contents of coercions. -- so, just return a fresh variable of the right (flattened) type coreFlattenCo :: TvSubstEnv -> FlattenEnv -> Coercion -> (FlattenEnv, Coercion) coreFlattenCo subst env co = (env2, mkCoVarCo covar) where fresh_name = mkFlattenFreshCoName (env1, kind') = coreFlattenTy subst env (coercionType co) covar = uniqAway (fe_in_scope env1) (mkCoVar fresh_name kind') -- Add the covar to the FlattenEnv's in-scope set. -- See Note [Flattening], wrinkle 2A. env2 = updateInScopeSet env1 (flip extendInScopeSet covar) coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar) coreFlattenVarBndr subst env tv = (env2, subst', tv') where -- See Note [Flattening], wrinkle 2B. kind = varType tv (env1, kind') = coreFlattenTy subst env kind tv' = uniqAway (fe_in_scope env1) (setVarType tv kind') subst' = extendVarEnv subst tv (mkTyVarTy tv') env2 = updateInScopeSet env1 (flip extendInScopeSet tv') coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv -> TyCon -- type family tycon -> [Type] -- args, already flattened -> (FlattenEnv, Type) coreFlattenTyFamApp tv_subst env fam_tc fam_args = case lookupTypeMap type_map fam_ty of Just tv -> (env', mkAppTys (mkTyVarTy tv) leftover_args') Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc tv = uniqAway in_scope $ mkTyVar tyvar_name (typeKind fam_ty) ty' = mkAppTys (mkTyVarTy tv) leftover_args' env'' = env' { fe_type_map = extendTypeMap type_map fam_ty tv , fe_in_scope = extendInScopeSet in_scope tv } in (env'', ty') where arity = tyConArity fam_tc tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args ) splitAt arity fam_args -- Apply the substitution before looking up an application in the -- environment. See Note [Flattening], wrinkle 1. -- NB: substTys short-cuts the common case when the substitution is empty. sat_fam_args' = substTys tcv_subst sat_fam_args (env', leftover_args') = coreFlattenTys tv_subst env leftover_args -- `fam_tc` may be over-applied to `fam_args` (see Note [Flattening], -- wrinkle 3), so we split it into the arguments needed to saturate it -- (sat_fam_args') and the rest (leftover_args') fam_ty = mkTyConApp fam_tc sat_fam_args' FlattenEnv { fe_type_map = type_map , fe_in_scope = in_scope } = env' mkFlattenFreshTyName :: Uniquable a => a -> Name mkFlattenFreshTyName unq = mkSysTvName (getUnique unq) (fsLit "flt") mkFlattenFreshCoName :: Name mkFlattenFreshCoName = mkSystemVarName (deriveUnique eqPrimTyConKey 71) (fsLit "flc") ghc-lib-parser-8.10.2.20200808/compiler/utils/FastFunctions.hs0000644000000000000000000000065113713635745021605 0ustar0000000000000000{- (c) The University of Glasgow, 2000-2006 -} {-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} module FastFunctions ( inlinePerformIO, ) where #include "GhclibHsVersions.h" import GhcPrelude () import GHC.Exts import GHC.IO (IO(..)) -- Just like unsafeDupablePerformIO, but we inline it. {-# INLINE inlinePerformIO #-} inlinePerformIO :: IO a -> a inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r ghc-lib-parser-8.10.2.20200808/compiler/utils/FastMutInt.hs0000644000000000000000000000321113713635745021050 0ustar0000000000000000{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -O2 #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected -- -- (c) The University of Glasgow 2002-2006 -- -- Unboxed mutable Ints module FastMutInt( FastMutInt, newFastMutInt, readFastMutInt, writeFastMutInt, FastMutPtr, newFastMutPtr, readFastMutPtr, writeFastMutPtr ) where import GhcPrelude import Data.Bits import GHC.Base import GHC.Ptr newFastMutInt :: IO FastMutInt readFastMutInt :: FastMutInt -> IO Int writeFastMutInt :: FastMutInt -> Int -> IO () newFastMutPtr :: IO FastMutPtr readFastMutPtr :: FastMutPtr -> IO (Ptr a) writeFastMutPtr :: FastMutPtr -> Ptr a -> IO () data FastMutInt = FastMutInt (MutableByteArray# RealWorld) newFastMutInt = IO $ \s -> case newByteArray# size s of { (# s, arr #) -> (# s, FastMutInt arr #) } where !(I# size) = finiteBitSize (0 :: Int) readFastMutInt (FastMutInt arr) = IO $ \s -> case readIntArray# arr 0# s of { (# s, i #) -> (# s, I# i #) } writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> case writeIntArray# arr 0# i s of { s -> (# s, () #) } data FastMutPtr = FastMutPtr (MutableByteArray# RealWorld) newFastMutPtr = IO $ \s -> case newByteArray# size s of { (# s, arr #) -> (# s, FastMutPtr arr #) } -- GHC assumes 'sizeof (Int) == sizeof (Ptr a)' where !(I# size) = finiteBitSize (0 :: Int) readFastMutPtr (FastMutPtr arr) = IO $ \s -> case readAddrArray# arr 0# s of { (# s, i #) -> (# s, Ptr i #) } writeFastMutPtr (FastMutPtr arr) (Ptr i) = IO $ \s -> case writeAddrArray# arr 0# i s of { s -> (# s, () #) } ghc-lib-parser-8.10.2.20200808/compiler/utils/FastString.hs0000644000000000000000000005677113713635745021121 0ustar0000000000000000-- (c) The University of Glasgow, 1997-2006 {-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected -- | -- There are two principal string types used internally by GHC: -- -- ['FastString'] -- -- * A compact, hash-consed, representation of character strings. -- * Comparison is O(1), and you can get a 'Unique.Unique' from them. -- * Generated by 'fsLit'. -- * Turn into 'Outputable.SDoc' with 'Outputable.ftext'. -- -- ['PtrString'] -- -- * Pointer and size of a Latin-1 encoded string. -- * Practically no operations. -- * Outputing them is fast. -- * Generated by 'sLit'. -- * Turn into 'Outputable.SDoc' with 'Outputable.ptext' -- * Requires manual memory management. -- Improper use may lead to memory leaks or dangling pointers. -- * It assumes Latin-1 as the encoding, therefore it cannot represent -- arbitrary Unicode strings. -- -- Use 'PtrString' unless you want the facilities of 'FastString'. module FastString ( -- * ByteString bytesFS, -- :: FastString -> ByteString fastStringToByteString, -- = bytesFS (kept for haddock) mkFastStringByteString, fastZStringToByteString, unsafeMkByteString, -- * FastZString FastZString, hPutFZS, zString, lengthFZS, -- * FastStrings FastString(..), -- not abstract, for now. -- ** Construction fsLit, mkFastString, mkFastStringBytes, mkFastStringByteList, mkFastStringForeignPtr, mkFastString#, -- ** Deconstruction unpackFS, -- :: FastString -> String -- ** Encoding zEncodeFS, -- ** Operations uniqueOfFS, lengthFS, nullFS, appendFS, headFS, tailFS, concatFS, consFS, nilFS, isUnderscoreFS, -- ** Outputing hPutFS, -- ** Internal getFastStringTable, getFastStringZEncCounter, -- * PtrStrings PtrString (..), -- ** Construction sLit, mkPtrString#, mkPtrString, -- ** Deconstruction unpackPtrString, -- ** Operations lengthPS ) where #include "GhclibHsVersions.h" import GhcPrelude as Prelude import Encoding import FastFunctions import PlainPanic import Util import Control.Concurrent.MVar import Control.DeepSeq import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Unsafe as BS import Foreign.C import GHC.Exts import System.IO import Data.Data import Data.IORef import Data.Char import Data.Semigroup as Semi import GHC.IO import Foreign #if GHC_STAGE >= 2 import GHC.Conc.Sync (sharedCAF) #endif import GHC.Base ( unpackCString#, unpackNBytes# ) -- | Gives the UTF-8 encoded bytes corresponding to a 'FastString' bytesFS :: FastString -> ByteString bytesFS f = fs_bs f {-# DEPRECATED fastStringToByteString "Use `bytesFS` instead" #-} fastStringToByteString :: FastString -> ByteString fastStringToByteString = bytesFS fastZStringToByteString :: FastZString -> ByteString fastZStringToByteString (FastZString bs) = bs -- This will drop information if any character > '\xFF' unsafeMkByteString :: String -> ByteString unsafeMkByteString = BSC.pack hashFastString :: FastString -> Int hashFastString (FastString _ _ bs _) = inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> return $ hashStr (castPtr ptr) len -- ----------------------------------------------------------------------------- newtype FastZString = FastZString ByteString deriving NFData hPutFZS :: Handle -> FastZString -> IO () hPutFZS handle (FastZString bs) = BS.hPut handle bs zString :: FastZString -> String zString (FastZString bs) = inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen lengthFZS :: FastZString -> Int lengthFZS (FastZString bs) = BS.length bs mkFastZStringString :: String -> FastZString mkFastZStringString str = FastZString (BSC.pack str) -- ----------------------------------------------------------------------------- {-| A 'FastString' is a UTF-8 encoded string together with a unique ID. All 'FastString's are stored in a global hashtable to support fast O(1) comparison. It is also associated with a lazy reference to the Z-encoding of this string which is used by the compiler internally. -} data FastString = FastString { uniq :: {-# UNPACK #-} !Int, -- unique id n_chars :: {-# UNPACK #-} !Int, -- number of chars fs_bs :: {-# UNPACK #-} !ByteString, fs_zenc :: FastZString -- ^ Lazily computed z-encoding of this string. -- -- Since 'FastString's are globally memoized this is computed at most -- once for any given string. } instance Eq FastString where f1 == f2 = uniq f1 == uniq f2 instance Ord FastString where -- Compares lexicographically, not by unique a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False } a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False } a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True } a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True } max x y | x >= y = x | otherwise = y min x y | x <= y = x | otherwise = y compare a b = cmpFS a b instance IsString FastString where fromString = fsLit instance Semi.Semigroup FastString where (<>) = appendFS instance Monoid FastString where mempty = nilFS mappend = (Semi.<>) mconcat = concatFS instance Show FastString where show fs = show (unpackFS fs) instance Data FastString where -- don't traverse? toConstr _ = abstractConstr "FastString" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "FastString" instance NFData FastString where rnf fs = seq fs () cmpFS :: FastString -> FastString -> Ordering cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) = if u1 == u2 then EQ else compare (bytesFS f1) (bytesFS f2) foreign import ccall unsafe "memcmp" memcmp :: Ptr a -> Ptr b -> Int -> IO Int -- ----------------------------------------------------------------------------- -- Construction {- Internally, the compiler will maintain a fast string symbol table, providing sharing and fast comparison. Creation of new @FastString@s then covertly does a lookup, re-using the @FastString@ if there was a hit. The design of the FastString hash table allows for lockless concurrent reads and updates to multiple buckets with low synchronization overhead. See Note [Updating the FastString table] on how it's updated. -} data FastStringTable = FastStringTable {-# UNPACK #-} !(IORef Int) -- the unique ID counter shared with all buckets {-# UNPACK #-} !(IORef Int) -- number of computed z-encodings for all buckets (Array# (IORef FastStringTableSegment)) -- concurrent segments data FastStringTableSegment = FastStringTableSegment {-# UNPACK #-} !(MVar ()) -- the lock for write in each segment {-# UNPACK #-} !(IORef Int) -- the number of elements (MutableArray# RealWorld [FastString]) -- buckets in this segment {- Following parameters are determined based on: * Benchmark based on testsuite/tests/utils/should_run/T14854.hs * Stats of @echo :browse | ghc --interactive -dfaststring-stats >/dev/null@: on 2018-10-24, we have 13920 entries. -} segmentBits, numSegments, segmentMask, initialNumBuckets :: Int segmentBits = 8 numSegments = 256 -- bit segmentBits segmentMask = 0xff -- bit segmentBits - 1 initialNumBuckets = 64 hashToSegment# :: Int# -> Int# hashToSegment# hash# = hash# `andI#` segmentMask# where !(I# segmentMask#) = segmentMask hashToIndex# :: MutableArray# RealWorld [FastString] -> Int# -> Int# hashToIndex# buckets# hash# = (hash# `uncheckedIShiftRL#` segmentBits#) `remInt#` size# where !(I# segmentBits#) = segmentBits size# = sizeofMutableArray# buckets# maybeResizeSegment :: IORef FastStringTableSegment -> IO FastStringTableSegment maybeResizeSegment segmentRef = do segment@(FastStringTableSegment lock counter old#) <- readIORef segmentRef let oldSize# = sizeofMutableArray# old# newSize# = oldSize# *# 2# (I# n#) <- readIORef counter if isTrue# (n# <# newSize#) -- maximum load of 1 then return segment else do resizedSegment@(FastStringTableSegment _ _ new#) <- IO $ \s1# -> case newArray# newSize# [] s1# of (# s2#, arr# #) -> (# s2#, FastStringTableSegment lock counter arr# #) forM_ [0 .. (I# oldSize#) - 1] $ \(I# i#) -> do fsList <- IO $ readArray# old# i# forM_ fsList $ \fs -> do let -- Shall we store in hash value in FastString instead? !(I# hash#) = hashFastString fs idx# = hashToIndex# new# hash# IO $ \s1# -> case readArray# new# idx# s1# of (# s2#, bucket #) -> case writeArray# new# idx# (fs: bucket) s2# of s3# -> (# s3#, () #) writeIORef segmentRef resizedSegment return resizedSegment {-# NOINLINE stringTable #-} stringTable :: FastStringTable stringTable = unsafePerformIO $ do let !(I# numSegments#) = numSegments !(I# initialNumBuckets#) = initialNumBuckets loop a# i# s1# | isTrue# (i# ==# numSegments#) = s1# | otherwise = case newMVar () `unIO` s1# of (# s2#, lock #) -> case newIORef 0 `unIO` s2# of (# s3#, counter #) -> case newArray# initialNumBuckets# [] s3# of (# s4#, buckets# #) -> case newIORef (FastStringTableSegment lock counter buckets#) `unIO` s4# of (# s5#, segment #) -> case writeArray# a# i# segment s5# of s6# -> loop a# (i# +# 1#) s6# uid <- newIORef 603979776 -- ord '$' * 0x01000000 n_zencs <- newIORef 0 tab <- IO $ \s1# -> case newArray# numSegments# (panic "string_table") s1# of (# s2#, arr# #) -> case loop arr# 0# s2# of s3# -> case unsafeFreezeArray# arr# s3# of (# s4#, segments# #) -> (# s4#, FastStringTable uid n_zencs segments# #) -- use the support wired into the RTS to share this CAF among all images of -- libHSghc #if GHC_STAGE < 2 return tab #else sharedCAF tab getOrSetLibHSghcFastStringTable -- from the RTS; thus we cannot use this mechanism when GHC_STAGE<2; the previous -- RTS might not have this symbol foreign import ccall unsafe "getOrSetLibHSghcFastStringTable" getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a) #endif {- We include the FastString table in the `sharedCAF` mechanism because we'd like FastStrings created by a Core plugin to have the same uniques as corresponding strings created by the host compiler itself. For example, this allows plugins to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or even re-invoke the parser. In particular, the following little sanity test was failing in a plugin prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not be looked up /by the plugin/. let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT" putMsgS $ showSDoc dflags $ ppr $ lookupGRE_RdrName rdrName $ mg_rdr_env guts `mkTcOcc` involves the lookup (or creation) of a FastString. Since the plugin's FastString.string_table is empty, constructing the RdrName also allocates new uniques for the FastStrings "GHC.NT.Type" and "NT". These uniques are almost certainly unequal to the ones that the host compiler originally assigned to those FastStrings. Thus the lookup fails since the domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's unique. Maintaining synchronization of the two instances of this global is rather difficult because of the uses of `unsafePerformIO` in this module. Not synchronizing them risks breaking the rather major invariant that two FastStrings with the same unique have the same string. Thus we use the lower-level `sharedCAF` mechanism that relies on Globals.c. -} mkFastString# :: Addr# -> FastString mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr) where ptr = Ptr a# {- Note [Updating the FastString table] We use a concurrent hashtable which contains multiple segments, each hash value always maps to the same segment. Read is lock-free, write to the a segment should acquire a lock for that segment to avoid race condition, writes to different segments are independent. The procedure goes like this: 1. Find out which segment to operate on based on the hash value 2. Read the relevant bucket and perform a look up of the string. 3. If it exists, return it. 4. Otherwise grab a unique ID, create a new FastString and atomically attempt to update the relevant segment with this FastString: * Resize the segment by doubling the number of buckets when the number of FastStrings in this segment grows beyond the threshold. * Double check that the string is not in the bucket. Another thread may have inserted it while we were creating our string. * Return the existing FastString if it exists. The one we preemptively created will get GCed. * Otherwise, insert and return the string we created. -} mkFastStringWith :: (Int -> IORef Int-> IO FastString) -> Ptr Word8 -> Int -> IO FastString mkFastStringWith mk_fs !ptr !len = do FastStringTableSegment lock _ buckets# <- readIORef segmentRef let idx# = hashToIndex# buckets# hash# bucket <- IO $ readArray# buckets# idx# res <- bucket_match bucket len ptr case res of Just found -> return found Nothing -> do -- The withMVar below is not dupable. It can lead to deadlock if it is -- only run partially and putMVar is not called after takeMVar. noDuplicate n <- get_uid new_fs <- mk_fs n n_zencs withMVar lock $ \_ -> insert new_fs where !(FastStringTable uid n_zencs segments#) = stringTable get_uid = atomicModifyIORef' uid $ \n -> (n+1,n) !(I# hash#) = hashStr ptr len (# segmentRef #) = indexArray# segments# (hashToSegment# hash#) insert fs = do FastStringTableSegment _ counter buckets# <- maybeResizeSegment segmentRef let idx# = hashToIndex# buckets# hash# bucket <- IO $ readArray# buckets# idx# res <- bucket_match bucket len ptr case res of -- The FastString was added by another thread after previous read and -- before we acquired the write lock. Just found -> return found Nothing -> do IO $ \s1# -> case writeArray# buckets# idx# (fs: bucket) s1# of s2# -> (# s2#, () #) modifyIORef' counter succ return fs bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString) bucket_match [] _ _ = return Nothing bucket_match (v@(FastString _ _ bs _):ls) len ptr | len == BS.length bs = do b <- BS.unsafeUseAsCString bs $ \buf -> cmpStringPrefix ptr (castPtr buf) len if b then return (Just v) else bucket_match ls len ptr | otherwise = bucket_match ls len ptr mkFastStringBytes :: Ptr Word8 -> Int -> FastString mkFastStringBytes !ptr !len = -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is -- idempotent. unsafeDupablePerformIO $ mkFastStringWith (copyNewFastString ptr len) ptr len -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference -- between this and 'mkFastStringBytes' is that we don't have to copy -- the bytes if the string is new to the table. mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString mkFastStringForeignPtr ptr !fp len = mkFastStringWith (mkNewFastString fp ptr len) ptr len -- | Create a 'FastString' from an existing 'ForeignPtr'; the difference -- between this and 'mkFastStringBytes' is that we don't have to copy -- the bytes if the string is new to the table. mkFastStringByteString :: ByteString -> FastString mkFastStringByteString bs = inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do let ptr' = castPtr ptr mkFastStringWith (mkNewFastStringByteString bs ptr' len) ptr' len -- | Creates a UTF-8 encoded 'FastString' from a 'String' mkFastString :: String -> FastString mkFastString str = inlinePerformIO $ do let l = utf8EncodedLength str buf <- mallocForeignPtrBytes l withForeignPtr buf $ \ptr -> do utf8EncodeString ptr str mkFastStringForeignPtr ptr buf l -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ mkFastStringByteList :: [Word8] -> FastString mkFastStringByteList str = mkFastStringByteString (BS.pack str) -- | Creates a (lazy) Z-encoded 'FastString' from a 'String' and account -- the number of forced z-strings into the passed 'IORef'. mkZFastString :: IORef Int -> ByteString -> FastZString mkZFastString n_zencs bs = unsafePerformIO $ do atomicModifyIORef' n_zencs $ \n -> (n+1, ()) return $ mkFastZStringString (zEncodeString (utf8DecodeByteString bs)) mkNewFastString :: ForeignPtr Word8 -> Ptr Word8 -> Int -> Int -> IORef Int -> IO FastString mkNewFastString fp ptr len uid n_zencs = do let bs = BS.fromForeignPtr fp 0 len zstr = mkZFastString n_zencs bs n_chars <- countUTF8Chars ptr len return (FastString uid n_chars bs zstr) mkNewFastStringByteString :: ByteString -> Ptr Word8 -> Int -> Int -> IORef Int -> IO FastString mkNewFastStringByteString bs ptr len uid n_zencs = do let zstr = mkZFastString n_zencs bs n_chars <- countUTF8Chars ptr len return (FastString uid n_chars bs zstr) copyNewFastString :: Ptr Word8 -> Int -> Int -> IORef Int -> IO FastString copyNewFastString ptr len uid n_zencs = do fp <- copyBytesToForeignPtr ptr len let bs = BS.fromForeignPtr fp 0 len zstr = mkZFastString n_zencs bs n_chars <- countUTF8Chars ptr len return (FastString uid n_chars bs zstr) copyBytesToForeignPtr :: Ptr Word8 -> Int -> IO (ForeignPtr Word8) copyBytesToForeignPtr ptr len = do fp <- mallocForeignPtrBytes len withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len return fp cmpStringPrefix :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool cmpStringPrefix ptr1 ptr2 len = do r <- memcmp ptr1 ptr2 len return (r == 0) hashStr :: Ptr Word8 -> Int -> Int -- use the Addr to produce a hash value between 0 & m (inclusive) hashStr (Ptr a#) (I# len#) = loop 0# 0# where loop h n = if isTrue# (n ==# len#) then I# h else let -- DO NOT move this let binding! indexCharOffAddr# reads from the -- pointer so we need to evaluate this based on the length check -- above. Not doing this right caused #17909. !c = ord# (indexCharOffAddr# a# n) !h2 = (h *# 16777619#) `xorI#` c in loop h2 (n +# 1#) -- ----------------------------------------------------------------------------- -- Operations -- | Returns the length of the 'FastString' in characters lengthFS :: FastString -> Int lengthFS f = n_chars f -- | Returns @True@ if the 'FastString' is empty nullFS :: FastString -> Bool nullFS f = BS.null (fs_bs f) -- | Unpacks and decodes the FastString unpackFS :: FastString -> String unpackFS (FastString _ _ bs _) = utf8DecodeByteString bs -- | Returns a Z-encoded version of a 'FastString'. This might be the -- original, if it was already Z-encoded. The first time this -- function is applied to a particular 'FastString', the results are -- memoized. -- zEncodeFS :: FastString -> FastZString zEncodeFS (FastString _ _ _ ref) = ref appendFS :: FastString -> FastString -> FastString appendFS fs1 fs2 = mkFastStringByteString $ BS.append (bytesFS fs1) (bytesFS fs2) concatFS :: [FastString] -> FastString concatFS = mkFastStringByteString . BS.concat . map fs_bs headFS :: FastString -> Char headFS (FastString _ 0 _ _) = panic "headFS: Empty FastString" headFS (FastString _ _ bs _) = inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> return (fst (utf8DecodeChar (castPtr ptr))) tailFS :: FastString -> FastString tailFS (FastString _ 0 _ _) = panic "tailFS: Empty FastString" tailFS (FastString _ _ bs _) = inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> do let (_, n) = utf8DecodeChar (castPtr ptr) return $! mkFastStringByteString (BS.drop n bs) consFS :: Char -> FastString -> FastString consFS c fs = mkFastString (c : unpackFS fs) uniqueOfFS :: FastString -> Int uniqueOfFS (FastString u _ _ _) = u nilFS :: FastString nilFS = mkFastString "" isUnderscoreFS :: FastString -> Bool isUnderscoreFS fs = fs == fsLit "_" -- ----------------------------------------------------------------------------- -- Stats getFastStringTable :: IO [[[FastString]]] getFastStringTable = forM [0 .. numSegments - 1] $ \(I# i#) -> do let (# segmentRef #) = indexArray# segments# i# FastStringTableSegment _ _ buckets# <- readIORef segmentRef let bucketSize = I# (sizeofMutableArray# buckets#) forM [0 .. bucketSize - 1] $ \(I# j#) -> IO $ readArray# buckets# j# where !(FastStringTable _ _ segments#) = stringTable getFastStringZEncCounter :: IO Int getFastStringZEncCounter = readIORef n_zencs where !(FastStringTable _ n_zencs _) = stringTable -- ----------------------------------------------------------------------------- -- Outputting 'FastString's -- |Outputs a 'FastString' with /no decoding at all/, that is, you -- get the actual bytes in the 'FastString' written to the 'Handle'. hPutFS :: Handle -> FastString -> IO () hPutFS handle fs = BS.hPut handle $ bytesFS fs -- ToDo: we'll probably want an hPutFSLocal, or something, to output -- in the current locale's encoding (for error messages and suchlike). -- ----------------------------------------------------------------------------- -- PtrStrings, here for convenience only. -- | A 'PtrString' is a pointer to some array of Latin-1 encoded chars. data PtrString = PtrString !(Ptr Word8) !Int -- | Wrap an unboxed address into a 'PtrString'. mkPtrString# :: Addr# -> PtrString mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#)) -- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1 -- encoding. The original string must not contain non-Latin-1 characters -- (above codepoint @0xff@). {-# INLINE mkPtrString #-} mkPtrString :: String -> PtrString mkPtrString s = -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks -- and because someone might be using `eqAddr#` to check for string equality. unsafePerformIO (do let len = length s p <- mallocBytes len let loop :: Int -> String -> IO () loop !_ [] = return () loop n (c:cs) = do pokeByteOff p n (fromIntegral (ord c) :: Word8) loop (1+n) cs loop 0 s return (PtrString p len) ) -- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding. -- This does not free the memory associated with 'PtrString'. unpackPtrString :: PtrString -> String unpackPtrString (PtrString (Ptr p#) (I# n#)) = unpackNBytes# p# n# -- | Return the length of a 'PtrString' lengthPS :: PtrString -> Int lengthPS (PtrString _ n) = n -- ----------------------------------------------------------------------------- -- under the carpet foreign import ccall unsafe "strlen" ptrStrLength :: Ptr Word8 -> Int {-# NOINLINE sLit #-} sLit :: String -> PtrString sLit x = mkPtrString x {-# NOINLINE fsLit #-} fsLit :: String -> FastString fsLit x = mkFastString x {-# RULES "slit" forall x . sLit (unpackCString# x) = mkPtrString# x #-} {-# RULES "fslit" forall x . fsLit (unpackCString# x) = mkFastString# x #-} ghc-lib-parser-8.10.2.20200808/compiler/utils/FastStringEnv.hs0000644000000000000000000000740613713635745021561 0ustar0000000000000000{- % % (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[FastStringEnv]{@FastStringEnv@: FastString environments} -} module FastStringEnv ( -- * FastString environments (maps) FastStringEnv, -- ** Manipulating these environments mkFsEnv, emptyFsEnv, unitFsEnv, extendFsEnv_C, extendFsEnv_Acc, extendFsEnv, extendFsEnvList, extendFsEnvList_C, filterFsEnv, plusFsEnv, plusFsEnv_C, alterFsEnv, lookupFsEnv, lookupFsEnv_NF, delFromFsEnv, delListFromFsEnv, elemFsEnv, mapFsEnv, -- * Deterministic FastString environments (maps) DFastStringEnv, -- ** Manipulating these environments mkDFsEnv, emptyDFsEnv, dFsEnvElts, lookupDFsEnv ) where import GhcPrelude import UniqFM import UniqDFM import Maybes import FastString -- | A non-deterministic set of FastStrings. -- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not -- deterministic and why it matters. Use DFastStringEnv if the set eventually -- gets converted into a list or folded over in a way where the order -- changes the generated code. type FastStringEnv a = UniqFM a -- Domain is FastString emptyFsEnv :: FastStringEnv a mkFsEnv :: [(FastString,a)] -> FastStringEnv a alterFsEnv :: (Maybe a-> Maybe a) -> FastStringEnv a -> FastString -> FastStringEnv a extendFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastString -> a -> FastStringEnv a extendFsEnv_Acc :: (a->b->b) -> (a->b) -> FastStringEnv b -> FastString -> a -> FastStringEnv b extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a plusFsEnv :: FastStringEnv a -> FastStringEnv a -> FastStringEnv a plusFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastStringEnv a -> FastStringEnv a extendFsEnvList :: FastStringEnv a -> [(FastString,a)] -> FastStringEnv a extendFsEnvList_C :: (a->a->a) -> FastStringEnv a -> [(FastString,a)] -> FastStringEnv a delFromFsEnv :: FastStringEnv a -> FastString -> FastStringEnv a delListFromFsEnv :: FastStringEnv a -> [FastString] -> FastStringEnv a elemFsEnv :: FastString -> FastStringEnv a -> Bool unitFsEnv :: FastString -> a -> FastStringEnv a lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a lookupFsEnv_NF :: FastStringEnv a -> FastString -> a filterFsEnv :: (elt -> Bool) -> FastStringEnv elt -> FastStringEnv elt mapFsEnv :: (elt1 -> elt2) -> FastStringEnv elt1 -> FastStringEnv elt2 emptyFsEnv = emptyUFM unitFsEnv x y = unitUFM x y extendFsEnv x y z = addToUFM x y z extendFsEnvList x l = addListToUFM x l lookupFsEnv x y = lookupUFM x y alterFsEnv = alterUFM mkFsEnv l = listToUFM l elemFsEnv x y = elemUFM x y plusFsEnv x y = plusUFM x y plusFsEnv_C f x y = plusUFM_C f x y extendFsEnv_C f x y z = addToUFM_C f x y z mapFsEnv f x = mapUFM f x extendFsEnv_Acc x y z a b = addToUFM_Acc x y z a b extendFsEnvList_C x y z = addListToUFM_C x y z delFromFsEnv x y = delFromUFM x y delListFromFsEnv x y = delListFromUFM x y filterFsEnv x y = filterUFM x y lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n) -- Deterministic FastStringEnv -- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need -- DFastStringEnv. type DFastStringEnv a = UniqDFM a -- Domain is FastString emptyDFsEnv :: DFastStringEnv a emptyDFsEnv = emptyUDFM dFsEnvElts :: DFastStringEnv a -> [a] dFsEnvElts = eltsUDFM mkDFsEnv :: [(FastString,a)] -> DFastStringEnv a mkDFsEnv l = listToUDFM l lookupDFsEnv :: DFastStringEnv a -> FastString -> Maybe a lookupDFsEnv = lookupUDFM ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/FieldLabel.hs0000644000000000000000000001017513713635744021751 0ustar0000000000000000{- % % (c) Adam Gundry 2013-2015 % This module defines the representation of FieldLabels as stored in TyCons. As well as a selector name, these have some extra structure to support the DuplicateRecordFields extension. In the normal case (with NoDuplicateRecordFields), a datatype like data T = MkT { foo :: Int } has FieldLabel { flLabel = "foo" , flIsOverloaded = False , flSelector = foo }. In particular, the Name of the selector has the same string representation as the label. If DuplicateRecordFields is enabled, however, the same declaration instead gives FieldLabel { flLabel = "foo" , flIsOverloaded = True , flSelector = $sel:foo:MkT }. Now the name of the selector ($sel:foo:MkT) does not match the label of the field (foo). We must be careful not to show the selector name to the user! The point of mangling the selector name is to allow a module to define the same field label in different datatypes: data T = MkT { foo :: Int } data U = MkU { foo :: Bool } Now there will be two FieldLabel values for 'foo', one in T and one in U. They share the same label (FieldLabelString), but the selector functions differ. See also Note [Representing fields in AvailInfo] in Avail. Note [Why selector names include data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As explained above, a selector name includes the name of the first data constructor in the type, so that the same label can appear multiple times in the same module. (This is irrespective of whether the first constructor has that field, for simplicity.) We use a data constructor name, rather than the type constructor name, because data family instances do not have a representation type constructor name generated until relatively late in the typechecking process. Of course, datatypes with no constructors cannot have any fields. -} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE StandaloneDeriving #-} module FieldLabel ( FieldLabelString , FieldLabelEnv , FieldLbl(..) , FieldLabel , mkFieldLabelOccs ) where import GhcPrelude import OccName import Name import FastString import FastStringEnv import Outputable import Binary import Data.Data -- | Field labels are just represented as strings; -- they are not necessarily unique (even within a module) type FieldLabelString = FastString -- | A map from labels to all the auxiliary information type FieldLabelEnv = DFastStringEnv FieldLabel type FieldLabel = FieldLbl Name -- | Fields in an algebraic record type data FieldLbl a = FieldLabel { flLabel :: FieldLabelString, -- ^ User-visible label of the field flIsOverloaded :: Bool, -- ^ Was DuplicateRecordFields on -- in the defining module for this datatype? flSelector :: a -- ^ Record selector function } deriving (Eq, Functor, Foldable, Traversable) deriving instance Data a => Data (FieldLbl a) instance Outputable a => Outputable (FieldLbl a) where ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl)) instance Binary a => Binary (FieldLbl a) where put_ bh (FieldLabel aa ab ac) = do put_ bh aa put_ bh ab put_ bh ac get bh = do ab <- get bh ac <- get bh ad <- get bh return (FieldLabel ab ac ad) -- | Record selector OccNames are built from the underlying field name -- and the name of the first data constructor of the type, to support -- duplicate record field names. -- See Note [Why selector names include data constructors]. mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName mkFieldLabelOccs lbl dc is_overloaded = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded , flSelector = sel_occ } where str = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc sel_occ | is_overloaded = mkRecFldSelOcc str | otherwise = mkVarOccFS lbl ghc-lib-parser-8.10.2.20200808/compiler/main/FileCleanup.hs0000644000000000000000000002671013713635745020776 0ustar0000000000000000{-# LANGUAGE CPP #-} module FileCleanup ( TempFileLifetime(..) , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles , addFilesToClean, changeTempFilesLifetime , newTempName, newTempLibName, newTempDir , withSystemTempDirectory, withTempDirectory ) where import GhcPrelude import DynFlags import ErrUtils import Outputable import Util import Exception import DriverPhases import Control.Monad import Data.List import qualified Data.Set as Set import qualified Data.Map as Map import Data.IORef import System.Directory import System.FilePath import System.IO.Error #if !defined(mingw32_HOST_OS) import qualified System.Posix.Internals #endif -- | Used when a temp file is created. This determines which component Set of -- FilesToClean will get the temp file data TempFileLifetime = TFL_CurrentModule -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the -- end of upweep_mod | TFL_GhcSession -- ^ A file with lifetime TFL_GhcSession will be cleaned up at the end of -- runGhc(T) deriving (Show) cleanTempDirs :: DynFlags -> IO () cleanTempDirs dflags = unless (gopt Opt_KeepTmpFiles dflags) $ mask_ $ do let ref = dirsToClean dflags ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds) removeTmpDirs dflags (Map.elems ds) -- | Delete all files in @filesToClean dflags@. cleanTempFiles :: DynFlags -> IO () cleanTempFiles dflags = unless (gopt Opt_KeepTmpFiles dflags) $ mask_ $ do let ref = filesToClean dflags to_delete <- atomicModifyIORef' ref $ \FilesToClean { ftcCurrentModule = cm_files , ftcGhcSession = gs_files } -> ( emptyFilesToClean , Set.toList cm_files ++ Set.toList gs_files) removeTmpFiles dflags to_delete -- | Delete all files in @filesToClean dflags@. That have lifetime -- TFL_CurrentModule. -- If a file must be cleaned eventually, but must survive a -- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession. cleanCurrentModuleTempFiles :: DynFlags -> IO () cleanCurrentModuleTempFiles dflags = unless (gopt Opt_KeepTmpFiles dflags) $ mask_ $ do let ref = filesToClean dflags to_delete <- atomicModifyIORef' ref $ \ftc@FilesToClean{ftcCurrentModule = cm_files} -> (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files) removeTmpFiles dflags to_delete -- | Ensure that new_files are cleaned on the next call of -- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime. -- If any of new_files are already tracked, they will have their lifetime -- updated. addFilesToClean :: DynFlags -> TempFileLifetime -> [FilePath] -> IO () addFilesToClean dflags lifetime new_files = modifyIORef' (filesToClean dflags) $ \FilesToClean { ftcCurrentModule = cm_files , ftcGhcSession = gs_files } -> case lifetime of TFL_CurrentModule -> FilesToClean { ftcCurrentModule = cm_files `Set.union` new_files_set , ftcGhcSession = gs_files `Set.difference` new_files_set } TFL_GhcSession -> FilesToClean { ftcCurrentModule = cm_files `Set.difference` new_files_set , ftcGhcSession = gs_files `Set.union` new_files_set } where new_files_set = Set.fromList new_files -- | Update the lifetime of files already being tracked. If any files are -- not being tracked they will be discarded. changeTempFilesLifetime :: DynFlags -> TempFileLifetime -> [FilePath] -> IO () changeTempFilesLifetime dflags lifetime files = do FilesToClean { ftcCurrentModule = cm_files , ftcGhcSession = gs_files } <- readIORef (filesToClean dflags) let old_set = case lifetime of TFL_CurrentModule -> gs_files TFL_GhcSession -> cm_files existing_files = [f | f <- files, f `Set.member` old_set] addFilesToClean dflags lifetime existing_files -- Return a unique numeric temp file suffix newTempSuffix :: DynFlags -> IO Int newTempSuffix dflags = atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n) -- Find a temporary name that doesn't already exist. newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath newTempName dflags lifetime extn = do d <- getTempDir dflags findTempName (d "ghc_") -- See Note [Deterministic base name] where findTempName :: FilePath -> IO FilePath findTempName prefix = do n <- newTempSuffix dflags let filename = prefix ++ show n <.> extn b <- doesFileExist filename if b then findTempName prefix else do -- clean it up later addFilesToClean dflags lifetime [filename] return filename newTempDir :: DynFlags -> IO FilePath newTempDir dflags = do d <- getTempDir dflags findTempDir (d "ghc_") where findTempDir :: FilePath -> IO FilePath findTempDir prefix = do n <- newTempSuffix dflags let filename = prefix ++ show n b <- doesDirectoryExist filename if b then findTempDir prefix else do createDirectory filename -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename return filename newTempLibName :: DynFlags -> TempFileLifetime -> Suffix -> IO (FilePath, FilePath, String) newTempLibName dflags lifetime extn = do d <- getTempDir dflags findTempName d ("ghc_") where findTempName :: FilePath -> String -> IO (FilePath, FilePath, String) findTempName dir prefix = do n <- newTempSuffix dflags -- See Note [Deterministic base name] let libname = prefix ++ show n filename = dir "lib" ++ libname <.> extn b <- doesFileExist filename if b then findTempName dir prefix else do -- clean it up later addFilesToClean dflags lifetime [filename] return (filename, dir, libname) -- Return our temporary directory within tmp_dir, creating one if we -- don't have one yet. getTempDir :: DynFlags -> IO FilePath getTempDir dflags = do mapping <- readIORef dir_ref case Map.lookup tmp_dir mapping of Nothing -> do pid <- getProcessID let prefix = tmp_dir "ghc" ++ show pid ++ "_" mask_ $ mkTempDir prefix Just dir -> return dir where tmp_dir = tmpDir dflags dir_ref = dirsToClean dflags mkTempDir :: FilePath -> IO FilePath mkTempDir prefix = do n <- newTempSuffix dflags let our_dir = prefix ++ show n -- 1. Speculatively create our new directory. createDirectory our_dir -- 2. Update the dirsToClean mapping unless an entry already exists -- (i.e. unless another thread beat us to it). their_dir <- atomicModifyIORef' dir_ref $ \mapping -> case Map.lookup tmp_dir mapping of Just dir -> (mapping, Just dir) Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing) -- 3. If there was an existing entry, return it and delete the -- directory we created. Otherwise return the directory we created. case their_dir of Nothing -> do debugTraceMsg dflags 2 $ text "Created temporary directory:" <+> text our_dir return our_dir Just dir -> do removeDirectory our_dir return dir `catchIO` \e -> if isAlreadyExistsError e then mkTempDir prefix else ioError e {- Note [Deterministic base name] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The filename of temporary files, especially the basename of C files, can end up in the output in some form, e.g. as part of linker debug information. In the interest of bit-wise exactly reproducible compilation (#4012), the basename of the temporary file no longer contains random information (it used to contain the process id). This is ok, as the temporary directory used contains the pid (see getTempDir). -} removeTmpDirs :: DynFlags -> [FilePath] -> IO () removeTmpDirs dflags ds = traceCmd dflags "Deleting temp dirs" ("Deleting: " ++ unwords ds) (mapM_ (removeWith dflags removeDirectory) ds) removeTmpFiles :: DynFlags -> [FilePath] -> IO () removeTmpFiles dflags fs = warnNon $ traceCmd dflags "Deleting temp files" ("Deleting: " ++ unwords deletees) (mapM_ (removeWith dflags removeFile) deletees) where -- Flat out refuse to delete files that are likely to be source input -- files (is there a worse bug than having a compiler delete your source -- files?) -- -- Deleting source files is a sign of a bug elsewhere, so prominently flag -- the condition. warnNon act | null non_deletees = act | otherwise = do putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees)) act (non_deletees, deletees) = partition isHaskellUserSrcFilename fs removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () removeWith dflags remover f = remover f `catchIO` (\e -> let msg = if isDoesNotExistError e then text "Warning: deleting non-existent" <+> text f else text "Warning: exception raised when deleting" <+> text f <> colon $$ text (show e) in debugTraceMsg dflags 2 msg ) #if defined(mingw32_HOST_OS) -- relies on Int == Int32 on Windows foreign import ccall unsafe "_getpid" getProcessID :: IO Int #else getProcessID :: IO Int getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral #endif -- The following three functions are from the `temporary` package. -- | Create and use a temporary directory in the system standard temporary -- directory. -- -- Behaves exactly the same as 'withTempDirectory', except that the parent -- temporary directory will be that returned by 'getTemporaryDirectory'. withSystemTempDirectory :: String -- ^ Directory name template. See 'openTempFile'. -> (FilePath -> IO a) -- ^ Callback that can use the directory -> IO a withSystemTempDirectory template action = getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action -- | Create and use a temporary directory. -- -- Creates a new temporary directory inside the given directory, making use -- of the template. The temp directory is deleted after use. For example: -- -- > withTempDirectory "src" "sdist." $ \tmpDir -> do ... -- -- The @tmpDir@ will be a new subdirectory of the given directory, e.g. -- @src/sdist.342@. withTempDirectory :: FilePath -- ^ Temp directory to create the directory in -> String -- ^ Directory name template. See 'openTempFile'. -> (FilePath -> IO a) -- ^ Callback that can use the directory -> IO a withTempDirectory targetDir template = Exception.bracket (createTempDirectory targetDir template) (ignoringIOErrors . removeDirectoryRecursive) ignoringIOErrors :: IO () -> IO () ignoringIOErrors ioe = ioe `catch` (\e -> const (return ()) (e :: IOError)) createTempDirectory :: FilePath -> String -> IO FilePath createTempDirectory dir template = do pid <- getProcessID findTempName pid where findTempName x = do let path = dir template ++ show x createDirectory path return path `catchIO` \e -> if isAlreadyExistsError e then findTempName (x+1) else ioError e ghc-lib-parser-8.10.2.20200808/compiler/main/FileSettings.hs0000644000000000000000000000111513713635745021177 0ustar0000000000000000module FileSettings ( FileSettings (..) ) where import GhcPrelude -- | Paths to various files and directories used by GHC, including those that -- provide more settings. data FileSettings = FileSettings { fileSettings_ghcUsagePath :: FilePath -- ditto , fileSettings_ghciUsagePath :: FilePath -- ditto , fileSettings_toolDir :: Maybe FilePath -- ditto , fileSettings_topDir :: FilePath -- ditto , fileSettings_tmpDir :: String -- no trailing '/' , fileSettings_systemPackageConfig :: FilePath } ghc-lib-parser-8.10.2.20200808/compiler/utils/Fingerprint.hs0000644000000000000000000000247313713635745021312 0ustar0000000000000000{-# LANGUAGE CPP #-} -- ---------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2006 -- -- Fingerprints for recompilation checking and ABI versioning. -- -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance -- -- ---------------------------------------------------------------------------- module Fingerprint ( readHexFingerprint, fingerprintByteString, -- * Re-exported from GHC.Fingerprint Fingerprint(..), fingerprint0, fingerprintFingerprints, fingerprintData, fingerprintString, getFileHash ) where #include "GhclibHsVersions.h" import GhcPrelude import Foreign import GHC.IO import Numeric ( readHex ) import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import GHC.Fingerprint -- useful for parsing the output of 'md5sum', should we want to do that. readHexFingerprint :: String -> Fingerprint readHexFingerprint s = Fingerprint w1 w2 where (s1,s2) = splitAt 16 s [(w1,"")] = readHex s1 [(w2,"")] = readHex (take 16 s2) fingerprintByteString :: BS.ByteString -> Fingerprint fingerprintByteString bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len ghc-lib-parser-8.10.2.20200808/compiler/utils/FiniteMap.hs0000644000000000000000000000162413713635745020674 0ustar0000000000000000-- Some extra functions to extend Data.Map module FiniteMap ( insertList, insertListWith, deleteList, foldRight, foldRightWithKey ) where import GhcPrelude import Data.Map (Map) import qualified Data.Map as Map insertList :: Ord key => [(key,elt)] -> Map key elt -> Map key elt insertList xs m = foldl' (\m (k, v) -> Map.insert k v m) m xs insertListWith :: Ord key => (elt -> elt -> elt) -> [(key,elt)] -> Map key elt -> Map key elt insertListWith f xs m0 = foldl' (\m (k, v) -> Map.insertWith f k v m) m0 xs deleteList :: Ord key => [key] -> Map key elt -> Map key elt deleteList ks m = foldl' (flip Map.delete) m ks foldRight :: (elt -> a -> a) -> a -> Map key elt -> a foldRight = Map.foldr foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a foldRightWithKey = Map.foldrWithKey ghc-lib-parser-8.10.2.20200808/compiler/prelude/ForeignCall.hs0000644000000000000000000002724513713635745021514 0ustar0000000000000000{- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[Foreign]{Foreign calls} -} {-# LANGUAGE DeriveDataTypeable #-} module ForeignCall ( ForeignCall(..), isSafeForeignCall, Safety(..), playSafe, playInterruptible, CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, CCallSpec(..), CCallTarget(..), isDynamicTarget, CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, Header(..), CType(..), ) where import GhcPrelude import FastString import Binary import Outputable import Module import BasicTypes ( SourceText, pprWithSourceText ) import Data.Char import Data.Data {- ************************************************************************ * * \subsubsection{Data types} * * ************************************************************************ -} newtype ForeignCall = CCall CCallSpec deriving Eq isSafeForeignCall :: ForeignCall -> Bool isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe -- We may need more clues to distinguish foreign calls -- but this simple printer will do for now instance Outputable ForeignCall where ppr (CCall cc) = ppr cc data Safety = PlaySafe -- Might invoke Haskell GC, or do a call back, or -- switch threads, etc. So make sure things are -- tidy before the call. Additionally, in the threaded -- RTS we arrange for the external call to be executed -- by a separate OS thread, i.e., _concurrently_ to the -- execution of other Haskell threads. | PlayInterruptible -- Like PlaySafe, but additionally -- the worker thread running this foreign call may -- be unceremoniously killed, so it must be scheduled -- on an unbound thread. | PlayRisky -- None of the above can happen; the call will return -- without interacting with the runtime system at all deriving ( Eq, Show, Data ) -- Show used just for Show Lex.Token, I think instance Outputable Safety where ppr PlaySafe = text "safe" ppr PlayInterruptible = text "interruptible" ppr PlayRisky = text "unsafe" playSafe :: Safety -> Bool playSafe PlaySafe = True playSafe PlayInterruptible = True playSafe PlayRisky = False playInterruptible :: Safety -> Bool playInterruptible PlayInterruptible = True playInterruptible _ = False {- ************************************************************************ * * \subsubsection{Calling C} * * ************************************************************************ -} data CExportSpec = CExportStatic -- foreign export ccall foo :: ty SourceText -- of the CLabelString. -- See note [Pragma source text] in BasicTypes CLabelString -- C Name of exported function CCallConv deriving Data data CCallSpec = CCallSpec CCallTarget -- What to call CCallConv -- Calling convention to use. Safety deriving( Eq ) -- The call target: -- | How to call a particular function in C-land. data CCallTarget -- An "unboxed" ccall# to named function in a particular package. = StaticTarget SourceText -- of the CLabelString. -- See note [Pragma source text] in BasicTypes CLabelString -- C-land name of label. (Maybe UnitId) -- What package the function is in. -- If Nothing, then it's taken to be in the current package. -- Note: This information is only used for PrimCalls on Windows. -- See CLabel.labelDynamic and CoreToStg.coreToStgApp -- for the difference in representation between PrimCalls -- and ForeignCalls. If the CCallTarget is representing -- a regular ForeignCall then it's safe to set this to Nothing. -- The first argument of the import is the name of a function pointer (an Addr#). -- Used when importing a label as "foreign import ccall "dynamic" ..." Bool -- True => really a function -- False => a value; only -- allowed in CAPI imports | DynamicTarget deriving( Eq, Data ) isDynamicTarget :: CCallTarget -> Bool isDynamicTarget DynamicTarget = True isDynamicTarget _ = False {- Stuff to do with calling convention: ccall: Caller allocates parameters, *and* deallocates them. stdcall: Caller allocates parameters, callee deallocates. Function name has @N after it, where N is number of arg bytes e.g. _Foo@8. This convention is x86 (win32) specific. See: http://www.programmersheaven.com/2/Calling-conventions -} -- any changes here should be replicated in the CallConv type in template haskell data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv deriving (Eq, Data) instance Outputable CCallConv where ppr StdCallConv = text "stdcall" ppr CCallConv = text "ccall" ppr CApiConv = text "capi" ppr PrimCallConv = text "prim" ppr JavaScriptCallConv = text "javascript" defaultCCallConv :: CCallConv defaultCCallConv = CCallConv ccallConvToInt :: CCallConv -> Int ccallConvToInt StdCallConv = 0 ccallConvToInt CCallConv = 1 ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv" ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv" ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv" {- Generate the gcc attribute corresponding to the given calling convention (used by PprAbsC): -} ccallConvAttribute :: CCallConv -> SDoc ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))" ccallConvAttribute CCallConv = empty ccallConvAttribute CApiConv = empty ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv" ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv" type CLabelString = FastString -- A C label, completely unencoded pprCLabelString :: CLabelString -> SDoc pprCLabelString lbl = ftext lbl isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label isCLabelString lbl = all ok (unpackFS lbl) where ok c = isAlphaNum c || c == '_' || c == '.' -- The '.' appears in e.g. "foo.so" in the -- module part of a ExtName. Maybe it should be separate -- Printing into C files: instance Outputable CExportSpec where ppr (CExportStatic _ str _) = pprCLabelString str instance Outputable CCallSpec where ppr (CCallSpec fun cconv safety) = hcat [ whenPprDebug callconv, ppr_fun fun ] where callconv = text "{-" <> ppr cconv <> text "-}" gc_suf | playSafe safety = text "_GC" | otherwise = empty ppr_fun (StaticTarget st _fn mPkgId isFun) = text (if isFun then "__pkg_ccall" else "__pkg_ccall_value") <> gc_suf <+> (case mPkgId of Nothing -> empty Just pkgId -> ppr pkgId) <+> (pprWithSourceText st empty) ppr_fun DynamicTarget = text "__dyn_ccall" <> gc_suf <+> text "\"\"" -- The filename for a C header file -- Note [Pragma source text] in BasicTypes data Header = Header SourceText FastString deriving (Eq, Data) instance Outputable Header where ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h) -- | A C type, used in CAPI FFI calls -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@, -- 'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal', -- 'ApiAnnotation.AnnClose' @'\#-}'@, -- For details on above see note [Api annotations] in ApiAnnotation data CType = CType SourceText -- Note [Pragma source text] in BasicTypes (Maybe Header) -- header to include for this type (SourceText,FastString) -- the type itself deriving (Eq, Data) instance Outputable CType where ppr (CType stp mh (stct,ct)) = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}" where hDoc = case mh of Nothing -> empty Just h -> ppr h {- ************************************************************************ * * \subsubsection{Misc} * * ************************************************************************ -} instance Binary ForeignCall where put_ bh (CCall aa) = put_ bh aa get bh = do aa <- get bh; return (CCall aa) instance Binary Safety where put_ bh PlaySafe = do putByte bh 0 put_ bh PlayInterruptible = do putByte bh 1 put_ bh PlayRisky = do putByte bh 2 get bh = do h <- getByte bh case h of 0 -> do return PlaySafe 1 -> do return PlayInterruptible _ -> do return PlayRisky instance Binary CExportSpec where put_ bh (CExportStatic ss aa ab) = do put_ bh ss put_ bh aa put_ bh ab get bh = do ss <- get bh aa <- get bh ab <- get bh return (CExportStatic ss aa ab) instance Binary CCallSpec where put_ bh (CCallSpec aa ab ac) = do put_ bh aa put_ bh ab put_ bh ac get bh = do aa <- get bh ab <- get bh ac <- get bh return (CCallSpec aa ab ac) instance Binary CCallTarget where put_ bh (StaticTarget ss aa ab ac) = do putByte bh 0 put_ bh ss put_ bh aa put_ bh ab put_ bh ac put_ bh DynamicTarget = do putByte bh 1 get bh = do h <- getByte bh case h of 0 -> do ss <- get bh aa <- get bh ab <- get bh ac <- get bh return (StaticTarget ss aa ab ac) _ -> do return DynamicTarget instance Binary CCallConv where put_ bh CCallConv = do putByte bh 0 put_ bh StdCallConv = do putByte bh 1 put_ bh PrimCallConv = do putByte bh 2 put_ bh CApiConv = do putByte bh 3 put_ bh JavaScriptCallConv = do putByte bh 4 get bh = do h <- getByte bh case h of 0 -> do return CCallConv 1 -> do return StdCallConv 2 -> do return PrimCallConv 3 -> do return CApiConv _ -> do return JavaScriptCallConv instance Binary CType where put_ bh (CType s mh fs) = do put_ bh s put_ bh mh put_ bh fs get bh = do s <- get bh mh <- get bh fs <- get bh return (CType s mh fs) instance Binary Header where put_ bh (Header s h) = put_ bh s >> put_ bh h get bh = do s <- get bh h <- get bh return (Header s h) ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot/GHC/BaseDir.hs0000644000000000000000000000542313713635665021440 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Note [Base Dir] -- ~~~~~~~~~~~~~~~~~ -- -- GHC's base directory or top directory containers miscellaneous settings and -- the package database. The main compiler of course needs this directory to -- read those settings and read and write packages. ghc-pkg uses it to find the -- global package database too. -- -- In the interest of making GHC builds more relocatable, many settings also -- will expand `${top_dir}` inside strings so GHC doesn't need to know it's on -- installation location at build time. ghc-pkg also can expand those variables -- and so needs the top dir location to do that too. module GHC.BaseDir where import Prelude -- See Note [Why do we import Prelude here?] import Data.List import System.FilePath -- Windows #if defined(mingw32_HOST_OS) import System.Environment (getExecutablePath) -- POSIX #elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS) import System.Environment (getExecutablePath) #endif -- | Expand occurrences of the @$topdir@ interpolation in a string. expandTopDir :: FilePath -> String -> String expandTopDir = expandPathVar "topdir" -- | @expandPathVar var value str@ -- -- replaces occurences of variable @$var@ with @value@ in str. expandPathVar :: String -> FilePath -> String -> String expandPathVar var value str | Just str' <- stripPrefix ('$':var) str , null str' || isPathSeparator (head str') = value ++ expandPathVar var value str' expandPathVar var value (x:xs) = x : expandPathVar var value xs expandPathVar _ _ [] = [] -- | Calculate the location of the base dir getBaseDir :: IO (Maybe String) #if defined(mingw32_HOST_OS) getBaseDir = Just . (\p -> p "lib") . rootDir <$> getExecutablePath where -- locate the "base dir" when given the path -- to the real ghc executable (as opposed to symlink) -- that is running this function. rootDir :: FilePath -> FilePath rootDir = takeDirectory . takeDirectory . normalise #elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS) -- on unix, this is a bit more confusing. -- The layout right now is something like -- -- /bin/ghc-X.Y.Z <- wrapper script (1) -- /bin/ghc <- symlink to wrapper script (2) -- /lib/ghc-X.Y.Z/bin/ghc <- ghc executable (3) -- /lib/ghc-X.Y.Z <- $topdir (4) -- -- As such, we first need to find the absolute location to the -- binary. -- -- getExecutablePath will return (3). One takeDirectory will -- give use /lib/ghc-X.Y.Z/bin, and another will give us (4). -- -- This of course only works due to the current layout. If -- the layout is changed, such that we have ghc-X.Y.Z/{bin,lib} -- this would need to be changed accordingly. -- getBaseDir = Just . (\p -> p "lib") . takeDirectory . takeDirectory <$> getExecutablePath #else getBaseDir = return Nothing #endif ghc-lib-parser-8.10.2.20200808/libraries/ghc-heap/GHC/Exts/Heap.hs0000644000000000000000000002404613713635665021703 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeFamilies #-} {-| Module : GHC.Exts.Heap Copyright : (c) 2012 Joachim Breitner License : BSD3 Maintainer : Joachim Breitner With this module, you can investigate the heap representation of Haskell values, i.e. to investigate sharing and lazy evaluation. -} module GHC.Exts.Heap ( -- * Closure types Closure , GenClosure(..) , ClosureType(..) , PrimType(..) , HasHeapRep(getClosureData) -- * Info Table types , StgInfoTable(..) , EntryFunPtr , HalfWord , ItblCodes , itblSize , peekItbl , pokeItbl -- * Closure inspection , getBoxedClosureData , allClosures -- * Boxes , Box(..) , asBox , areBoxesEqual ) where import Prelude import GHC.Exts.Heap.Closures import GHC.Exts.Heap.ClosureTypes import GHC.Exts.Heap.Constants #if defined(PROFILING) import GHC.Exts.Heap.InfoTableProf #else import GHC.Exts.Heap.InfoTable #endif import GHC.Exts.Heap.Utils import Control.Monad import Data.Bits import GHC.Arr import GHC.Exts import GHC.Int import GHC.Word #include "ghcconfig.h" class HasHeapRep (a :: TYPE rep) where getClosureData :: a -> IO Closure instance HasHeapRep (a :: TYPE 'LiftedRep) where getClosureData = getClosure instance HasHeapRep (a :: TYPE 'UnliftedRep) where getClosureData x = getClosure (unsafeCoerce# x) instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where getClosureData x = return $ IntClosure { ptipe = PInt, intVal = I# x } instance Word# ~ a => HasHeapRep (a :: TYPE 'WordRep) where getClosureData x = return $ WordClosure { ptipe = PWord, wordVal = W# x } instance Int64# ~ a => HasHeapRep (a :: TYPE 'Int64Rep) where getClosureData x = return $ Int64Closure { ptipe = PInt64, int64Val = I64# (unsafeCoerce# x) } instance Word64# ~ a => HasHeapRep (a :: TYPE 'Word64Rep) where getClosureData x = return $ Word64Closure { ptipe = PWord64, word64Val = W64# (unsafeCoerce# x) } instance Addr# ~ a => HasHeapRep (a :: TYPE 'AddrRep) where getClosureData x = return $ AddrClosure { ptipe = PAddr, addrVal = I# (unsafeCoerce# x) } instance Float# ~ a => HasHeapRep (a :: TYPE 'FloatRep) where getClosureData x = return $ FloatClosure { ptipe = PFloat, floatVal = F# x } instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where getClosureData x = return $ DoubleClosure { ptipe = PDouble, doubleVal = D# x } -- | This returns the raw representation of the given argument. The second -- component of the triple is the raw words of the closure on the heap, and the -- third component is those words that are actually pointers. Once back in the -- Haskell world, the raw words that hold pointers may be outdated after a -- garbage collector run, but the corresponding values in 'Box's will still -- point to the correct value. getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box]) getClosureRaw x = do case unpackClosure# x of -- This is a hack to cover the bootstrap compiler using the old version of -- 'unpackClosure'. The new 'unpackClosure' return values are not merely -- a reordering, so using the old version would not work. (# iptr, dat, pointers #) -> do let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE end = fromIntegral nelems - 1 rawWds = [W# (indexWordArray# dat i) | I# i <- [0.. end] ] pelems = I# (sizeofArray# pointers) ptrList = amap' Box $ Array 0 (pelems - 1) pelems pointers pure (Ptr iptr, rawWds, ptrList) -- From compiler/ghci/RtClosureInspect.hs amap' :: (t -> b) -> Array Int t -> [b] amap' f (Array i0 i _ arr#) = map g [0 .. i - i0] where g (I# i#) = case indexArray# arr# i# of (# e #) -> f e -- | This function returns a parsed heap representation of the argument _at -- this moment_, even if it is unevaluated or an indirection or other exotic -- stuff. Beware when passing something to this function, the same caveats as -- for 'asBox' apply. getClosure :: a -> IO Closure getClosure x = do (iptr, wds, pts) <- getClosureRaw x itbl <- peekItbl iptr -- The remaining words after the header let rawWds = drop (closureTypeHeaderSize (tipe itbl)) wds -- For data args in a pointers then non-pointers closure -- This is incorrect in non pointers-first setups -- not sure if that happens npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) wds case tipe itbl of t | t >= CONSTR && t <= CONSTR_NOCAF -> do (p, m, n) <- dataConNames iptr if m == "ByteCodeInstr" && n == "BreakInfo" then pure $ UnsupportedClosure itbl else pure $ ConstrClosure itbl pts npts p m n t | t >= THUNK && t <= THUNK_STATIC -> do pure $ ThunkClosure itbl pts npts THUNK_SELECTOR -> do unless (length pts >= 1) $ fail "Expected at least 1 ptr argument to THUNK_SELECTOR" pure $ SelectorClosure itbl (head pts) t | t >= FUN && t <= FUN_STATIC -> do pure $ FunClosure itbl pts npts AP -> do unless (length pts >= 1) $ fail "Expected at least 1 ptr argument to AP" -- We expect at least the arity, n_args, and fun fields unless (length rawWds >= 2) $ fail $ "Expected at least 2 raw words to AP" let splitWord = rawWds !! 0 pure $ APClosure itbl #if defined(WORDS_BIGENDIAN) (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) (fromIntegral splitWord) #else (fromIntegral splitWord) (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) #endif (head pts) (tail pts) PAP -> do unless (length pts >= 1) $ fail "Expected at least 1 ptr argument to PAP" -- We expect at least the arity, n_args, and fun fields unless (length rawWds >= 2) $ fail "Expected at least 2 raw words to PAP" let splitWord = rawWds !! 0 pure $ PAPClosure itbl #if defined(WORDS_BIGENDIAN) (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) (fromIntegral splitWord) #else (fromIntegral splitWord) (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) #endif (head pts) (tail pts) AP_STACK -> do unless (length pts >= 1) $ fail "Expected at least 1 ptr argument to AP_STACK" pure $ APStackClosure itbl (head pts) (tail pts) IND -> do unless (length pts >= 1) $ fail "Expected at least 1 ptr argument to IND" pure $ IndClosure itbl (head pts) IND_STATIC -> do unless (length pts >= 1) $ fail "Expected at least 1 ptr argument to IND_STATIC" pure $ IndClosure itbl (head pts) BLACKHOLE -> do unless (length pts >= 1) $ fail "Expected at least 1 ptr argument to BLACKHOLE" pure $ BlackholeClosure itbl (head pts) BCO -> do unless (length pts >= 3) $ fail $ "Expected at least 3 ptr argument to BCO, found " ++ show (length pts) unless (length rawWds >= 4) $ fail $ "Expected at least 4 words to BCO, found " ++ show (length rawWds) let splitWord = rawWds !! 3 pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2) #if defined(WORDS_BIGENDIAN) (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) (fromIntegral splitWord) #else (fromIntegral splitWord) (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) #endif (drop 4 rawWds) ARR_WORDS -> do unless (length rawWds >= 1) $ fail $ "Expected at least 1 words to ARR_WORDS, found " ++ show (length rawWds) pure $ ArrWordsClosure itbl (head rawWds) (tail rawWds) t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> do unless (length rawWds >= 2) $ fail $ "Expected at least 2 words to MUT_ARR_PTRS_* " ++ "found " ++ show (length rawWds) pure $ MutArrClosure itbl (rawWds !! 0) (rawWds !! 1) pts t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> do unless (length rawWds >= 1) $ fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* " ++ "found " ++ show (length rawWds) pure $ SmallMutArrClosure itbl (rawWds !! 0) pts t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> pure $ MutVarClosure itbl (head pts) t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do unless (length pts >= 3) $ fail $ "Expected at least 3 ptrs to MVAR, found " ++ show (length pts) pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2) BLOCKING_QUEUE -> pure $ OtherClosure itbl pts wds -- pure $ BlockingQueueClosure itbl -- (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3) -- pure $ OtherClosure itbl pts wds -- WEAK -> pure $ WeakClosure { info = itbl , cfinalizers = pts !! 0 , key = pts !! 1 , value = pts !! 2 , finalizer = pts !! 3 , link = pts !! 4 } _ -> pure $ UnsupportedClosure itbl -- | Like 'getClosureData', but taking a 'Box', so it is easier to work with. getBoxedClosureData :: Box -> IO Closure getBoxedClosureData (Box a) = getClosureData a ghc-lib-parser-8.10.2.20200808/libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs0000644000000000000000000000412413713635662024334 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} module GHC.Exts.Heap.ClosureTypes ( ClosureType(..) , closureTypeHeaderSize ) where import Prelude -- See note [Why do we import Prelude here?] import GHC.Generics {- --------------------------------------------- -- Enum representing closure types -- This is a mirror of: -- includes/rts/storage/ClosureTypes.h -- ---------------------------------------------} data ClosureType = INVALID_OBJECT | CONSTR | CONSTR_1_0 | CONSTR_0_1 | CONSTR_2_0 | CONSTR_1_1 | CONSTR_0_2 | CONSTR_NOCAF | FUN | FUN_1_0 | FUN_0_1 | FUN_2_0 | FUN_1_1 | FUN_0_2 | FUN_STATIC | THUNK | THUNK_1_0 | THUNK_0_1 | THUNK_2_0 | THUNK_1_1 | THUNK_0_2 | THUNK_STATIC | THUNK_SELECTOR | BCO | AP | PAP | AP_STACK | IND | IND_STATIC | RET_BCO | RET_SMALL | RET_BIG | RET_FUN | UPDATE_FRAME | CATCH_FRAME | UNDERFLOW_FRAME | STOP_FRAME | BLOCKING_QUEUE | BLACKHOLE | MVAR_CLEAN | MVAR_DIRTY | TVAR | ARR_WORDS | MUT_ARR_PTRS_CLEAN | MUT_ARR_PTRS_DIRTY | MUT_ARR_PTRS_FROZEN_DIRTY | MUT_ARR_PTRS_FROZEN_CLEAN | MUT_VAR_CLEAN | MUT_VAR_DIRTY | WEAK | PRIM | MUT_PRIM | TSO | STACK | TREC_CHUNK | ATOMICALLY_FRAME | CATCH_RETRY_FRAME | CATCH_STM_FRAME | WHITEHOLE | SMALL_MUT_ARR_PTRS_CLEAN | SMALL_MUT_ARR_PTRS_DIRTY | SMALL_MUT_ARR_PTRS_FROZEN_DIRTY | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN | COMPACT_NFDATA | N_CLOSURE_TYPES deriving (Enum, Eq, Ord, Show, Generic) -- | Return the size of the closures header in words closureTypeHeaderSize :: ClosureType -> Int closureTypeHeaderSize closType = case closType of ct | THUNK <= ct && ct <= THUNK_0_2 -> thunkHeader ct | ct == THUNK_SELECTOR -> thunkHeader ct | ct == AP -> thunkHeader ct | ct == AP_STACK -> thunkHeader _ -> header where header = 1 + prof thunkHeader = 2 + prof #if defined(PROFILING) prof = 2 #else prof = 0 #endif ghc-lib-parser-8.10.2.20200808/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs0000644000000000000000000002727013713635745023503 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GHCForeignImportPrim #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UnliftedFFITypes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} module GHC.Exts.Heap.Closures ( -- * Closures Closure , GenClosure(..) , PrimType(..) , allClosures #if __GLASGOW_HASKELL__ >= 809 -- The closureSize# primop is unsupported on earlier GHC releases but we -- build ghc-heap as a boot library so it must be buildable. Drop this once -- we are guaranteed to bootstsrap with GHC >= 8.9. , closureSize #endif -- * Boxes , Box(..) , areBoxesEqual , asBox ) where import Prelude -- See note [Why do we import Prelude here?] import GHC.Exts.Heap.Constants #if defined(PROFILING) import GHC.Exts.Heap.InfoTableProf #else import GHC.Exts.Heap.InfoTable -- `ghc -M` currently doesn't properly account for ways when generating -- dependencies (#15197). This import ensures correct build-ordering between -- this module and GHC.Exts.Heap.InfoTableProf. It should be removed when #15197 -- is fixed. import GHC.Exts.Heap.InfoTableProf () #endif import Data.Bits import Data.Int import Data.Word import GHC.Exts import GHC.Generics import Numeric ------------------------------------------------------------------------ -- Boxes foreign import prim "Ghclib_aToWordzh" aToWord# :: Any -> Word# foreign import prim "Ghclib_reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int# -- | An arbitrary Haskell value in a safe Box. The point is that even -- unevaluated thunks can safely be moved around inside the Box, and when -- required, e.g. in 'getBoxedClosureData', the function knows how far it has -- to evaluate the argument. data Box = Box Any instance Show Box where -- From libraries/base/GHC/Ptr.lhs showsPrec _ (Box a) rs = -- unsafePerformIO (print "↓" >> pClosure a) `seq` pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs where ptr = W# (aToWord# a) tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1) addr = ptr - tag pad_out ls = '0':'x':ls -- |This takes an arbitrary value and puts it into a box. -- Note that calls like -- -- > asBox (head list) -- -- will put the thunk \"head list\" into the box, /not/ the element at the head -- of the list. For that, use careful case expressions: -- -- > case list of x:_ -> asBox x asBox :: a -> Box asBox x = Box (unsafeCoerce# x) -- | Boxes can be compared, but this is not pure, as different heap objects can, -- after garbage collection, become the same object. areBoxesEqual :: Box -> Box -> IO Bool areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of 0# -> pure False _ -> pure True ------------------------------------------------------------------------ -- Closures type Closure = GenClosure Box -- | This is the representation of a Haskell value on the heap. It reflects -- -- -- The data type is parametrized by the type to store references in. Usually -- this is a 'Box' with the type synonym 'Closure'. -- -- All Heap objects have the same basic layout. A header containing a pointer -- to the info table and a payload with various fields. The @info@ field below -- always refers to the info table pointed to by the header. The remaining -- fields are the payload. -- -- See -- -- for more information. data GenClosure b = -- | A data constructor ConstrClosure { info :: !StgInfoTable , ptrArgs :: ![b] -- ^ Pointer arguments , dataArgs :: ![Word] -- ^ Non-pointer arguments , pkg :: !String -- ^ Package name , modl :: !String -- ^ Module name , name :: !String -- ^ Constructor name } -- | A function | FunClosure { info :: !StgInfoTable , ptrArgs :: ![b] -- ^ Pointer arguments , dataArgs :: ![Word] -- ^ Non-pointer arguments } -- | A thunk, an expression not obviously in head normal form | ThunkClosure { info :: !StgInfoTable , ptrArgs :: ![b] -- ^ Pointer arguments , dataArgs :: ![Word] -- ^ Non-pointer arguments } -- | A thunk which performs a simple selection operation | SelectorClosure { info :: !StgInfoTable , selectee :: !b -- ^ Pointer to the object being -- selected from } -- | An unsaturated function application | PAPClosure { info :: !StgInfoTable , arity :: !HalfWord -- ^ Arity of the partial application , n_args :: !HalfWord -- ^ Size of the payload in words , fun :: !b -- ^ Pointer to a 'FunClosure' , payload :: ![b] -- ^ Sequence of already applied -- arguments } -- In GHCi, if Linker.h would allow a reverse lookup, we could for exported -- functions fun actually find the name here. -- At least the other direction works via "lookupSymbol -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags) -- | A function application | APClosure { info :: !StgInfoTable , arity :: !HalfWord -- ^ Always 0 , n_args :: !HalfWord -- ^ Size of payload in words , fun :: !b -- ^ Pointer to a 'FunClosure' , payload :: ![b] -- ^ Sequence of already applied -- arguments } -- | A suspended thunk evaluation | APStackClosure { info :: !StgInfoTable , fun :: !b -- ^ Function closure , payload :: ![b] -- ^ Stack right before suspension } -- | A pointer to another closure, introduced when a thunk is updated -- to point at its value | IndClosure { info :: !StgInfoTable , indirectee :: !b -- ^ Target closure } -- | A byte-code object (BCO) which can be interpreted by GHC's byte-code -- interpreter (e.g. as used by GHCi) | BCOClosure { info :: !StgInfoTable , instrs :: !b -- ^ A pointer to an ArrWords -- of instructions , literals :: !b -- ^ A pointer to an ArrWords -- of literals , bcoptrs :: !b -- ^ A pointer to an ArrWords -- of byte code objects , arity :: !HalfWord -- ^ The arity of this BCO , size :: !HalfWord -- ^ The size of this BCO in words , bitmap :: ![Word] -- ^ An StgLargeBitmap describing the -- pointerhood of its args/free vars } -- | A thunk under evaluation by another thread | BlackholeClosure { info :: !StgInfoTable , indirectee :: !b -- ^ The target closure } -- | A @ByteArray#@ | ArrWordsClosure { info :: !StgInfoTable , bytes :: !Word -- ^ Size of array in bytes , arrWords :: ![Word] -- ^ Array payload } -- | A @MutableByteArray#@ | MutArrClosure { info :: !StgInfoTable , mccPtrs :: !Word -- ^ Number of pointers , mccSize :: !Word -- ^ ?? Closures.h vs ClosureMacros.h , mccPayload :: ![b] -- ^ Array payload -- Card table ignored } -- | A @SmallMutableArray#@ -- -- @since 8.10.1 | SmallMutArrClosure { info :: !StgInfoTable , mccPtrs :: !Word -- ^ Number of pointers , mccPayload :: ![b] -- ^ Array payload } -- | An @MVar#@, with a queue of thread state objects blocking on them | MVarClosure { info :: !StgInfoTable , queueHead :: !b -- ^ Pointer to head of queue , queueTail :: !b -- ^ Pointer to tail of queue , value :: !b -- ^ Pointer to closure } -- | A @MutVar#@ | MutVarClosure { info :: !StgInfoTable , var :: !b -- ^ Pointer to contents } -- | An STM blocking queue. | BlockingQueueClosure { info :: !StgInfoTable , link :: !b -- ^ ?? Here so it looks like an IND , blackHole :: !b -- ^ The blackhole closure , owner :: !b -- ^ The owning thread state object , queue :: !b -- ^ ?? } | WeakClosure { info :: !StgInfoTable , cfinalizers :: !b , key :: !b , value :: !b , finalizer :: !b , link :: !b -- ^ next weak pointer for the capability, can be NULL. } ------------------------------------------------------------ -- Unboxed unlifted closures -- | Primitive Int | IntClosure { ptipe :: PrimType , intVal :: !Int } -- | Primitive Word | WordClosure { ptipe :: PrimType , wordVal :: !Word } -- | Primitive Int64 | Int64Closure { ptipe :: PrimType , int64Val :: !Int64 } -- | Primitive Word64 | Word64Closure { ptipe :: PrimType , word64Val :: !Word64 } -- | Primitive Addr | AddrClosure { ptipe :: PrimType , addrVal :: !Int } -- | Primitive Float | FloatClosure { ptipe :: PrimType , floatVal :: !Float } -- | Primitive Double | DoubleClosure { ptipe :: PrimType , doubleVal :: !Double } ----------------------------------------------------------- -- Anything else -- | Another kind of closure | OtherClosure { info :: !StgInfoTable , hvalues :: ![b] , rawWords :: ![Word] } | UnsupportedClosure { info :: !StgInfoTable } deriving (Show, Generic, Functor, Foldable, Traversable) data PrimType = PInt | PWord | PInt64 | PWord64 | PAddr | PFloat | PDouble deriving (Eq, Show, Generic) -- | For generic code, this function returns all referenced closures. allClosures :: GenClosure b -> [b] allClosures (ConstrClosure {..}) = ptrArgs allClosures (ThunkClosure {..}) = ptrArgs allClosures (SelectorClosure {..}) = [selectee] allClosures (IndClosure {..}) = [indirectee] allClosures (BlackholeClosure {..}) = [indirectee] allClosures (APClosure {..}) = fun:payload allClosures (PAPClosure {..}) = fun:payload allClosures (APStackClosure {..}) = fun:payload allClosures (BCOClosure {..}) = [instrs,literals,bcoptrs] allClosures (ArrWordsClosure {}) = [] allClosures (MutArrClosure {..}) = mccPayload allClosures (SmallMutArrClosure {..}) = mccPayload allClosures (MutVarClosure {..}) = [var] allClosures (MVarClosure {..}) = [queueHead,queueTail,value] allClosures (FunClosure {..}) = ptrArgs allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue] allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer, link] allClosures (OtherClosure {..}) = hvalues allClosures _ = [] #if __GLASGOW_HASKELL__ >= 809 -- | Get the size of a closure in words. -- -- @since 8.10.1 closureSize :: Box -> Int closureSize (Box x) = I# (closureSize# x) #endif ghc-lib-parser-8.10.2.20200808/libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc0000644000000000000000000000060513713635662024012 0ustar0000000000000000{-# LANGUAGE CPP #-} module GHC.Exts.Heap.Constants ( wORD_SIZE , tAG_MASK , wORD_SIZE_IN_BITS ) where #include "MachDeps.h" import Prelude -- See note [Why do we import Prelude here?] import Data.Bits wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS :: Int wORD_SIZE = #const SIZEOF_HSWORD wORD_SIZE_IN_BITS = #const WORD_SIZE_IN_BITS tAG_MASK = (1 `shift` #const TAG_BITS) - 1 ghc-lib-parser-8.10.2.20200808/libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc0000644000000000000000000000461313713635662023704 0ustar0000000000000000module GHC.Exts.Heap.InfoTable ( module GHC.Exts.Heap.InfoTable.Types , itblSize , peekItbl , pokeItbl ) where #include "Rts.h" import Prelude -- See note [Why do we import Prelude here?] import GHC.Exts.Heap.InfoTable.Types #if !defined(TABLES_NEXT_TO_CODE) import GHC.Exts.Heap.Constants import Data.Maybe #endif import Foreign ------------------------------------------------------------------------- -- Profiling specific code -- -- The functions that follow all rely on PROFILING. They are duplicated in -- ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc where PROFILING is defined. This -- allows hsc2hs to generate values for both profiling and non-profiling builds. -- | Read an InfoTable from the heap into a haskell type. -- WARNING: This code assumes it is passed a pointer to a "standard" info -- table. If tables_next_to_code is enabled, it will look 1 byte before the -- start for the entry field. peekItbl :: Ptr StgInfoTable -> IO StgInfoTable peekItbl a0 = do #if !defined(TABLES_NEXT_TO_CODE) let ptr = a0 `plusPtr` (negate wORD_SIZE) entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr #else let ptr = a0 entry' = Nothing #endif ptrs' <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr nptrs' <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr tipe' <- (#peek struct StgInfoTable_, type) ptr srtlen' <- (#peek struct StgInfoTable_, srt) a0 return StgInfoTable { entry = entry' , ptrs = ptrs' , nptrs = nptrs' , tipe = toEnum (fromIntegral (tipe' :: HalfWord)) , srtlen = srtlen' , code = Nothing } pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO () pokeItbl a0 itbl = do #if !defined(TABLES_NEXT_TO_CODE) (#poke StgInfoTable, entry) a0 (fromJust (entry itbl)) #endif (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl) (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl) (#poke StgInfoTable, type) a0 (toHalfWord (fromEnum (tipe itbl))) (#poke StgInfoTable, srt) a0 (srtlen itbl) #if defined(TABLES_NEXT_TO_CODE) let code_offset = a0 `plusPtr` (#offset StgInfoTable, code) case code itbl of Nothing -> return () Just (Left xs) -> pokeArray code_offset xs Just (Right xs) -> pokeArray code_offset xs #endif where toHalfWord :: Int -> HalfWord toHalfWord i = fromIntegral i -- | Size in bytes of a standard InfoTable itblSize :: Int itblSize = (#size struct StgInfoTable_) ghc-lib-parser-8.10.2.20200808/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc0000644000000000000000000000211513713635665025006 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module GHC.Exts.Heap.InfoTable.Types ( StgInfoTable(..) , EntryFunPtr , HalfWord , ItblCodes ) where #include "Rts.h" import Prelude -- See note [Why do we import Prelude here?] import GHC.Generics import GHC.Exts.Heap.ClosureTypes import Foreign type ItblCodes = Either [Word8] [Word32] #include "ghcautoconf.h" -- Ultra-minimalist version specially for constructors #if SIZEOF_VOID_P == 8 type HalfWord = Word32 #elif SIZEOF_VOID_P == 4 type HalfWord = Word16 #else #error Unknown SIZEOF_VOID_P #endif type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ())) -- | This is a somewhat faithful representation of an info table. See -- -- for more details on this data structure. data StgInfoTable = StgInfoTable { entry :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode ptrs :: HalfWord, nptrs :: HalfWord, tipe :: ClosureType, srtlen :: HalfWord, code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode } deriving (Show, Generic) ghc-lib-parser-8.10.2.20200808/libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc0000644000000000000000000000423413713635662024532 0ustar0000000000000000module GHC.Exts.Heap.InfoTableProf ( module GHC.Exts.Heap.InfoTable.Types , itblSize , peekItbl , pokeItbl ) where -- This file overrides InfoTable.hsc's implementation of peekItbl and pokeItbl. -- Manually defining PROFILING gives the #peek and #poke macros an accurate -- representation of StgInfoTable_ when hsc2hs runs. #define PROFILING #include "Rts.h" import Prelude -- See note [Why do we import Prelude here?] import GHC.Exts.Heap.InfoTable.Types #if !defined(TABLES_NEXT_TO_CODE) import GHC.Exts.Heap.Constants import Data.Maybe #endif import Foreign -- | Read an InfoTable from the heap into a haskell type. -- WARNING: This code assumes it is passed a pointer to a "standard" info -- table. If tables_next_to_code is enabled, it will look 1 byte before the -- start for the entry field. peekItbl :: Ptr StgInfoTable -> IO StgInfoTable peekItbl a0 = do #if !defined(TABLES_NEXT_TO_CODE) let ptr = a0 `plusPtr` (negate wORD_SIZE) entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr #else let ptr = a0 entry' = Nothing #endif ptrs' <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr nptrs' <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr tipe' <- (#peek struct StgInfoTable_, type) ptr srtlen' <- (#peek struct StgInfoTable_, srt) a0 return StgInfoTable { entry = entry' , ptrs = ptrs' , nptrs = nptrs' , tipe = toEnum (fromIntegral (tipe' :: HalfWord)) , srtlen = srtlen' , code = Nothing } pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO () pokeItbl a0 itbl = do #if !defined(TABLES_NEXT_TO_CODE) (#poke StgInfoTable, entry) a0 (fromJust (entry itbl)) #endif (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl) (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl) (#poke StgInfoTable, type) a0 (fromEnum (tipe itbl)) (#poke StgInfoTable, srt) a0 (srtlen itbl) #if defined(TABLES_NEXT_TO_CODE) let code_offset = a0 `plusPtr` (#offset StgInfoTable, code) case code itbl of Nothing -> return () Just (Left xs) -> pokeArray code_offset xs Just (Right xs) -> pokeArray code_offset xs #endif itblSize :: Int itblSize = (#size struct StgInfoTable_) ghc-lib-parser-8.10.2.20200808/libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc0000644000000000000000000001132013713635662023132 0ustar0000000000000000{-# LANGUAGE CPP, MagicHash #-} module GHC.Exts.Heap.Utils ( dataConNames ) where #include "Rts.h" import Prelude -- See note [Why do we import Prelude here?] import GHC.Exts.Heap.Constants import GHC.Exts.Heap.InfoTable import Data.Char import Data.List import Foreign import GHC.CString import GHC.Exts {- To find the string in the constructor's info table we need to consider the layout of info tables relative to the entry code for a closure. An info table can be next to the entry code for the closure, or it can be separate. The former (faster) is used in registerised versions of ghc, and the latter (portable) is for non-registerised versions. The diagrams below show where the string is to be found relative to the normal info table of the closure. 1) Tables next to code: -------------- | | <- pointer to the start of the string -------------- | | <- the (start of the) info table structure | | | | -------------- | entry code | | .... | In this case the pointer to the start of the string can be found in the memory location _one word before_ the first entry in the normal info table. 2) Tables NOT next to code: -------------- info table structure -> | *------------------> -------------- | | | entry code | | | | .... | -------------- ptr to start of str -> | | -------------- In this case the pointer to the start of the string can be found in the memory location: info_table_ptr + info_table_size -} -- Given a ptr to an 'StgInfoTable' for a data constructor -- return (Package, Module, Name) dataConNames :: Ptr StgInfoTable -> IO (String, String, String) dataConNames ptr = do conDescAddress <- getConDescAddress pure $ parse conDescAddress where -- Retrieve the con_desc field address pointing to -- 'Package:Module.Name' string getConDescAddress :: IO (Ptr Word8) getConDescAddress #if defined(TABLES_NEXT_TO_CODE) = do offsetToString <- peek (ptr `plusPtr` negate wORD_SIZE) pure $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` fromIntegral (offsetToString :: Int32) #else = peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral stdInfoTableSizeB #endif stdInfoTableSizeW :: Int -- The size of a standard info table varies with profiling/ticky etc, -- so we can't get it from Constants -- It must vary in sync with mkStdInfoTable stdInfoTableSizeW = size_fixed + size_prof where size_fixed = 2 -- layout, type ##if defined(PROFILING) size_prof = 2 ##else size_prof = 0 ##endif stdInfoTableSizeB :: Int stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE -- parsing names is a little bit fiddly because we have a string in the form: -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo"). -- Thus we split at the leftmost colon and the rightmost occurrence of the dot. -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas -- this is not the conventional way of writing Haskell names. We stick with -- convention, even though it makes the parsing code more troublesome. -- Warning: this code assumes that the string is well formed. parse :: Ptr Word8 -> (String, String, String) parse (Ptr addr) = if not . all (>0) . fmap length $ [p,m,occ] then ([], [], input) else (p, m, occ) where input = unpackCStringUtf8## addr (p, rest1) = break (== ':') input (m, occ) = (intercalate "." $ reverse modWords, occWord) where (modWords, occWord) = if length rest1 < 1 -- XXXXXXXXx YUKX --then error "getConDescAddress:parse:length rest1 < 1" then parseModOcc [] [] else parseModOcc [] (tail rest1) -- We only look for dots if str could start with a module name, -- i.e. if it starts with an upper case character. -- Otherwise we might think that "X.:->" is the module name in -- "X.:->.+", whereas actually "X" is the module name and -- ":->.+" is a constructor name. parseModOcc :: [String] -> String -> ([String], String) parseModOcc acc str@(c : _) | isUpper c = case break (== '.') str of (top, []) -> (acc, top) (top, _:bot) -> parseModOcc (top : acc) bot parseModOcc acc str = (acc, str) ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot/GHC/ForeignSrcLang.hs0000644000000000000000000000041713713635662022765 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} -- | See @GHC.LanguageExtensions@ for an explanation -- on why this is needed module GHC.ForeignSrcLang ( module GHC.ForeignSrcLang.Type ) where import Data.Binary import GHC.ForeignSrcLang.Type instance Binary ForeignSrcLang ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs0000644000000000000000000000072613713635662024322 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module GHC.ForeignSrcLang.Type ( ForeignSrcLang(..) ) where import Prelude -- See note [Why do we import Prelude here?] import GHC.Generics (Generic) -- | Foreign formats supported by GHC via TH data ForeignSrcLang = LangC -- ^ C | LangCxx -- ^ C++ | LangObjc -- ^ Objective C | LangObjcxx -- ^ Objective C++ | LangAsm -- ^ Assembly language (.s) | RawObject -- ^ Object (.o) deriving (Eq, Show, Generic) ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs.hs0000644000000000000000000001173613713635745016640 0ustar0000000000000000{-# OPTIONS_GHC -O0 #-} {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section{Haskell abstract syntax definition} This module glues together the pieces of the Haskell abstract syntax, which is declared in the various \tr{Hs*} modules. This module, therefore, is almost nothing but re-exporting. -} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data module GHC.Hs ( module GHC.Hs.Binds, module GHC.Hs.Decls, module GHC.Hs.Expr, module GHC.Hs.ImpExp, module GHC.Hs.Lit, module GHC.Hs.Pat, module GHC.Hs.Types, module GHC.Hs.Utils, module GHC.Hs.Doc, module GHC.Hs.PlaceHolder, module GHC.Hs.Extension, Fixity, HsModule(..), ) where -- friends: import GhcPrelude import GHC.Hs.Decls import GHC.Hs.Binds import GHC.Hs.Expr import GHC.Hs.ImpExp import GHC.Hs.Lit import GHC.Hs.PlaceHolder import GHC.Hs.Extension import GHC.Hs.Pat import GHC.Hs.Types import BasicTypes ( Fixity, WarningTxt ) import GHC.Hs.Utils import GHC.Hs.Doc import GHC.Hs.Instances () -- For Data instances -- others: import Outputable import SrcLoc import Module ( ModuleName ) -- libraries: import Data.Data hiding ( Fixity ) -- | Haskell Module -- -- All we actually declare here is the top-level structure for a module. data HsModule pass = HsModule { hsmodName :: Maybe (Located ModuleName), -- ^ @Nothing@: \"module X where\" is omitted (in which case the next -- field is Nothing too) hsmodExports :: Maybe (Located [LIE pass]), -- ^ Export list -- -- - @Nothing@: export list omitted, so export everything -- -- - @Just []@: export /nothing/ -- -- - @Just [...]@: as you would expect... -- -- -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' -- ,'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation hsmodImports :: [LImportDecl pass], -- ^ We snaffle interesting stuff out of the imported interfaces early -- on, adding that info to TyDecls/etc; so this list is often empty, -- downstream. hsmodDecls :: [LHsDecl pass], -- ^ Type, class, value, and interface signature decls hsmodDeprecMessage :: Maybe (Located WarningTxt), -- ^ reason\/explanation for warning/deprecation of this module -- -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' -- ,'ApiAnnotation.AnnClose' -- -- For details on above see note [Api annotations] in ApiAnnotation hsmodHaddockModHeader :: Maybe LHsDocString -- ^ Haddock module info and description, unparsed -- -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' -- ,'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation } -- ^ 'ApiAnnotation.AnnKeywordId's -- -- - 'ApiAnnotation.AnnModule','ApiAnnotation.AnnWhere' -- -- - 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnSemi', -- 'ApiAnnotation.AnnClose' for explicit braces and semi around -- hsmodImports,hsmodDecls if this style is used. -- For details on above see note [Api annotations] in ApiAnnotation -- deriving instance (DataIdLR name name) => Data (HsModule name) deriving instance Data (HsModule GhcPs) deriving instance Data (HsModule GhcRn) deriving instance Data (HsModule GhcTc) instance (OutputableBndrId p) => Outputable (HsModule (GhcPass p)) where ppr (HsModule Nothing _ imports decls _ mbDoc) = pp_mb mbDoc $$ pp_nonnull imports $$ pp_nonnull decls ppr (HsModule (Just name) exports imports decls deprec mbDoc) = vcat [ pp_mb mbDoc, case exports of Nothing -> pp_header (text "where") Just es -> vcat [ pp_header lparen, nest 8 (fsep (punctuate comma (map ppr (unLoc es)))), nest 4 (text ") where") ], pp_nonnull imports, pp_nonnull decls ] where pp_header rest = case deprec of Nothing -> pp_modname <+> rest Just d -> vcat [ pp_modname, ppr d, rest ] pp_modname = text "module" <+> ppr name pp_mb :: Outputable t => Maybe t -> SDoc pp_mb (Just x) = ppr x pp_mb Nothing = empty pp_nonnull :: Outputable t => [t] -> SDoc pp_nonnull [] = empty pp_nonnull xs = vcat (map ppr xs) ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/Binds.hs0000644000000000000000000013761313713635744017701 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[HsBinds]{Abstract syntax: top-level bindings and signatures} Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. -} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} module GHC.Hs.Binds where import GhcPrelude import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, LHsExpr, MatchGroup, pprFunBind, GRHSs, pprPatBind ) import {-# SOURCE #-} GHC.Hs.Pat ( LPat ) import GHC.Hs.Extension import GHC.Hs.Types import CoreSyn import TcEvidence import Type import NameSet import BasicTypes import Outputable import SrcLoc import Var import Bag import FastString import BooleanFormula (LBooleanFormula) import DynFlags import Data.Data hiding ( Fixity ) import Data.List hiding ( foldr ) import Data.Ord {- ************************************************************************ * * \subsection{Bindings: @BindGroup@} * * ************************************************************************ Global bindings (where clauses) -} -- During renaming, we need bindings where the left-hand sides -- have been renamed but the right-hand sides have not. -- the ...LR datatypes are parametrized by two id types, -- one for the left and one for the right. -- Other than during renaming, these will be the same. -- | Haskell Local Bindings type HsLocalBinds id = HsLocalBindsLR id id -- | Located Haskell local bindings type LHsLocalBinds id = Located (HsLocalBinds id) -- | Haskell Local Bindings with separate Left and Right identifier types -- -- Bindings in a 'let' expression -- or a 'where' clause data HsLocalBindsLR idL idR = HsValBinds (XHsValBinds idL idR) (HsValBindsLR idL idR) -- ^ Haskell Value Bindings -- There should be no pattern synonyms in the HsValBindsLR -- These are *local* (not top level) bindings -- The parser accepts them, however, leaving the -- renamer to report them | HsIPBinds (XHsIPBinds idL idR) (HsIPBinds idR) -- ^ Haskell Implicit Parameter Bindings | EmptyLocalBinds (XEmptyLocalBinds idL idR) -- ^ Empty Local Bindings | XHsLocalBindsLR (XXHsLocalBindsLR idL idR) type instance XHsValBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) -- | Haskell Value Bindings type HsValBinds id = HsValBindsLR id id -- | Haskell Value bindings with separate Left and Right identifier types -- (not implicit parameters) -- Used for both top level and nested bindings -- May contain pattern synonym bindings data HsValBindsLR idL idR = -- | Value Bindings In -- -- Before renaming RHS; idR is always RdrName -- Not dependency analysed -- Recursive by default ValBinds (XValBinds idL idR) (LHsBindsLR idL idR) [LSig idR] -- | Value Bindings Out -- -- After renaming RHS; idR can be Name or Id Dependency analysed, -- later bindings in the list may depend on earlier ones. | XValBindsLR (XXValBindsLR idL idR) -- --------------------------------------------------------------------- -- Deal with ValBindsOut -- TODO: make this the only type for ValBinds data NHsValBindsLR idL = NValBinds [(RecFlag, LHsBinds idL)] [LSig GhcRn] type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XXValBindsLR (GhcPass pL) (GhcPass pR) = NHsValBindsLR (GhcPass pL) -- --------------------------------------------------------------------- -- | Located Haskell Binding type LHsBind id = LHsBindLR id id -- | Located Haskell Bindings type LHsBinds id = LHsBindsLR id id -- | Haskell Binding type HsBind id = HsBindLR id id -- | Located Haskell Bindings with separate Left and Right identifier types type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) -- | Located Haskell Binding with separate Left and Right identifier types type LHsBindLR idL idR = Located (HsBindLR idL idR) {- Note [FunBind vs PatBind] ~~~~~~~~~~~~~~~~~~~~~~~~~ The distinction between FunBind and PatBind is a bit subtle. FunBind covers patterns which resemble function bindings and simple variable bindings. f x = e f !x = e f = e !x = e -- FunRhs has SrcStrict x `f` y = e -- FunRhs has Infix The actual patterns and RHSs of a FunBind are encoding in fun_matches. The m_ctxt field of each Match in fun_matches will be FunRhs and carries two bits of information about the match, * The mc_fixity field on each Match describes the fixity of the function binder in that match. E.g. this is legal: f True False = e1 True `f` True = e2 * The mc_strictness field is used /only/ for nullary FunBinds: ones with one Match, which has no pats. For these, it describes whether the match is decorated with a bang (e.g. `!x = e`). By contrast, PatBind represents data constructor patterns, as well as a few other interesting cases. Namely, Just x = e (x) = e x :: Ty = e -} -- | Haskell Binding with separate Left and Right id's data HsBindLR idL idR = -- | Function-like Binding -- -- FunBind is used for both functions @f x = e@ -- and variables @f = \x -> e@ -- and strict variables @!x = x + 1@ -- -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'. -- -- Reason 2: Instance decls can only have FunBinds, which is convenient. -- If you change this, you'll need to change e.g. rnMethodBinds -- -- But note that the form @f :: a->a = ...@ -- parses as a pattern binding, just like -- @(f :: a -> a) = ... @ -- -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their -- 'MatchContext'. See Note [FunBind vs PatBind] for -- details about the relationship between FunBind and PatBind. -- -- 'ApiAnnotation.AnnKeywordId's -- -- - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches -- -- - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', -- For details on above see note [Api annotations] in ApiAnnotation FunBind { fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains -- the locally-bound -- free variables of this defn. -- See Note [Bind free vars] fun_id :: Located (IdP idL), -- Note [fun_id in Match] in GHC.Hs.Expr fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of -- the Id. Example: -- -- @ -- f :: Int -> forall a. a -> a -- f x y = y -- @ -- -- Then the MatchGroup will have type (Int -> a' -> a') -- (with a free type variable a'). The coercion will take -- a CoreExpr of this type and convert it to a CoreExpr of -- type Int -> forall a'. a' -> a' -- Notice that the coercion captures the free a'. fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any } -- | Pattern Binding -- -- The pattern is never a simple variable; -- That case is done by FunBind. -- See Note [FunBind vs PatBind] for details about the -- relationship between FunBind and PatBind. -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang', -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', -- For details on above see note [Api annotations] in ApiAnnotation | PatBind { pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars] pat_lhs :: LPat idL, pat_rhs :: GRHSs idR (LHsExpr idR), pat_ticks :: ([Tickish Id], [[Tickish Id]]) -- ^ Ticks to put on the rhs, if any, and ticks to put on -- the bound variables. } -- | Variable Binding -- -- Dictionary binding and suchlike. -- All VarBinds are introduced by the type checker | VarBind { var_ext :: XVarBind idL idR, var_id :: IdP idL, var_rhs :: LHsExpr idR, -- ^ Located only for consistency var_inline :: Bool -- ^ True <=> inline this binding regardless -- (used for implication constraints only) } -- | Abstraction Bindings | AbsBinds { -- Binds abstraction; TRANSLATION abs_ext :: XAbsBinds idL idR, abs_tvs :: [TyVar], abs_ev_vars :: [EvVar], -- ^ Includes equality constraints -- | AbsBinds only gets used when idL = idR after renaming, -- but these need to be idL's for the collect... code in HsUtil -- to have the right type abs_exports :: [ABExport idL], -- | Evidence bindings -- Why a list? See TcInstDcls -- Note [Typechecking plan for instance declarations] abs_ev_binds :: [TcEvBinds], -- | Typechecked user bindings abs_binds :: LHsBinds idL, abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds] } -- | Patterns Synonym Binding | PatSynBind (XPatSynBind idL idR) (PatSynBind idL idR) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', -- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual', -- 'ApiAnnotation.AnnWhere' -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@ -- For details on above see note [Api annotations] in ApiAnnotation | XHsBindsLR (XXHsBindsLR idL idR) data NPatBindTc = NPatBindTc { pat_fvs :: NameSet, -- ^ Free variables pat_rhs_ty :: Type -- ^ Type of the GRHSs } deriving Data type instance XFunBind (GhcPass pL) GhcPs = NoExtField type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables type instance XPatBind GhcPs (GhcPass pR) = NoExtField type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExtField type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] -- -- Creates bindings for (polymorphic, overloaded) poly_f -- in terms of monomorphic, non-overloaded mono_f -- -- Invariants: -- 1. 'binds' binds mono_f -- 2. ftvs is a subset of tvs -- 3. ftvs includes all tyvars free in ds -- -- See Note [AbsBinds] -- | Abtraction Bindings Export data ABExport p = ABE { abe_ext :: XABE p , abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id , abe_mono :: IdP p , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper] -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas } | XABExport (XXABExport p) type instance XABE (GhcPass p) = NoExtField type instance XXABExport (GhcPass p) = NoExtCon -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow' -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnClose' @'}'@, -- For details on above see note [Api annotations] in ApiAnnotation -- | Pattern Synonym binding data PatSynBind idL idR = PSB { psb_ext :: XPSB idL idR, -- ^ Post renaming, FVs. -- See Note [Bind free vars] psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym psb_args :: HsPatSynDetails (Located (IdP idR)), -- ^ Formal parameter names psb_def :: LPat idR, -- ^ Right-hand side psb_dir :: HsPatSynDir idR -- ^ Directionality } | XPatSynBind (XXPatSynBind idL idR) type instance XPSB (GhcPass idL) GhcPs = NoExtField type instance XPSB (GhcPass idL) GhcRn = NameSet type instance XPSB (GhcPass idL) GhcTc = NameSet type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExtCon {- Note [AbsBinds] ~~~~~~~~~~~~~~~ The AbsBinds constructor is used in the output of the type checker, to record *typechecked* and *generalised* bindings. Specifically AbsBinds { abs_tvs = tvs , abs_ev_vars = [d1,d2] , abs_exports = [ABE { abe_poly = fp, abe_mono = fm , abe_wrap = fwrap } ABE { slly for g } ] , abs_ev_binds = DBINDS , abs_binds = BIND[fm,gm] } where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS ] [ ; BIND[fm,gm] } ] [ in fm ] gp = ...same again, with gm instead of fm The 'fwrap' is an impedence-matcher that typically does nothing; see Note [ABExport wrapper]. This is a pretty bad translation, because it duplicates all the bindings. So the desugarer tries to do a better job: fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of (fm,gm) -> fm ..ditto for gp.. tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND } in (fm,gm) In general: * abs_tvs are the type variables over which the binding group is generalised * abs_ev_var are the evidence variables (usually dictionaries) over which the binding group is generalised * abs_binds are the monomorphic bindings * abs_ex_binds are the evidence bindings that wrap the abs_binds * abs_exports connects the monomorphic Ids bound by abs_binds with the polymorphic Ids bound by the AbsBinds itself. For example, consider a module M, with this top-level binding, where there is no type signature for M.reverse, M.reverse [] = [] M.reverse (x:xs) = M.reverse xs ++ [x] In Hindley-Milner, a recursive binding is typechecked with the *recursive* uses being *monomorphic*. So after typechecking *and* desugaring we will get something like this M.reverse :: forall a. [a] -> [a] = /\a. letrec reverse :: [a] -> [a] = \xs -> case xs of [] -> [] (x:xs) -> reverse xs ++ [x] in reverse Notice that 'M.reverse' is polymorphic as expected, but there is a local definition for plain 'reverse' which is *monomorphic*. The type variable 'a' scopes over the entire letrec. That's after desugaring. What about after type checking but before desugaring? That's where AbsBinds comes in. It looks like this: AbsBinds { abs_tvs = [a] , abs_ev_vars = [] , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a], , abe_mono = reverse :: [a] -> [a]}] , abs_ev_binds = {} , abs_binds = { reverse :: [a] -> [a] = \xs -> case xs of [] -> [] (x:xs) -> reverse xs ++ [x] } } Here, * abs_tvs says what type variables are abstracted over the binding group, just 'a' in this case. * abs_binds is the *monomorphic* bindings of the group * abs_exports describes how to get the polymorphic Id 'M.reverse' from the monomorphic one 'reverse' Notice that the *original* function (the polymorphic one you thought you were defining) appears in the abe_poly field of the abs_exports. The bindings in abs_binds are for fresh, local, Ids with a *monomorphic* Id. If there is a group of mutually recursive (see Note [Polymorphic recursion]) functions without type signatures, we get one AbsBinds with the monomorphic versions of the bindings in abs_binds, and one element of abe_exports for each variable bound in the mutually recursive group. This is true even for pattern bindings. Example: (f,g) = (\x -> x, f) After type checking we get AbsBinds { abs_tvs = [a] , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a , abe_mono = f :: a -> a } , ABE { abe_poly = M.g :: forall a. a -> a , abe_mono = g :: a -> a }] , abs_binds = { (f,g) = (\x -> x, f) } Note [Polymorphic recursion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider Rec { f x = ...(g ef)... ; g :: forall a. [a] -> [a] ; g y = ...(f eg)... } These bindings /are/ mutually recursive (f calls g, and g calls f). But we can use the type signature for g to break the recursion, like this: 1. Add g :: forall a. [a] -> [a] to the type environment 2. Typecheck the definition of f, all by itself, including generalising it to find its most general type, say f :: forall b. b -> b -> [b] 3. Extend the type environment with that type for f 4. Typecheck the definition of g, all by itself, checking that it has the type claimed by its signature Steps 2 and 4 each generate a separate AbsBinds, so we end up with Rec { AbsBinds { ...for f ... } ; AbsBinds { ...for g ... } } This approach allows both f and to call each other polymorphically, even though only g has a signature. We get an AbsBinds that encompasses multiple source-program bindings only when * Each binding in the group has at least one binder that lacks a user type signature * The group forms a strongly connected component Note [The abs_sig field of AbsBinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The abs_sig field supports a couple of special cases for bindings. Consider x :: Num a => (# a, a #) x = (# 3, 4 #) The general desugaring for AbsBinds would give x = /\a. \ ($dNum :: Num a) -> letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in xm But that has an illegal let-binding for an unboxed tuple. In this case we'd prefer to generate the (more direct) x = /\ a. \ ($dNum :: Num a) -> (# fromInteger $dNum 3, fromInteger $dNum 4 #) A similar thing happens with representation-polymorphic defns (#11405): undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a undef = error "undef" Again, the vanilla desugaring gives a local let-binding for a representation-polymorphic (undefm :: a), which is illegal. But again we can desugar without a let: undef = /\ a. \ (d:HasCallStack) -> error a d "undef" The abs_sig field supports this direct desugaring, with no local let-bining. When abs_sig = True * the abs_binds is single FunBind * the abs_exports is a singleton * we have a complete type sig for binder and hence the abs_binds is non-recursive (it binds the mono_id but refers to the poly_id These properties are exploited in DsBinds.dsAbsBinds to generate code without a let-binding. Note [ABExport wrapper] ~~~~~~~~~~~~~~~~~~~~~~~ Consider (f,g) = (\x.x, \y.y) This ultimately desugars to something like this: tup :: forall a b. (a->a, b->b) tup = /\a b. (\x:a.x, \y:b.y) f :: forall a. a -> a f = /\a. case tup a Any of (fm::a->a,gm:Any->Any) -> fm ...similarly for g... The abe_wrap field deals with impedance-matching between (/\a b. case tup a b of { (f,g) -> f }) and the thing we really want, which may have fewer type variables. The action happens in TcBinds.mkExport. Note [Bind free vars] ~~~~~~~~~~~~~~~~~~~~~ The bind_fvs field of FunBind and PatBind records the free variables of the definition. It is used for the following purposes a) Dependency analysis prior to type checking (see TcBinds.tc_group) b) Deciding whether we can do generalisation of the binding (see TcBinds.decideGeneralisationPlan) c) Deciding whether the binding can be used in static forms (see TcExpr.checkClosedInStaticForm for the HsStatic case and TcBinds.isClosedBndrGroup). Specifically, * bind_fvs includes all free vars that are defined in this module (including top-level things and lexically scoped type variables) * bind_fvs excludes imported vars; this is just to keep the set smaller * Before renaming, and after typechecking, the field is unused; it's just an error thunk -} instance (OutputableBndrId pl, OutputableBndrId pr) => Outputable (HsLocalBindsLR (GhcPass pl) (GhcPass pr)) where ppr (HsValBinds _ bs) = ppr bs ppr (HsIPBinds _ bs) = ppr bs ppr (EmptyLocalBinds _) = empty ppr (XHsLocalBindsLR x) = ppr x instance (OutputableBndrId pl, OutputableBndrId pr) => Outputable (HsValBindsLR (GhcPass pl) (GhcPass pr)) where ppr (ValBinds _ binds sigs) = pprDeclList (pprLHsBindsForUser binds sigs) ppr (XValBindsLR (NValBinds sccs sigs)) = getPprStyle $ \ sty -> if debugStyle sty then -- Print with sccs showing vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) else pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs) where ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds pp_rec Recursive = text "rec" pp_rec NonRecursive = text "nonrec" pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR) => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty | otherwise = pprDeclList (map ppr (bagToList binds)) pprLHsBindsForUser :: (OutputableBndrId idL, OutputableBndrId idR, OutputableBndrId id2) => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc] -- pprLHsBindsForUser is different to pprLHsBinds because -- a) No braces: 'let' and 'where' include a list of HsBindGroups -- and we don't want several groups of bindings each -- with braces around -- b) Sort by location before printing -- c) Include signatures pprLHsBindsForUser binds sigs = map snd (sort_by_loc decls) where decls :: [(SrcSpan, SDoc)] decls = [(loc, ppr sig) | L loc sig <- sigs] ++ [(loc, ppr bind) | L loc bind <- bagToList binds] sort_by_loc decls = sortBy (comparing fst) decls pprDeclList :: [SDoc] -> SDoc -- Braces with a space -- Print a bunch of declarations -- One could choose { d1; d2; ... }, using 'sep' -- or d1 -- d2 -- .. -- using vcat -- At the moment we chose the latter -- Also we do the 'pprDeeperList' thing. pprDeclList ds = pprDeeperList vcat ds ------------ emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) emptyLocalBinds = EmptyLocalBinds noExtField -- AZ:These functions do not seem to be used at all? isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool isEmptyLocalBindsTc (HsValBinds _ ds) = isEmptyValBinds ds isEmptyLocalBindsTc (HsIPBinds _ ds) = isEmptyIPBindsTc ds isEmptyLocalBindsTc (EmptyLocalBinds _) = True isEmptyLocalBindsTc (XHsLocalBindsLR _) = True isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool isEmptyLocalBindsPR (HsValBinds _ ds) = isEmptyValBinds ds isEmptyLocalBindsPR (HsIPBinds _ ds) = isEmptyIPBindsPR ds isEmptyLocalBindsPR (EmptyLocalBinds _) = True isEmptyLocalBindsPR (XHsLocalBindsLR _) = True eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool eqEmptyLocalBinds (EmptyLocalBinds _) = True eqEmptyLocalBinds _ = False isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b) emptyValBindsIn = ValBinds noExtField emptyBag [] emptyValBindsOut = XValBindsLR (NValBinds [] []) emptyLHsBinds :: LHsBindsLR idL idR emptyLHsBinds = emptyBag isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool isEmptyLHsBinds = isEmptyBag ------------ plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds(GhcPass a) plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) = ValBinds noExtField (ds1 `unionBags` ds2) (sigs1 ++ sigs2) plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1)) (XValBindsLR (NValBinds ds2 sigs2)) = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2)) plusHsValBinds _ _ = panic "HsBinds.plusHsValBinds" instance (OutputableBndrId pl, OutputableBndrId pr) => Outputable (HsBindLR (GhcPass pl) (GhcPass pr)) where ppr mbind = ppr_monobind mbind ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR) => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] ppr_monobind (FunBind { fun_id = fun, fun_co_fn = wrap, fun_matches = matches, fun_tick = ticks }) = pprTicks empty (if null ticks then empty else text "-- ticks = " <> ppr ticks) $$ whenPprDebug (pprBndr LetBind (unLoc fun)) $$ pprFunBind matches $$ whenPprDebug (ppr wrap) ppr_monobind (PatSynBind _ psb) = ppr psb ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars , abs_exports = exports, abs_binds = val_binds , abs_ev_binds = ev_binds }) = sdocWithDynFlags $ \ dflags -> if gopt Opt_PrintTypecheckerElaboration dflags then -- Show extra information (bug number: #10662) hang (text "AbsBinds" <+> brackets (interpp'SP tyvars) <+> brackets (interpp'SP dictvars)) 2 $ braces $ vcat [ text "Exports:" <+> brackets (sep (punctuate comma (map ppr exports))) , text "Exported types:" <+> vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] , text "Binds:" <+> pprLHsBinds val_binds , text "Evidence:" <+> ppr ev_binds ] else pprLHsBinds val_binds ppr_monobind (XHsBindsLR x) = ppr x instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) = vcat [ ppr gbl <+> text "<=" <+> ppr lcl , nest 2 (pprTcSpecPrags prags) , nest 2 (text "wrap:" <+> ppr wrap)] ppr (XABExport x) = ppr x instance (OutputableBndrId l, OutputableBndrId r, Outputable (XXPatSynBind (GhcPass l) (GhcPass r))) => Outputable (PatSynBind (GhcPass l) (GhcPass r)) where ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, psb_dir = dir }) = ppr_lhs <+> ppr_rhs where ppr_lhs = text "pattern" <+> ppr_details ppr_simple syntax = syntax <+> ppr pat ppr_details = case details of InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2] PrefixCon vs -> hsep (pprPrefixOcc psyn : map ppr vs) RecCon vs -> pprPrefixOcc psyn <> braces (sep (punctuate comma (map ppr vs))) ppr_rhs = case dir of Unidirectional -> ppr_simple (text "<-") ImplicitBidirectional -> ppr_simple equals ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$ (nest 2 $ pprFunBind mg) ppr (XPatSynBind x) = ppr x pprTicks :: SDoc -> SDoc -> SDoc -- Print stuff about ticks only when -dppr-debug is on, to avoid -- them appearing in error messages (from the desugarer); see # 3263 -- Also print ticks in dumpStyle, so that -ddump-hpc actually does -- something useful. pprTicks pp_no_debug pp_when_debug = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty then pp_when_debug else pp_no_debug) {- ************************************************************************ * * Implicit parameter bindings * * ************************************************************************ -} -- | Haskell Implicit Parameter Bindings data HsIPBinds id = IPBinds (XIPBinds id) [LIPBind id] -- TcEvBinds -- Only in typechecker output; binds -- -- uses of the implicit parameters | XHsIPBinds (XXHsIPBinds id) type instance XIPBinds GhcPs = NoExtField type instance XIPBinds GhcRn = NoExtField type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the -- implicit parameters type instance XXHsIPBinds (GhcPass p) = NoExtCon isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool isEmptyIPBindsPR (IPBinds _ is) = null is isEmptyIPBindsPR (XHsIPBinds _) = True isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds isEmptyIPBindsTc (XHsIPBinds _) = True -- | Located Implicit Parameter Binding type LIPBind id = Located (IPBind id) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a -- list -- For details on above see note [Api annotations] in ApiAnnotation -- | Implicit parameter bindings. -- -- These bindings start off as (Left "x") in the parser and stay -- that way until after type-checking when they are replaced with -- (Right d), where "d" is the name of the dictionary holding the -- evidence for the implicit parameter. -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' -- For details on above see note [Api annotations] in ApiAnnotation data IPBind id = IPBind (XCIPBind id) (Either (Located HsIPName) (IdP id)) (LHsExpr id) | XIPBind (XXIPBind id) type instance XCIPBind (GhcPass p) = NoExtField type instance XXIPBind (GhcPass p) = NoExtCon instance OutputableBndrId p => Outputable (HsIPBinds (GhcPass p)) where ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs) $$ whenPprDebug (ppr ds) ppr (XHsIPBinds x) = ppr x instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) where name = case lr of Left (L _ ip) -> pprBndr LetBind ip Right id -> pprBndr LetBind id ppr (XIPBind x) = ppr x {- ************************************************************************ * * \subsection{@Sig@: type signatures and value-modifying user pragmas} * * ************************************************************************ It is convenient to lump ``value-modifying'' user-pragmas (e.g., ``specialise this function to these four types...'') in with type signatures. Then all the machinery to move them into place, etc., serves for both. -} -- | Located Signature type LSig pass = Located (Sig pass) -- | Signatures and pragmas data Sig pass = -- | An ordinary type signature -- -- > f :: Num a => a -> a -- -- After renaming, this list of Names contains the named -- wildcards brought into scope by this signature. For a signature -- @_ -> _a -> Bool@, the renamer will leave the unnamed wildcard @_@ -- untouched, and the named wildcard @_a@ is then replaced with -- fresh meta vars in the type. Their names are stored in the type -- signature that brought them into scope, in this third field to be -- more specific. -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon', -- 'ApiAnnotation.AnnComma' -- For details on above see note [Api annotations] in ApiAnnotation TypeSig (XTypeSig pass) [Located (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah (LHsSigWcType pass) -- RHS of the signature; can have wildcards -- | A pattern synonym type signature -- -- > pattern Single :: () => (Show a) => a -> [a] -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall' -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' -- For details on above see note [Api annotations] in ApiAnnotation | PatSynSig (XPatSynSig pass) [Located (IdP pass)] (LHsSigType pass) -- P :: forall a b. Req => Prov => ty -- | A signature for a class method -- False: ordinary class-method signature -- True: generic-default class method signature -- e.g. class C a where -- op :: a -> a -- Ordinary -- default op :: Eq a => a -> a -- Generic default -- No wildcards allowed here -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', -- 'ApiAnnotation.AnnDcolon' | ClassOpSig (XClassOpSig pass) Bool [Located (IdP pass)] (LHsSigType pass) -- | A type signature in generated code, notably the code -- generated for record selectors. We simply record -- the desired Id itself, replete with its name, type -- and IdDetails. Otherwise it's just like a type -- signature: there should be an accompanying binding | IdSig (XIdSig pass) Id -- | An ordinary fixity declaration -- -- > infixl 8 *** -- -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix', -- 'ApiAnnotation.AnnVal' -- For details on above see note [Api annotations] in ApiAnnotation | FixSig (XFixSig pass) (FixitySig pass) -- | An inline pragma -- -- > {#- INLINE f #-} -- -- - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@, -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde', -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation | InlineSig (XInlineSig pass) (Located (IdP pass)) -- Function name InlinePragma -- Never defaultInlinePragma -- | A specialisation pragma -- -- > {-# SPECIALISE f :: Int -> Int #-} -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@, -- 'ApiAnnotation.AnnTilde', -- 'ApiAnnotation.AnnVal', -- 'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@, -- 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation | SpecSig (XSpecSig pass) (Located (IdP pass)) -- Specialise a function or datatype ... [LHsSigType pass] -- ... to these types InlinePragma -- The pragma on SPECIALISE_INLINE form. -- If it's just defaultInlinePragma, then we said -- SPECIALISE, not SPECIALISE_INLINE -- | A specialisation pragma for instance declarations only -- -- > {-# SPECIALISE instance Eq [Int] #-} -- -- (Class tys); should be a specialisation of the -- current instance declaration -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass) -- Note [Pragma source text] in BasicTypes -- | A minimal complete definition pragma -- -- > {-# MINIMAL a | (b, c | (d | e)) #-} -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma', -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation | MinimalSig (XMinimalSig pass) SourceText (LBooleanFormula (Located (IdP pass))) -- Note [Pragma source text] in BasicTypes -- | A "set cost centre" pragma for declarations -- -- > {-# SCC funName #-} -- -- or -- -- > {-# SCC funName "cost_centre_name" #-} | SCCFunSig (XSCCFunSig pass) SourceText -- Note [Pragma source text] in BasicTypes (Located (IdP pass)) -- Function name (Maybe (Located StringLiteral)) -- | A complete match pragma -- -- > {-# COMPLETE C, D [:: T] #-} -- -- Used to inform the pattern match checker about additional -- complete matchings which, for example, arise from pattern -- synonym definitions. | CompleteMatchSig (XCompleteMatchSig pass) SourceText (Located [Located (IdP pass)]) (Maybe (Located (IdP pass))) | XSig (XXSig pass) type instance XTypeSig (GhcPass p) = NoExtField type instance XPatSynSig (GhcPass p) = NoExtField type instance XClassOpSig (GhcPass p) = NoExtField type instance XIdSig (GhcPass p) = NoExtField type instance XFixSig (GhcPass p) = NoExtField type instance XInlineSig (GhcPass p) = NoExtField type instance XSpecSig (GhcPass p) = NoExtField type instance XSpecInstSig (GhcPass p) = NoExtField type instance XMinimalSig (GhcPass p) = NoExtField type instance XSCCFunSig (GhcPass p) = NoExtField type instance XCompleteMatchSig (GhcPass p) = NoExtField type instance XXSig (GhcPass p) = NoExtCon -- | Located Fixity Signature type LFixitySig pass = Located (FixitySig pass) -- | Fixity Signature data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity | XFixitySig (XXFixitySig pass) type instance XFixitySig (GhcPass p) = NoExtField type instance XXFixitySig (GhcPass p) = NoExtCon -- | Type checker Specialisation Pragmas -- -- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer data TcSpecPrags = IsDefaultMethod -- ^ Super-specialised: a default method should -- be macro-expanded at every call site | SpecPrags [LTcSpecPrag] deriving Data -- | Located Type checker Specification Pragmas type LTcSpecPrag = Located TcSpecPrag -- | Type checker Specification Pragma data TcSpecPrag = SpecPrag Id HsWrapper InlinePragma -- ^ The Id to be specialised, a wrapper that specialises the -- polymorphic function, and inlining spec for the specialised function deriving Data noSpecPrags :: TcSpecPrags noSpecPrags = SpecPrags [] hasSpecPrags :: TcSpecPrags -> Bool hasSpecPrags (SpecPrags ps) = not (null ps) hasSpecPrags IsDefaultMethod = False isDefaultMethod :: TcSpecPrags -> Bool isDefaultMethod IsDefaultMethod = True isDefaultMethod (SpecPrags {}) = False isFixityLSig :: LSig name -> Bool isFixityLSig (L _ (FixSig {})) = True isFixityLSig _ = False isTypeLSig :: LSig name -> Bool -- Type signatures isTypeLSig (L _(TypeSig {})) = True isTypeLSig (L _(ClassOpSig {})) = True isTypeLSig (L _(IdSig {})) = True isTypeLSig _ = False isSpecLSig :: LSig name -> Bool isSpecLSig (L _(SpecSig {})) = True isSpecLSig _ = False isSpecInstLSig :: LSig name -> Bool isSpecInstLSig (L _ (SpecInstSig {})) = True isSpecInstLSig _ = False isPragLSig :: LSig name -> Bool -- Identifies pragmas isPragLSig (L _ (SpecSig {})) = True isPragLSig (L _ (InlineSig {})) = True isPragLSig (L _ (SCCFunSig {})) = True isPragLSig (L _ (CompleteMatchSig {})) = True isPragLSig _ = False isInlineLSig :: LSig name -> Bool -- Identifies inline pragmas isInlineLSig (L _ (InlineSig {})) = True isInlineLSig _ = False isMinimalLSig :: LSig name -> Bool isMinimalLSig (L _ (MinimalSig {})) = True isMinimalLSig _ = False isSCCFunSig :: LSig name -> Bool isSCCFunSig (L _ (SCCFunSig {})) = True isSCCFunSig _ = False isCompleteMatchSig :: LSig name -> Bool isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True isCompleteMatchSig _ = False hsSigDoc :: Sig name -> SDoc hsSigDoc (TypeSig {}) = text "type signature" hsSigDoc (PatSynSig {}) = text "pattern synonym signature" hsSigDoc (ClassOpSig _ is_deflt _ _) | is_deflt = text "default type signature" | otherwise = text "class method signature" hsSigDoc (IdSig {}) = text "id signature" hsSigDoc (SpecSig _ _ _ inl) = ppr inl <+> text "pragma" hsSigDoc (InlineSig _ _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma" hsSigDoc (SpecInstSig _ src _) = pprWithSourceText src empty <+> text "instance pragma" hsSigDoc (FixSig {}) = text "fixity declaration" hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" hsSigDoc (SCCFunSig {}) = text "SCC pragma" hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" hsSigDoc (XSig {}) = text "XSIG TTG extension" {- Check if signatures overlap; this is used when checking for duplicate signatures. Since some of the signatures contain a list of names, testing for equality is not enough -- we have to check if they overlap. -} instance OutputableBndrId p => Outputable (Sig (GhcPass p)) where ppr sig = ppr_sig sig ppr_sig :: (OutputableBndrId p) => Sig (GhcPass p) -> SDoc ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (ClassOpSig _ is_deflt vars ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) | otherwise = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id)) ppr_sig (FixSig _ fix_sig) = ppr fix_sig ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec })) = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var) (interpp'SP ty) inl) where pragmaSrc = case spec of NoUserInline -> "{-# SPECIALISE" _ -> "{-# SPECIALISE_INLINE" ppr_sig (InlineSig _ var inl) = pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl <+> pprPrefixOcc (unLoc var)) ppr_sig (SpecInstSig _ src ty) = pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty) ppr_sig (MinimalSig _ src bf) = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf) ppr_sig (PatSynSig _ names sig_ty) = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) ppr_sig (SCCFunSig _ src fn mlabel) = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel ) ppr_sig (CompleteMatchSig _ src cs mty) = pragSrcBrackets src "{-# COMPLETE" ((hsep (punctuate comma (map ppr (unLoc cs)))) <+> opt_sig) where opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty ppr_sig (XSig x) = ppr x instance OutputableBndrId p => Outputable (FixitySig (GhcPass p)) where ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops] where pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) ppr (XFixitySig x) = ppr x pragBrackets :: SDoc -> SDoc pragBrackets doc = text "{-#" <+> doc <+> text "#-}" -- | Using SourceText in case the pragma was spelled differently or used mixed -- case pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc pragSrcBrackets (SourceText src) _ doc = text src <+> doc <+> text "#-}" pragSrcBrackets NoSourceText alt doc = text alt <+> doc <+> text "#-}" pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] where pprvars = hsep $ punctuate comma (map pprPrefixOcc vars) pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty where pp_inl | isDefaultInlinePragma inl = empty | otherwise = pprInline inl pprTcSpecPrags :: TcSpecPrags -> SDoc pprTcSpecPrags IsDefaultMethod = text "" pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps) instance Outputable TcSpecPrag where ppr (SpecPrag var _ inl) = text "SPECIALIZE" <+> pprSpec var (text "") inl pprMinimalSig :: (OutputableBndr name) => LBooleanFormula (Located name) -> SDoc pprMinimalSig (L _ bf) = ppr (fmap unLoc bf) {- ************************************************************************ * * \subsection[PatSynBind]{A pattern synonym definition} * * ************************************************************************ -} -- | Haskell Pattern Synonym Details type HsPatSynDetails arg = HsConDetails arg [RecordPatSynField arg] -- See Note [Record PatSyn Fields] -- | Record Pattern Synonym Field data RecordPatSynField a = RecordPatSynField { recordPatSynSelectorId :: a -- Selector name visible in rest of the file , recordPatSynPatVar :: a -- Filled in by renamer, the name used internally -- by the pattern } deriving (Data, Functor) {- Note [Record PatSyn Fields] Consider the following two pattern synonyms. pattern P x y = ([x,True], [y,'v']) pattern Q{ x, y } =([x,True], [y,'v']) In P, we just have two local binders, x and y. In Q, we have local binders but also top-level record selectors x :: ([Bool], [Char]) -> Bool and similarly for y. It would make sense to support record-like syntax pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v']) when we have a different name for the local and top-level binder the distinction between the two names clear -} instance Outputable a => Outputable (RecordPatSynField a) where ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v instance Foldable RecordPatSynField where foldMap f (RecordPatSynField { recordPatSynSelectorId = visible , recordPatSynPatVar = hidden }) = f visible `mappend` f hidden instance Traversable RecordPatSynField where traverse f (RecordPatSynField { recordPatSynSelectorId =visible , recordPatSynPatVar = hidden }) = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id , recordPatSynPatVar = pat_var }) <$> f visible <*> f hidden -- | Haskell Pattern Synonym Direction data HsPatSynDir id = Unidirectional | ImplicitBidirectional | ExplicitBidirectional (MatchGroup id (LHsExpr id)) ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/Decls.hs0000644000000000000000000027735113713635744017700 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} {-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} -- | Abstract syntax of global declarations. -- -- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@, -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. module GHC.Hs.Decls ( -- * Toplevel declarations HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour, StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName, -- ** Class or type declarations TyClDecl(..), LTyClDecl, DataDeclRn(..), TyClGroup(..), tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, tyClGroupKindSigs, isClassDecl, isDataDecl, isSynDecl, tcdName, isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, tyFamInstDeclName, tyFamInstDeclLName, countTyClDecls, pprTyClDeclFlavour, tyClDeclLName, tyClDeclTyVars, hsDeclHasCusk, famResultKindSignature, FamilyDecl(..), LFamilyDecl, -- ** Instance declarations InstDecl(..), LInstDecl, FamilyInfo(..), TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, TyFamDefltDecl, LTyFamDefltDecl, DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS, FamInstEqn, LFamInstEqn, FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsTyPats, LClsInstDecl, ClsInstDecl(..), -- ** Standalone deriving declarations DerivDecl(..), LDerivDecl, -- ** Deriving strategies DerivStrategy(..), LDerivStrategy, derivStrategyName, foldDerivStrategy, mapDerivStrategy, -- ** @RULE@ declarations LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..), RuleBndr(..),LRuleBndr, collectRuleBndrSigTys, flattenRuleDecls, pprFullRuleName, -- ** @default@ declarations DefaultDecl(..), LDefaultDecl, -- ** Template haskell declaration splice SpliceExplicitFlag(..), SpliceDecl(..), LSpliceDecl, -- ** Foreign function interface declarations ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), CImportSpec(..), -- ** Data-constructor declarations ConDecl(..), LConDecl, HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta, getConNames, getConArgs, -- ** Document comments DocDecl(..), LDocDecl, docDeclDoc, -- ** Deprecations WarnDecl(..), LWarnDecl, WarnDecls(..), LWarnDecls, -- ** Annotations AnnDecl(..), LAnnDecl, AnnProvenance(..), annProvenanceName_maybe, -- ** Role annotations RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName, -- ** Injective type families FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn, resultVariableName, familyDeclLName, familyDeclName, -- * Grouping HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls ) where -- friends: import GhcPrelude import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, HsSplice, pprExpr, pprSpliceDecl ) -- Because Expr imports Decls via HsBracket import GHC.Hs.Binds import GHC.Hs.Types import GHC.Hs.Doc import TyCon import BasicTypes import Coercion import ForeignCall import GHC.Hs.Extension import NameSet -- others: import Class import Outputable import Util import SrcLoc import Type import Bag import Maybes import Data.Data hiding (TyCon,Fixity, Infix) {- ************************************************************************ * * \subsection[HsDecl]{Declarations} * * ************************************************************************ -} type LHsDecl p = Located (HsDecl p) -- ^ When in a list this may have -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' -- -- For details on above see note [Api annotations] in ApiAnnotation -- | A Haskell Declaration data HsDecl p = TyClD (XTyClD p) (TyClDecl p) -- ^ Type or Class Declaration | InstD (XInstD p) (InstDecl p) -- ^ Instance declaration | DerivD (XDerivD p) (DerivDecl p) -- ^ Deriving declaration | ValD (XValD p) (HsBind p) -- ^ Value declaration | SigD (XSigD p) (Sig p) -- ^ Signature declaration | KindSigD (XKindSigD p) (StandaloneKindSig p) -- ^ Standalone kind signature | DefD (XDefD p) (DefaultDecl p) -- ^ 'default' declaration | ForD (XForD p) (ForeignDecl p) -- ^ Foreign declaration | WarningD (XWarningD p) (WarnDecls p) -- ^ Warning declaration | AnnD (XAnnD p) (AnnDecl p) -- ^ Annotation declaration | RuleD (XRuleD p) (RuleDecls p) -- ^ Rule declaration | SpliceD (XSpliceD p) (SpliceDecl p) -- ^ Splice declaration -- (Includes quasi-quotes) | DocD (XDocD p) (DocDecl) -- ^ Documentation comment declaration | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration | XHsDecl (XXHsDecl p) type instance XTyClD (GhcPass _) = NoExtField type instance XInstD (GhcPass _) = NoExtField type instance XDerivD (GhcPass _) = NoExtField type instance XValD (GhcPass _) = NoExtField type instance XSigD (GhcPass _) = NoExtField type instance XKindSigD (GhcPass _) = NoExtField type instance XDefD (GhcPass _) = NoExtField type instance XForD (GhcPass _) = NoExtField type instance XWarningD (GhcPass _) = NoExtField type instance XAnnD (GhcPass _) = NoExtField type instance XRuleD (GhcPass _) = NoExtField type instance XSpliceD (GhcPass _) = NoExtField type instance XDocD (GhcPass _) = NoExtField type instance XRoleAnnotD (GhcPass _) = NoExtField type instance XXHsDecl (GhcPass _) = NoExtCon -- NB: all top-level fixity decls are contained EITHER -- EITHER SigDs -- OR in the ClassDecls in TyClDs -- -- The former covers -- a) data constructors -- b) class methods (but they can be also done in the -- signatures of class decls) -- c) imported functions (that have an IfacSig) -- d) top level decls -- -- The latter is for class methods only -- | Haskell Group -- -- A 'HsDecl' is categorised into a 'HsGroup' before being -- fed to the renamer. data HsGroup p = HsGroup { hs_ext :: XCHsGroup p, hs_valds :: HsValBinds p, hs_splcds :: [LSpliceDecl p], hs_tyclds :: [TyClGroup p], -- A list of mutually-recursive groups; -- This includes `InstDecl`s as well; -- Parser generates a singleton list; -- renamer does dependency analysis hs_derivds :: [LDerivDecl p], hs_fixds :: [LFixitySig p], -- Snaffled out of both top-level fixity signatures, -- and those in class declarations hs_defds :: [LDefaultDecl p], hs_fords :: [LForeignDecl p], hs_warnds :: [LWarnDecls p], hs_annds :: [LAnnDecl p], hs_ruleds :: [LRuleDecls p], hs_docs :: [LDocDecl] } | XHsGroup (XXHsGroup p) type instance XCHsGroup (GhcPass _) = NoExtField type instance XXHsGroup (GhcPass _) = NoExtCon emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p) emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } hsGroupInstDecls :: HsGroup id -> [LInstDecl id] hsGroupInstDecls = (=<<) group_instds . hs_tyclds emptyGroup = HsGroup { hs_ext = noExtField, hs_tyclds = [], hs_derivds = [], hs_fixds = [], hs_defds = [], hs_annds = [], hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_valds = error "emptyGroup hs_valds: Can't happen", hs_splcds = [], hs_docs = [] } appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p) -> HsGroup (GhcPass p) appendGroups HsGroup { hs_valds = val_groups1, hs_splcds = spliceds1, hs_tyclds = tyclds1, hs_derivds = derivds1, hs_fixds = fixds1, hs_defds = defds1, hs_annds = annds1, hs_fords = fords1, hs_warnds = warnds1, hs_ruleds = rulds1, hs_docs = docs1 } HsGroup { hs_valds = val_groups2, hs_splcds = spliceds2, hs_tyclds = tyclds2, hs_derivds = derivds2, hs_fixds = fixds2, hs_defds = defds2, hs_annds = annds2, hs_fords = fords2, hs_warnds = warnds2, hs_ruleds = rulds2, hs_docs = docs2 } = HsGroup { hs_ext = noExtField, hs_valds = val_groups1 `plusHsValBinds` val_groups2, hs_splcds = spliceds1 ++ spliceds2, hs_tyclds = tyclds1 ++ tyclds2, hs_derivds = derivds1 ++ derivds2, hs_fixds = fixds1 ++ fixds2, hs_annds = annds1 ++ annds2, hs_defds = defds1 ++ defds2, hs_fords = fords1 ++ fords2, hs_warnds = warnds1 ++ warnds2, hs_ruleds = rulds1 ++ rulds2, hs_docs = docs1 ++ docs2 } appendGroups _ _ = panic "appendGroups" instance (OutputableBndrId p) => Outputable (HsDecl (GhcPass p)) where ppr (TyClD _ dcl) = ppr dcl ppr (ValD _ binds) = ppr binds ppr (DefD _ def) = ppr def ppr (InstD _ inst) = ppr inst ppr (DerivD _ deriv) = ppr deriv ppr (ForD _ fd) = ppr fd ppr (SigD _ sd) = ppr sd ppr (KindSigD _ ksd) = ppr ksd ppr (RuleD _ rd) = ppr rd ppr (WarningD _ wd) = ppr wd ppr (AnnD _ ad) = ppr ad ppr (SpliceD _ dd) = ppr dd ppr (DocD _ doc) = ppr doc ppr (RoleAnnotD _ ra) = ppr ra ppr (XHsDecl x) = ppr x instance (OutputableBndrId p) => Outputable (HsGroup (GhcPass p)) where ppr (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_derivds = deriv_decls, hs_fixds = fix_decls, hs_warnds = deprec_decls, hs_annds = ann_decls, hs_fords = foreign_decls, hs_defds = default_decls, hs_ruleds = rule_decls }) = vcat_mb empty [ppr_ds fix_decls, ppr_ds default_decls, ppr_ds deprec_decls, ppr_ds ann_decls, ppr_ds rule_decls, if isEmptyValBinds val_decls then Nothing else Just (ppr val_decls), ppr_ds (tyClGroupRoleDecls tycl_decls), ppr_ds (tyClGroupKindSigs tycl_decls), ppr_ds (tyClGroupTyClDecls tycl_decls), ppr_ds (tyClGroupInstDecls tycl_decls), ppr_ds deriv_decls, ppr_ds foreign_decls] where ppr_ds :: Outputable a => [a] -> Maybe SDoc ppr_ds [] = Nothing ppr_ds ds = Just (vcat (map ppr ds)) vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc -- Concatenate vertically with white-space between non-blanks vcat_mb _ [] = empty vcat_mb gap (Nothing : ds) = vcat_mb gap ds vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds ppr (XHsGroup x) = ppr x -- | Located Splice Declaration type LSpliceDecl pass = Located (SpliceDecl pass) -- | Splice Declaration data SpliceDecl p = SpliceDecl -- Top level splice (XSpliceDecl p) (Located (HsSplice p)) SpliceExplicitFlag | XSpliceDecl (XXSpliceDecl p) type instance XSpliceDecl (GhcPass _) = NoExtField type instance XXSpliceDecl (GhcPass _) = NoExtCon instance OutputableBndrId p => Outputable (SpliceDecl (GhcPass p)) where ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f ppr (XSpliceDecl x) = ppr x {- ************************************************************************ * * Type and class declarations * * ************************************************************************ Note [The Naming story] ~~~~~~~~~~~~~~~~~~~~~~~ Here is the story about the implicit names that go with type, class, and instance decls. It's a bit tricky, so pay attention! "Implicit" (or "system") binders ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Each data type decl defines a worker name for each constructor to-T and from-T convertors Each class decl defines a tycon for the class a data constructor for that tycon the worker for that constructor a selector for each superclass All have occurrence names that are derived uniquely from their parent declaration. None of these get separate definitions in an interface file; they are fully defined by the data or class decl. But they may *occur* in interface files, of course. Any such occurrence must haul in the relevant type or class decl. Plan of attack: - Ensure they "point to" the parent data/class decl when loading that decl from an interface file (See RnHiFiles.getSysBinders) - When typechecking the decl, we build the implicit TyCons and Ids. When doing so we look them up in the name cache (RnEnv.lookupSysName), to ensure correct module and provenance is set These are the two places that we have to conjure up the magic derived names. (The actual magic is in OccName.mkWorkerOcc, etc.) Default methods ~~~~~~~~~~~~~~~ - Occurrence name is derived uniquely from the method name E.g. $dmmax - If there is a default method name at all, it's recorded in the ClassOpSig (in GHC.Hs.Binds), in the DefMethInfo field. (DefMethInfo is defined in Class.hs) Source-code class decls and interface-code class decls are treated subtly differently, which has given me a great deal of confusion over the years. Here's the deal. (We distinguish the two cases because source-code decls have (Just binds) in the tcdMeths field, whereas interface decls have Nothing. In *source-code* class declarations: - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName This is done by RdrHsSyn.mkClassOpSigDM - The renamer renames it to a Name - During typechecking, we generate a binding for each $dm for which there's a programmer-supplied default method: class Foo a where op1 :: op2 :: op1 = ... We generate a binding for $dmop1 but not for $dmop2. The Class for Foo has a Nothing for op2 and a Just ($dm_op1, VanillaDM) for op1. The Name for $dmop2 is simply discarded. In *interface-file* class declarations: - When parsing, we see if there's an explicit programmer-supplied default method because there's an '=' sign to indicate it: class Foo a where op1 = :: -- NB the '=' op2 :: We use this info to generate a DefMeth with a suitable RdrName for op1, and a NoDefMeth for op2 - The interface file has a separate definition for $dmop1, with unfolding etc. - The renamer renames it to a Name. - The renamer treats $dmop1 as a free variable of the declaration, so that the binding for $dmop1 will be sucked in. (See RnHsSyn.tyClDeclFVs) This doesn't happen for source code class decls, because they *bind* the default method. Dictionary functions ~~~~~~~~~~~~~~~~~~~~ Each instance declaration gives rise to one dictionary function binding. The type checker makes up new source-code instance declarations (e.g. from 'deriving' or generic default methods --- see TcInstDcls.tcInstDecls1). So we can't generate the names for dictionary functions in advance (we don't know how many we need). On the other hand for interface-file instance declarations, the decl specifies the name of the dictionary function, and it has a binding elsewhere in the interface file: instance {Eq Int} = dEqInt dEqInt :: {Eq Int} So again we treat source code and interface file code slightly differently. Source code: - Source code instance decls have a Nothing in the (Maybe name) field (see data InstDecl below) - The typechecker makes up a Local name for the dict fun for any source-code instance decl, whether it comes from a source-code instance decl, or whether the instance decl is derived from some other construct (e.g. 'deriving'). - The occurrence name it chooses is derived from the instance decl (just for documentation really) --- e.g. dNumInt. Two dict funs may share a common occurrence name, but will have different uniques. E.g. instance Foo [Int] where ... instance Foo [Bool] where ... These might both be dFooList - The CoreTidy phase externalises the name, and ensures the occurrence name is unique (this isn't special to dict funs). So we'd get dFooList and dFooList1. - We can take this relaxed approach (changing the occurrence name later) because dict fun Ids are not captured in a TyCon or Class (unlike default methods, say). Instead, they are kept separately in the InstEnv. This makes it easy to adjust them after compiling a module. (Once we've finished compiling that module, they don't change any more.) Interface file code: - The instance decl gives the dict fun name, so the InstDecl has a (Just name) in the (Maybe name) field. - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we suck in the dfun binding -} -- | Located Declaration of a Type or Class type LTyClDecl pass = Located (TyClDecl pass) -- | A type or class declaration. data TyClDecl pass = -- | @type/data family T :: *->*@ -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnData', -- 'ApiAnnotation.AnnFamily','ApiAnnotation.AnnDcolon', -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpenP', -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnCloseP', -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnRarrow', -- 'ApiAnnotation.AnnVbar' -- For details on above see note [Api annotations] in ApiAnnotation FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass } | -- | @type@ declaration -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnEqual', -- For details on above see note [Api annotations] in ApiAnnotation SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs , tcdLName :: Located (IdP pass) -- ^ Type constructor , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an -- associated type these -- include outer binders , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration , tcdRhs :: LHsType pass } -- ^ RHS of type declaration | -- | @data@ declaration -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', -- 'ApiAnnotation.AnnFamily', -- 'ApiAnnotation.AnnNewType', -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnDcolon' -- 'ApiAnnotation.AnnWhere', -- For details on above see note [Api annotations] in ApiAnnotation DataDecl { tcdDExt :: XDataDecl pass -- ^ Post renamer, CUSK flag, FVs , tcdLName :: Located (IdP pass) -- ^ Type constructor , tcdTyVars :: LHsQTyVars pass -- ^ Type variables -- See Note [TyVar binders for associated declarations] , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration , tcdDataDefn :: HsDataDefn pass } | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs tcdCtxt :: LHsContext pass, -- ^ Context... tcdLName :: Located (IdP pass), -- ^ Name of the class tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration tcdFDs :: [LHsFunDep pass], -- ^ Functional deps tcdSigs :: [LSig pass], -- ^ Methods' signatures tcdMeths :: LHsBinds pass, -- ^ Default methods tcdATs :: [LFamilyDecl pass], -- ^ Associated types; tcdATDefs :: [LTyFamDefltDecl pass], -- ^ Associated type defaults tcdDocs :: [LDocDecl] -- ^ Haddock docs } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass', -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose' -- - The tcdFDs will have 'ApiAnnotation.AnnVbar', -- 'ApiAnnotation.AnnComma' -- 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation | XTyClDecl (XXTyClDecl pass) type LHsFunDep pass = Located (FunDep (Located (IdP pass))) data DataDeclRn = DataDeclRn { tcdDataCusk :: Bool -- ^ does this have a CUSK? -- See Note [CUSKs: complete user-supplied kind signatures] , tcdFVs :: NameSet } deriving Data {- Note [TyVar binders for associated decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For an /associated/ data, newtype, or type-family decl, the LHsQTyVars /includes/ outer binders. For example class T a where data D a c type F a b :: * type F a b = a -> a Here the data decl for 'D', and type-family decl for 'F', both include 'a' in their LHsQTyVars (tcdTyVars and fdTyVars resp). Ditto any implicit binders in the hsq_implicit field of the LHSQTyVars. The idea is that the associated type is really a top-level decl in its own right. However we are careful to use the same name 'a', so that we can match things up. c.f. Note [Associated type tyvar names] in Class.hs Note [Family instance declaration binders] -} type instance XFamDecl (GhcPass _) = NoExtField type instance XSynDecl GhcPs = NoExtField type instance XSynDecl GhcRn = NameSet -- FVs type instance XSynDecl GhcTc = NameSet -- FVs type instance XDataDecl GhcPs = NoExtField type instance XDataDecl GhcRn = DataDeclRn type instance XDataDecl GhcTc = DataDeclRn type instance XClassDecl GhcPs = NoExtField type instance XClassDecl GhcRn = NameSet -- FVs type instance XClassDecl GhcTc = NameSet -- FVs type instance XXTyClDecl (GhcPass _) = NoExtCon -- Simple classifiers for TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- | @True@ <=> argument is a @data@\/@newtype@ -- declaration. isDataDecl :: TyClDecl pass -> Bool isDataDecl (DataDecl {}) = True isDataDecl _other = False -- | type or type instance declaration isSynDecl :: TyClDecl pass -> Bool isSynDecl (SynDecl {}) = True isSynDecl _other = False -- | type class isClassDecl :: TyClDecl pass -> Bool isClassDecl (ClassDecl {}) = True isClassDecl _ = False -- | type/data family declaration isFamilyDecl :: TyClDecl pass -> Bool isFamilyDecl (FamDecl {}) = True isFamilyDecl _other = False -- | type family declaration isTypeFamilyDecl :: TyClDecl pass -> Bool isTypeFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = info })) = case info of OpenTypeFamily -> True ClosedTypeFamily {} -> True _ -> False isTypeFamilyDecl _ = False -- | open type family info isOpenTypeFamilyInfo :: FamilyInfo pass -> Bool isOpenTypeFamilyInfo OpenTypeFamily = True isOpenTypeFamilyInfo _ = False -- | closed type family info isClosedTypeFamilyInfo :: FamilyInfo pass -> Bool isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True isClosedTypeFamilyInfo _ = False -- | data family declaration isDataFamilyDecl :: TyClDecl pass -> Bool isDataFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = DataFamily })) = True isDataFamilyDecl _other = False -- Dealing with names tyFamInstDeclName :: TyFamInstDecl (GhcPass p) -> IdP (GhcPass p) tyFamInstDeclName = unLoc . tyFamInstDeclLName tyFamInstDeclLName :: TyFamInstDecl (GhcPass p) -> Located (IdP (GhcPass p)) tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = (HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) }) = ln tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn nec))) = noExtCon nec tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec tyClDeclLName :: TyClDecl (GhcPass p) -> Located (IdP (GhcPass p)) tyClDeclLName (FamDecl { tcdFam = fd }) = familyDeclLName fd tyClDeclLName (SynDecl { tcdLName = ln }) = ln tyClDeclLName (DataDecl { tcdLName = ln }) = ln tyClDeclLName (ClassDecl { tcdLName = ln }) = ln tyClDeclLName (XTyClDecl nec) = noExtCon nec tcdName :: TyClDecl (GhcPass p) -> IdP (GhcPass p) tcdName = unLoc . tyClDeclLName tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs tyClDeclTyVars d = tcdTyVars d countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int) -- class, synonym decls, data, newtype, family decls countTyClDecls decls = (count isClassDecl decls, count isSynDecl decls, -- excluding... count isDataTy decls, -- ...family... count isNewTy decls, -- ...instances count isFamilyDecl decls) where isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True isDataTy _ = False isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True isNewTy _ = False -- | Does this declaration have a complete, user-supplied kind signature? -- See Note [CUSKs: complete user-supplied kind signatures] hsDeclHasCusk :: TyClDecl GhcRn -> Bool hsDeclHasCusk (FamDecl { tcdFam = FamilyDecl { fdInfo = fam_info , fdTyVars = tyvars , fdResultSig = L _ resultSig } }) = case fam_info of ClosedTypeFamily {} -> hsTvbAllKinded tyvars && isJust (famResultKindSignature resultSig) _ -> True -- Un-associated open type/data families have CUSKs hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) = hsTvbAllKinded tyvars && isJust (hsTyKindSig rhs) hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars hsDeclHasCusk (FamDecl { tcdFam = XFamilyDecl nec }) = noExtCon nec hsDeclHasCusk (XTyClDecl nec) = noExtCon nec -- Pretty-printing TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~ instance (OutputableBndrId p) => Outputable (TyClDecl (GhcPass p)) where ppr (FamDecl { tcdFam = decl }) = ppr decl ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity , tcdRhs = rhs }) = hang (text "type" <+> pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+> equals) 4 (ppr rhs) ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity , tcdDataDefn = defn }) = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, tcdFixity = fixity, tcdFDs = fds, tcdSigs = sigs, tcdMeths = methods, tcdATs = ats, tcdATDefs = at_defs}) | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part = top_matter | otherwise -- Laid out = vcat [ top_matter <+> text "where" , nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats ++ map (pprTyFamDefltDecl . unLoc) at_defs ++ pprLHsBindsForUser methods sigs) ] where top_matter = text "class" <+> pp_vanilla_decl_head lclas tyvars fixity context <+> pprFundeps (map unLoc fds) ppr (XTyClDecl x) = ppr x instance OutputableBndrId p => Outputable (TyClGroup (GhcPass p)) where ppr (TyClGroup { group_tyclds = tyclds , group_roles = roles , group_kisigs = kisigs , group_instds = instds } ) = hang (text "TyClGroup") 2 $ ppr kisigs $$ ppr tyclds $$ ppr roles $$ ppr instds ppr (XTyClGroup x) = ppr x pp_vanilla_decl_head :: (OutputableBndrId p) => Located (IdP (GhcPass p)) -> LHsQTyVars (GhcPass p) -> LexicalFixity -> LHsContext (GhcPass p) -> SDoc pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context = hsep [pprLHsContext context, pp_tyvars tyvars] where pp_tyvars (varl:varsr) | fixity == Infix && length varsr > 1 = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing) , (ppr.unLoc) (head varsr), char ')' , hsep (map (ppr.unLoc) (tail varsr))] | fixity == Infix = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) , hsep (map (ppr.unLoc) varsr)] | otherwise = hsep [ pprPrefixOcc (unLoc thing) , hsep (map (ppr.unLoc) (varl:varsr))] pp_tyvars [] = pprPrefixOcc (unLoc thing) pp_vanilla_decl_head _ (XLHsQTyVars x) _ _ = ppr x pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc pprTyClDeclFlavour (ClassDecl {}) = text "class" pprTyClDeclFlavour (SynDecl {}) = text "type" pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) = pprFlavour info <+> text "family" pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl nec }) = noExtCon nec pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) = ppr nd pprTyClDeclFlavour (DataDecl { tcdDataDefn = XHsDataDefn x }) = ppr x pprTyClDeclFlavour (XTyClDecl x) = ppr x {- Note [CUSKs: complete user-supplied kind signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We kind-check declarations differently if they have a complete, user-supplied kind signature (CUSK). This is because we can safely generalise a CUSKed declaration before checking all of the others, supporting polymorphic recursion. See https://gitlab.haskell.org/ghc/ghc/wikis/ghc-kinds/kind-inference#proposed-new-strategy and #9200 for lots of discussion of how we got here. The detection of CUSKs is enabled by the -XCUSKs extension, switched on by default. Under -XNoCUSKs, all declarations are treated as if they have no CUSK. See https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0036-kind-signatures.rst PRINCIPLE: a type declaration has a CUSK iff we could produce a separate kind signature for it, just like a type signature for a function, looking only at the header of the declaration. Examples: * data T1 (a :: *->*) (b :: *) = .... -- Has CUSK; equivalant to T1 :: (*->*) -> * -> * * data T2 a b = ... -- No CUSK; we do not want to guess T2 :: * -> * -> * -- because the full decl might be data T a b = MkT (a b) * data T3 (a :: k -> *) (b :: *) = ... -- CUSK; equivalent to T3 :: (k -> *) -> * -> * -- We lexically generalise over k to get -- T3 :: forall k. (k -> *) -> * -> * -- The generalisation is here is purely lexical, just like -- f3 :: a -> a -- means -- f3 :: forall a. a -> a * data T4 (a :: j k) = ... -- CUSK; equivalent to T4 :: j k -> * -- which we lexically generalise to T4 :: forall j k. j k -> * -- and then, if PolyKinds is on, we further generalise to -- T4 :: forall kk (j :: kk -> *) (k :: kk). j k -> * -- Again this is exactly like what happens as the term level -- when you write -- f4 :: forall a b. a b -> Int NOTE THAT * A CUSK does /not/ mean that everything about the kind signature is fully specified by the user. Look at T4 and f4: we had do do kind inference to figure out the kind-quantification. But in both cases (T4 and f4) that inference is done looking /only/ at the header of T4 (or signature for f4), not at the definition thereof. * The CUSK completely fixes the kind of the type constructor, forever. * The precise rules, for each declaration form, for whethher a declaration has a CUSK are given in the user manual section "Complete user-supplied kind signatures and polymorphic recursion". BUt they simply implement PRINCIPLE above. * Open type families are interesting: type family T5 a b :: * There simply /is/ no accompanying declaration, so that info is all we'll ever get. So we it has a CUSK by definition, and we default any un-fixed kind variables to *. * Associated types are a bit tricker: class C6 a where type family T6 a b :: * op :: a Int -> Int Here C6 does not have a CUSK (in fact we ultimately discover that a :: * -> *). And hence neither does T6, the associated family, because we can't fix its kind until we have settled C6. Another way to say it: unlike a top-level, we /may/ discover more about a's kind from C6's definition. * A data definition with a top-level :: must explicitly bind all kind variables to the right of the ::. See test dependent/should_compile/KindLevels, which requires this case. (Naturally, any kind variable mentioned before the :: should not be bound after it.) This last point is much more debatable than the others; see #15142 comment:22 Because this is fiddly to check, there is a field in the DataDeclRn structure (included in a DataDecl after the renamer) that stores whether or not the declaration has a CUSK. -} {- ********************************************************************* * * TyClGroup Strongly connected components of type, class, instance, and role declarations * * ********************************************************************* -} {- Note [TyClGroups and dependency analysis] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A TyClGroup represents a strongly connected components of type/class/instance decls, together with the role annotations for the type/class declarations. The hs_tyclds :: [TyClGroup] field of a HsGroup is a dependency-order sequence of strongly-connected components. Invariants * The type and class declarations, group_tyclds, may depend on each other, or earlier TyClGroups, but not on later ones * The role annotations, group_roles, are role-annotations for some or all of the types and classes in group_tyclds (only). * The instance declarations, group_instds, may (and usually will) depend on group_tyclds, or on earlier TyClGroups, but not on later ones. See Note [Dependency analsis of type, class, and instance decls] in RnSource for more info. -} -- | Type or Class Group data TyClGroup pass -- See Note [TyClGroups and dependency analysis] = TyClGroup { group_ext :: XCTyClGroup pass , group_tyclds :: [LTyClDecl pass] , group_roles :: [LRoleAnnotDecl pass] , group_kisigs :: [LStandaloneKindSig pass] , group_instds :: [LInstDecl pass] } | XTyClGroup (XXTyClGroup pass) type instance XCTyClGroup (GhcPass _) = NoExtField type instance XXTyClGroup (GhcPass _) = NoExtCon tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass] tyClGroupTyClDecls = concatMap group_tyclds tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass] tyClGroupInstDecls = concatMap group_instds tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass] tyClGroupRoleDecls = concatMap group_roles tyClGroupKindSigs :: [TyClGroup pass] -> [LStandaloneKindSig pass] tyClGroupKindSigs = concatMap group_kisigs {- ********************************************************************* * * Data and type family declarations * * ********************************************************************* -} {- Note [FamilyResultSig] ~~~~~~~~~~~~~~~~~~~~~~~~~ This data type represents the return signature of a type family. Possible values are: * NoSig - the user supplied no return signature: type family Id a where ... * KindSig - the user supplied the return kind: type family Id a :: * where ... * TyVarSig - user named the result with a type variable and possibly provided a kind signature for that variable: type family Id a = r where ... type family Id a = (r :: *) where ... Naming result of a type family is required if we want to provide injectivity annotation for a type family: type family Id a = r | r -> a where ... See also: Note [Injectivity annotation] Note [Injectivity annotation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A user can declare a type family to be injective: type family Id a = r | r -> a where ... * The part after the "|" is called "injectivity annotation". * "r -> a" part is called "injectivity condition"; at the moment terms "injectivity annotation" and "injectivity condition" are synonymous because we only allow a single injectivity condition. * "r" is the "LHS of injectivity condition". LHS can only contain the variable naming the result of a type family. * "a" is the "RHS of injectivity condition". RHS contains space-separated type and kind variables representing the arguments of a type family. Variables can be omitted if a type family is not injective in these arguments. Example: type family Foo a b c = d | d -> a c where ... Note that: (a) naming of type family result is required to provide injectivity annotation (b) for associated types if the result was named then injectivity annotation is mandatory. Otherwise result type variable is indistinguishable from associated type default. It is possible that in the future this syntax will be extended to support more complicated injectivity annotations. For example we could declare that if we know the result of Plus and one of its arguments we can determine the other argument: type family Plus a b = (r :: Nat) | r a -> b, r b -> a where ... Here injectivity annotation would consist of two comma-separated injectivity conditions. See also Note [Injective type families] in TyCon -} -- | Located type Family Result Signature type LFamilyResultSig pass = Located (FamilyResultSig pass) -- | type Family Result Signature data FamilyResultSig pass = -- see Note [FamilyResultSig] NoSig (XNoSig pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : -- For details on above see note [Api annotations] in ApiAnnotation | KindSig (XCKindSig pass) (LHsKind pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', -- 'ApiAnnotation.AnnCloseP' -- For details on above see note [Api annotations] in ApiAnnotation | TyVarSig (XTyVarSig pass) (LHsTyVarBndr pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', -- 'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual' | XFamilyResultSig (XXFamilyResultSig pass) -- For details on above see note [Api annotations] in ApiAnnotation type instance XNoSig (GhcPass _) = NoExtField type instance XCKindSig (GhcPass _) = NoExtField type instance XTyVarSig (GhcPass _) = NoExtField type instance XXFamilyResultSig (GhcPass _) = NoExtCon -- | Located type Family Declaration type LFamilyDecl pass = Located (FamilyDecl pass) -- | type Family Declaration data FamilyDecl pass = FamilyDecl { fdExt :: XCFamilyDecl pass , fdInfo :: FamilyInfo pass -- type/data, closed/open , fdLName :: Located (IdP pass) -- type constructor , fdTyVars :: LHsQTyVars pass -- type variables -- See Note [TyVar binders for associated declarations] , fdFixity :: LexicalFixity -- Fixity used in the declaration , fdResultSig :: LFamilyResultSig pass -- result signature , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann } | XFamilyDecl (XXFamilyDecl pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily', -- 'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP', -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnCloseP', -- 'ApiAnnotation.AnnEqual', 'ApiAnnotation.AnnRarrow', -- 'ApiAnnotation.AnnVbar' -- For details on above see note [Api annotations] in ApiAnnotation type instance XCFamilyDecl (GhcPass _) = NoExtField type instance XXFamilyDecl (GhcPass _) = NoExtCon -- | Located Injectivity Annotation type LInjectivityAnn pass = Located (InjectivityAnn pass) -- | If the user supplied an injectivity annotation it is represented using -- InjectivityAnn. At the moment this is a single injectivity condition - see -- Note [Injectivity annotation]. `Located name` stores the LHS of injectivity -- condition. `[Located name]` stores the RHS of injectivity condition. Example: -- -- type family Foo a b c = r | r -> a c where ... -- -- This will be represented as "InjectivityAnn `r` [`a`, `c`]" data InjectivityAnn pass = InjectivityAnn (Located (IdP pass)) [Located (IdP pass)] -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar' -- For details on above see note [Api annotations] in ApiAnnotation data FamilyInfo pass = DataFamily | OpenTypeFamily -- | 'Nothing' if we're in an hs-boot file and the user -- said "type family Foo x where .." | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) ------------- Functions over FamilyDecls ----------- familyDeclLName :: FamilyDecl (GhcPass p) -> Located (IdP (GhcPass p)) familyDeclLName (FamilyDecl { fdLName = n }) = n familyDeclLName (XFamilyDecl nec) = noExtCon nec familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p) familyDeclName = unLoc . familyDeclLName famResultKindSignature :: FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p)) famResultKindSignature (NoSig _) = Nothing famResultKindSignature (KindSig _ ki) = Just ki famResultKindSignature (TyVarSig _ bndr) = case unLoc bndr of UserTyVar _ _ -> Nothing KindedTyVar _ _ ki -> Just ki XTyVarBndr nec -> noExtCon nec famResultKindSignature (XFamilyResultSig nec) = noExtCon nec -- | Maybe return name of the result type variable resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a)) resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig resultVariableName _ = Nothing ------------- Pretty printing FamilyDecls ----------- instance OutputableBndrId p => Outputable (FamilyDecl (GhcPass p)) where ppr = pprFamilyDecl TopLevel pprFamilyDecl :: (OutputableBndrId p) => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon , fdTyVars = tyvars , fdFixity = fixity , fdResultSig = L _ result , fdInjectivityAnn = mb_inj }) = vcat [ pprFlavour info <+> pp_top_level <+> pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+> pp_kind <+> pp_inj <+> pp_where , nest 2 $ pp_eqns ] where pp_top_level = case top_level of TopLevel -> text "family" NotTopLevel -> empty pp_kind = case result of NoSig _ -> empty KindSig _ kind -> dcolon <+> ppr kind TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr XFamilyResultSig nec -> noExtCon nec pp_inj = case mb_inj of Just (L _ (InjectivityAnn lhs rhs)) -> hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] Nothing -> empty (pp_where, pp_eqns) = case info of ClosedTypeFamily mb_eqns -> ( text "where" , case mb_eqns of Nothing -> text ".." Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns ) _ -> (empty, empty) pprFamilyDecl _ (XFamilyDecl nec) = noExtCon nec pprFlavour :: FamilyInfo pass -> SDoc pprFlavour DataFamily = text "data" pprFlavour OpenTypeFamily = text "type" pprFlavour (ClosedTypeFamily {}) = text "type" instance Outputable (FamilyInfo pass) where ppr info = pprFlavour info <+> text "family" {- ********************************************************************* * * Data types and data constructors * * ********************************************************************* -} -- | Haskell Data type Definition data HsDataDefn pass -- The payload of a data type defn -- Used *both* for vanilla data declarations, -- *and* for data family instances = -- | Declares a data type or newtype, giving its constructors -- @ -- data/newtype T a = -- data/newtype instance T [a] = -- @ HsDataDefn { dd_ext :: XCHsDataDefn pass, dd_ND :: NewOrData, dd_ctxt :: LHsContext pass, -- ^ Context dd_cType :: Maybe (Located CType), dd_kindSig:: Maybe (LHsKind pass), -- ^ Optional kind signature. -- -- @(Just k)@ for a GADT-style @data@, -- or @data instance@ decl, with explicit kind sig -- -- Always @Nothing@ for H98-syntax decls dd_cons :: [LConDecl pass], -- ^ Data constructors -- -- For @data T a = T1 | T2 a@ -- the 'LConDecl's all have 'ConDeclH98'. -- For @data T a where { T1 :: T a }@ -- the 'LConDecls' all have 'ConDeclGADT'. dd_derivs :: HsDeriving pass -- ^ Optional 'deriving' claues -- For details on above see note [Api annotations] in ApiAnnotation } | XHsDataDefn (XXHsDataDefn pass) type instance XCHsDataDefn (GhcPass _) = NoExtField type instance XXHsDataDefn (GhcPass _) = NoExtCon -- | Haskell Deriving clause type HsDeriving pass = Located [LHsDerivingClause pass] -- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is -- plural because one can specify multiple deriving clauses using the -- @-XDerivingStrategies@ language extension. -- -- The list of 'LHsDerivingClause's corresponds to exactly what the user -- requested to derive, in order. If no deriving clauses were specified, -- the list is empty. type LHsDerivingClause pass = Located (HsDerivingClause pass) -- | A single @deriving@ clause of a data declaration. -- -- - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnDeriving', 'ApiAnnotation.AnnStock', -- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype', -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' data HsDerivingClause pass -- See Note [Deriving strategies] in TcDeriv = HsDerivingClause { deriv_clause_ext :: XCHsDerivingClause pass , deriv_clause_strategy :: Maybe (LDerivStrategy pass) -- ^ The user-specified strategy (if any) to use when deriving -- 'deriv_clause_tys'. , deriv_clause_tys :: Located [LHsSigType pass] -- ^ The types to derive. -- -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@, -- we can mention type variables that aren't bound by the datatype, e.g. -- -- > data T b = ... deriving (C [a]) -- -- should produce a derived instance for @C [a] (T b)@. } | XHsDerivingClause (XXHsDerivingClause pass) type instance XCHsDerivingClause (GhcPass _) = NoExtField type instance XXHsDerivingClause (GhcPass _) = NoExtCon instance OutputableBndrId p => Outputable (HsDerivingClause (GhcPass p)) where ppr (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ dct }) = hsep [ text "deriving" , pp_strat_before , pp_dct dct , pp_strat_after ] where -- This complexity is to distinguish between -- deriving Show -- deriving (Show) pp_dct [HsIB { hsib_body = ty }] = ppr (parenthesizeHsType appPrec ty) pp_dct _ = parens (interpp'SP dct) -- @via@ is unique in that in comes /after/ the class being derived, -- so we must special-case it. (pp_strat_before, pp_strat_after) = case dcs of Just (L _ via@ViaStrategy{}) -> (empty, ppr via) _ -> (ppDerivStrategy dcs, empty) ppr (XHsDerivingClause x) = ppr x -- | Located Standalone Kind Signature type LStandaloneKindSig pass = Located (StandaloneKindSig pass) data StandaloneKindSig pass = StandaloneKindSig (XStandaloneKindSig pass) (Located (IdP pass)) -- Why a single binder? See #16754 (LHsSigType pass) -- Why not LHsSigWcType? See Note [Wildcards in standalone kind signatures] | XStandaloneKindSig (XXStandaloneKindSig pass) type instance XStandaloneKindSig (GhcPass p) = NoExtField type instance XXStandaloneKindSig (GhcPass p) = NoExtCon standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p) standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname standaloneKindSigName (XStandaloneKindSig nec) = noExtCon nec {- Note [Wildcards in standalone kind signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Standalone kind signatures enable polymorphic recursion, and it is unclear how to reconcile this with partial type signatures, so we disallow wildcards in them. We reject wildcards in 'rnStandaloneKindSignature' by returning False for 'StandaloneKindSigCtx' in 'wildCardsAllowed'. The alternative design is to have special treatment for partial standalone kind signatures, much like we have special treatment for partial type signatures in terms. However, partial standalone kind signatures are not a proper replacement for CUSKs, so this would be a separate feature. -} data NewOrData = NewType -- ^ @newtype Blah ...@ | DataType -- ^ @data Blah ...@ deriving( Eq, Data ) -- Needed because Demand derives Eq -- | Convert a 'NewOrData' to a 'TyConFlavour' newOrDataToFlavour :: NewOrData -> TyConFlavour newOrDataToFlavour NewType = NewtypeFlavour newOrDataToFlavour DataType = DataTypeFlavour -- | Located data Constructor Declaration type LConDecl pass = Located (ConDecl pass) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when -- in a GADT constructor list -- For details on above see note [Api annotations] in ApiAnnotation -- | -- -- @ -- data T b = forall a. Eq a => MkT a b -- MkT :: forall b a. Eq a => MkT a b -- -- data T b where -- MkT1 :: Int -> T Int -- -- data T = Int `MkT` Int -- | MkT2 -- -- data T a where -- Int `MkT` Int :: T Int -- @ -- -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnCLose', -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnVbar', -- 'ApiAnnotation.AnnDarrow','ApiAnnotation.AnnDarrow', -- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot' -- For details on above see note [Api annotations] in ApiAnnotation -- | data Constructor Declaration data ConDecl pass = ConDeclGADT { con_g_ext :: XConDeclGADT pass , con_names :: [Located (IdP pass)] -- The next four fields describe the type after the '::' -- See Note [GADT abstract syntax] -- The following field is Located to anchor API Annotations, -- AnnForall and AnnDot. , con_forall :: Located Bool -- ^ True <=> explicit forall -- False => hsq_explicit is empty , con_qvars :: LHsQTyVars pass -- Whether or not there is an /explicit/ forall, we still -- need to capture the implicitly-bound type/kind variables , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon , con_res_ty :: LHsType pass -- ^ Result type , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } | ConDeclH98 { con_ext :: XConDeclH98 pass , con_name :: Located (IdP pass) , con_forall :: Located Bool -- ^ True <=> explicit user-written forall -- e.g. data T a = forall b. MkT b (b->a) -- con_ex_tvs = {b} -- False => con_ex_tvs is empty , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } | XConDecl (XXConDecl pass) type instance XConDeclGADT (GhcPass _) = NoExtField type instance XConDeclH98 (GhcPass _) = NoExtField type instance XXConDecl (GhcPass _) = NoExtCon {- Note [GADT abstract syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There's a wrinkle in ConDeclGADT * For record syntax, it's all uniform. Given: data T a where K :: forall a. Ord a => { x :: [a], ... } -> T a we make the a ConDeclGADT for K with con_qvars = {a} con_mb_cxt = Just [Ord a] con_args = RecCon con_res_ty = T a We need the RecCon before the reanmer, so we can find the record field binders in GHC.Hs.Utils.hsConDeclsBinders. * However for a GADT constr declaration which is not a record, it can be hard parse until we know operator fixities. Consider for example C :: a :*: b -> a :*: b -> a :+: b Initially this type will parse as a :*: (b -> (a :*: (b -> (a :+: b)))) so it's hard to split up the arguments until we've done the precedence resolution (in the renamer). So: - In the parser (RdrHsSyn.mkGadtDecl), we put the whole constr type into the res_ty for a ConDeclGADT for now, and use PrefixCon [] con_args = PrefixCon [] con_res_ty = a :*: (b -> (a :*: (b -> (a :+: b)))) - In the renamer (RnSource.rnConDecl), we unravel it afer operator fixities are sorted. So we generate. So we end up with con_args = PrefixCon [ a :*: b, a :*: b ] con_res_ty = a :+: b -} -- | Haskell data Constructor Declaration Details type HsConDeclDetails pass = HsConDetails (LBangType pass) (Located [LConDeclField pass]) getConNames :: ConDecl (GhcPass p) -> [Located (IdP (GhcPass p))] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names getConNames (XConDecl nec) = noExtCon nec getConArgs :: ConDecl pass -> HsConDeclDetails pass getConArgs d = con_args d hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass] hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass] hsConDeclTheta Nothing = [] hsConDeclTheta (Just (L _ theta)) = theta pp_data_defn :: (OutputableBndrId p) => (LHsContext (GhcPass p) -> SDoc) -- Printing the header -> HsDataDefn (GhcPass p) -> SDoc pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context , dd_cType = mb_ct , dd_kindSig = mb_sig , dd_cons = condecls, dd_derivs = derivings }) | null condecls = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig <+> pp_derivings derivings | otherwise = hang (ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig) 2 (pp_condecls condecls $$ pp_derivings derivings) where pp_ct = case mb_ct of Nothing -> empty Just ct -> ppr ct pp_sig = case mb_sig of Nothing -> empty Just kind -> dcolon <+> ppr kind pp_derivings (L _ ds) = vcat (map ppr ds) pp_data_defn _ (XHsDataDefn x) = ppr x instance OutputableBndrId p => Outputable (HsDataDefn (GhcPass p)) where ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d instance OutputableBndrId p => Outputable (StandaloneKindSig (GhcPass p)) where ppr (StandaloneKindSig _ v ki) = text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki ppr (XStandaloneKindSig nec) = noExtCon nec instance Outputable NewOrData where ppr NewType = text "newtype" ppr DataType = text "data" pp_condecls :: (OutputableBndrId p) => [LConDecl (GhcPass p)] -> SDoc pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax = hang (text "where") 2 (vcat (map ppr cs)) pp_condecls cs -- In H98 syntax = equals <+> sep (punctuate (text " |") (map ppr cs)) instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where ppr = pprConDecl pprConDecl :: (OutputableBndrId p) => ConDecl (GhcPass p) -> SDoc pprConDecl (ConDeclH98 { con_name = L _ con , con_ex_tvs = ex_tvs , con_mb_cxt = mcxt , con_args = args , con_doc = doc }) = sep [ppr_mbDoc doc, pprHsForAll ForallInvis ex_tvs cxt, ppr_details args] where ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2] ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con : map (pprHsType . unLoc) tys) ppr_details (RecCon fields) = pprPrefixOcc con <+> pprConDeclFields (unLoc fields) cxt = fromMaybe noLHsContext mcxt pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty, con_doc = doc }) = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon <+> (sep [pprHsForAll ForallInvis (hsq_explicit qvars) cxt, ppr_arrow_chain (get_args args ++ [ppr res_ty]) ]) where get_args (PrefixCon args) = map ppr args get_args (RecCon fields) = [pprConDeclFields (unLoc fields)] get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons) cxt = fromMaybe noLHsContext mcxt ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as) ppr_arrow_chain [] = empty pprConDecl (XConDecl x) = ppr x ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) {- ************************************************************************ * * Instance declarations * * ************************************************************************ Note [Type family instance declarations in HsSyn] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The data type FamEqn represents one equation of a type family instance. Aside from the pass, it is also parameterised over another field, feqn_rhs. feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType (for type family instances). Type family instances also include associated type family default equations. That is because a default for a type family looks like this: class C a where type family F a b :: Type type F c d = (c,d) -- Default instance The default declaration is really just a `type instance` declaration, but one with particularly simple patterns: they must all be distinct type variables. That's because we will instantiate it (in an instance declaration for `C`) if we don't give an explicit instance for `F`. Note that the names of the variables don't need to match those of the class: it really is like a free-standing `type instance` declaration. -} ----------------- Type synonym family instances ------------- -- | Located Type Family Instance Equation type LTyFamInstEqn pass = Located (TyFamInstEqn pass) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' -- when in a list -- For details on above see note [Api annotations] in ApiAnnotation -- | Haskell Type Patterns type HsTyPats pass = [LHsTypeArg pass] {- Note [Family instance declaration binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The feqn_pats field of FamEqn (family instance equation) stores the LHS type (and kind) patterns. Any type (and kind) variables contained in these type patterns are bound in the hsib_vars field of the HsImplicitBndrs in FamInstEqn depending on whether or not an explicit forall is present. In the case of an explicit forall, the hsib_vars only includes kind variables not bound in the forall. Otherwise, all type (and kind) variables are bound in the hsib_vars. In the latter case, note that in particular * The hsib_vars *includes* any anonymous wildcards. For example type instance F a _ = a The hsib_vars will be {a, _}. Remember that each separate wildcard '_' gets its own unique. In this context wildcards behave just like an ordinary type variable, only anonymous. * The hsib_vars *includes* type variables that are already in scope Eg class C s t where type F t p :: * instance C w (a,b) where type F (a,b) x = x->a The hsib_vars of the F decl are {a,b,x}, even though the F decl is nested inside the 'instance' decl. However after the renamer, the uniques will match up: instance C w7 (a8,b9) where type F (a8,b9) x10 = x10->a8 so that we can compare the type pattern in the 'instance' decl and in the associated 'type' decl c.f. Note [TyVar binders for associated decls] -} -- | Type Family Instance Equation type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) -- | Type family default declarations. -- A convenient synonym for 'TyFamInstDecl'. -- See @Note [Type family instance declarations in HsSyn]@. type TyFamDefltDecl = TyFamInstDecl -- | Located type family default declarations. type LTyFamDefltDecl pass = Located (TyFamDefltDecl pass) -- | Located Type Family Instance Declaration type LTyFamInstDecl pass = Located (TyFamInstDecl pass) -- | Type Family Instance Declaration newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnInstance', -- For details on above see note [Api annotations] in ApiAnnotation ----------------- Data family instances ------------- -- | Located Data Family Instance Declaration type LDataFamInstDecl pass = Located (DataFamInstDecl pass) -- | Data Family Instance Declaration newtype DataFamInstDecl pass = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance', -- 'ApiAnnotation.AnnDcolon' -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation ----------------- Family instances (common types) ------------- -- | Located Family Instance Equation type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs) -- | Family Instance Equation type FamInstEqn pass rhs = HsImplicitBndrs pass (FamEqn pass rhs) -- ^ Here, the @pats@ are type patterns (with kind and type bndrs). -- See Note [Family instance declaration binders] -- | Family Equation -- -- One equation in a type family instance declaration, data family instance -- declaration, or type family default. -- See Note [Type family instance declarations in HsSyn] -- See Note [Family instance declaration binders] data FamEqn pass rhs = FamEqn { feqn_ext :: XCFamEqn pass rhs , feqn_tycon :: Located (IdP pass) , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars , feqn_pats :: HsTyPats pass , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration , feqn_rhs :: rhs } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' | XFamEqn (XXFamEqn pass rhs) -- For details on above see note [Api annotations] in ApiAnnotation type instance XCFamEqn (GhcPass _) r = NoExtField type instance XXFamEqn (GhcPass _) r = NoExtCon ----------------- Class instances ------------- -- | Located Class Instance Declaration type LClsInstDecl pass = Located (ClsInstDecl pass) -- | Class Instance Declaration data ClsInstDecl pass = ClsInstDecl { cid_ext :: XCClsInstDecl pass , cid_poly_ty :: LHsSigType pass -- Context => Class Instance-type -- Using a polytype means that the renamer conveniently -- figures out the quantified type variables for us. , cid_binds :: LHsBinds pass -- Class methods , cid_sigs :: [LSig pass] -- User-supplied pragmatic info , cid_tyfam_insts :: [LTyFamInstDecl pass] -- Type family instances , cid_datafam_insts :: [LDataFamInstDecl pass] -- Data family instances , cid_overlap_mode :: Maybe (Located OverlapMode) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose', -- For details on above see note [Api annotations] in ApiAnnotation } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInstance', -- 'ApiAnnotation.AnnWhere', -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', -- For details on above see note [Api annotations] in ApiAnnotation | XClsInstDecl (XXClsInstDecl pass) type instance XCClsInstDecl (GhcPass _) = NoExtField type instance XXClsInstDecl (GhcPass _) = NoExtCon ----------------- Instances of all kinds ------------- -- | Located Instance Declaration type LInstDecl pass = Located (InstDecl pass) -- | Instance Declaration data InstDecl pass -- Both class and family instances = ClsInstD { cid_d_ext :: XClsInstD pass , cid_inst :: ClsInstDecl pass } | DataFamInstD -- data family instance { dfid_ext :: XDataFamInstD pass , dfid_inst :: DataFamInstDecl pass } | TyFamInstD -- type family instance { tfid_ext :: XTyFamInstD pass , tfid_inst :: TyFamInstDecl pass } | XInstDecl (XXInstDecl pass) type instance XClsInstD (GhcPass _) = NoExtField type instance XDataFamInstD (GhcPass _) = NoExtField type instance XTyFamInstD (GhcPass _) = NoExtField type instance XXInstDecl (GhcPass _) = NoExtCon instance OutputableBndrId p => Outputable (TyFamInstDecl (GhcPass p)) where ppr = pprTyFamInstDecl TopLevel pprTyFamInstDecl :: (OutputableBndrId p) => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword TopLevel = text "instance" ppr_instance_keyword NotTopLevel = empty pprTyFamDefltDecl :: (OutputableBndrId p) => TyFamDefltDecl (GhcPass p) -> SDoc pprTyFamDefltDecl = pprTyFamInstDecl NotTopLevel ppr_fam_inst_eqn :: (OutputableBndrId p) => TyFamInstEqn (GhcPass p) -> SDoc ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon , feqn_bndrs = bndrs , feqn_pats = pats , feqn_fixity = fixity , feqn_rhs = rhs }}) = pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+> equals <+> ppr rhs ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x instance OutputableBndrId p => Outputable (DataFamInstDecl (GhcPass p)) where ppr = pprDataFamInstDecl TopLevel pprDataFamInstDecl :: (OutputableBndrId p) => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon , feqn_bndrs = bndrs , feqn_pats = pats , feqn_fixity = fixity , feqn_rhs = defn }}}) = pp_data_defn pp_hdr defn where pp_hdr ctxt = ppr_instance_keyword top_lvl <+> pprHsFamInstLHS tycon bndrs pats fixity ctxt -- pp_data_defn pretty-prints the kind sig. See #14817. pprDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn x))) = ppr x pprDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs x)) = ppr x pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}}) = ppr nd pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = XHsDataDefn x}}}) = ppr x pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x))) = ppr x pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x)) = ppr x pprHsFamInstLHS :: (OutputableBndrId p) => IdP (GhcPass p) -> Maybe [LHsTyVarBndr (GhcPass p)] -> HsTyPats (GhcPass p) -> LexicalFixity -> LHsContext (GhcPass p) -> SDoc pprHsFamInstLHS thing bndrs typats fixity mb_ctxt = hsep [ pprHsExplicitForAll ForallInvis bndrs , pprLHsContext mb_ctxt , pp_pats typats ] where pp_pats (patl:patr:pats) | Infix <- fixity = let pp_op_app = hsep [ ppr patl, pprInfixOcc thing, ppr patr ] in case pats of [] -> pp_op_app _ -> hsep (parens pp_op_app : map ppr pats) pp_pats pats = hsep [ pprPrefixOcc thing , hsep (map ppr pats)] instance OutputableBndrId p => Outputable (ClsInstDecl (GhcPass p)) where ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats , cid_overlap_mode = mbOverlap , cid_datafam_insts = adts }) | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part = top_matter | otherwise -- Laid out = vcat [ top_matter <+> text "where" , nest 2 $ pprDeclList $ map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++ map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++ pprLHsBindsForUser binds sigs ] where top_matter = text "instance" <+> ppOverlapPragma mbOverlap <+> ppr inst_ty ppr (XClsInstDecl x) = ppr x ppDerivStrategy :: OutputableBndrId p => Maybe (LDerivStrategy (GhcPass p)) -> SDoc ppDerivStrategy mb = case mb of Nothing -> empty Just (L _ ds) -> ppr ds ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc ppOverlapPragma mb = case mb of Nothing -> empty Just (L _ (NoOverlap s)) -> maybe_stext s "{-# NO_OVERLAP #-}" Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}" Just (L _ (Overlapping s)) -> maybe_stext s "{-# OVERLAPPING #-}" Just (L _ (Overlaps s)) -> maybe_stext s "{-# OVERLAPS #-}" Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}" where maybe_stext NoSourceText alt = text alt maybe_stext (SourceText src) _ = text src <+> text "#-}" instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where ppr (ClsInstD { cid_inst = decl }) = ppr decl ppr (TyFamInstD { tfid_inst = decl }) = ppr decl ppr (DataFamInstD { dfid_inst = decl }) = ppr decl ppr (XInstDecl x) = ppr x -- Extract the declarations of associated data types from an instance instDeclDataFamInsts :: [LInstDecl (GhcPass p)] -> [DataFamInstDecl (GhcPass p)] instDeclDataFamInsts inst_decls = concatMap do_one inst_decls where do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } })) = map unLoc fam_insts do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] do_one (L _ (TyFamInstD {})) = [] do_one (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec do_one (L _ (XInstDecl nec)) = noExtCon nec {- ************************************************************************ * * \subsection[DerivDecl]{A stand-alone instance deriving declaration} * * ************************************************************************ -} -- | Located stand-alone 'deriving instance' declaration type LDerivDecl pass = Located (DerivDecl pass) -- | Stand-alone 'deriving instance' declaration data DerivDecl pass = DerivDecl { deriv_ext :: XCDerivDecl pass , deriv_type :: LHsSigWcType pass -- ^ The instance type to derive. -- -- It uses an 'LHsSigWcType' because the context is allowed to be a -- single wildcard: -- -- > deriving instance _ => Eq (Foo a) -- -- Which signifies that the context should be inferred. -- See Note [Inferring the instance context] in TcDerivInfer. , deriv_strategy :: Maybe (LDerivStrategy pass) , deriv_overlap_mode :: Maybe (Located OverlapMode) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving', -- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock', -- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype', -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation } | XDerivDecl (XXDerivDecl pass) type instance XCDerivDecl (GhcPass _) = NoExtField type instance XXDerivDecl (GhcPass _) = NoExtCon instance OutputableBndrId p => Outputable (DerivDecl (GhcPass p)) where ppr (DerivDecl { deriv_type = ty , deriv_strategy = ds , deriv_overlap_mode = o }) = hsep [ text "deriving" , ppDerivStrategy ds , text "instance" , ppOverlapPragma o , ppr ty ] ppr (XDerivDecl x) = ppr x {- ************************************************************************ * * Deriving strategies * * ************************************************************************ -} -- | A 'Located' 'DerivStrategy'. type LDerivStrategy pass = Located (DerivStrategy pass) -- | Which technique the user explicitly requested when deriving an instance. data DerivStrategy pass -- See Note [Deriving strategies] in TcDeriv = StockStrategy -- ^ GHC's \"standard\" strategy, which is to implement a -- custom instance for the data type. This only works -- for certain types that GHC knows about (e.g., 'Eq', -- 'Show', 'Functor' when @-XDeriveFunctor@ is enabled, -- etc.) | AnyclassStrategy -- ^ @-XDeriveAnyClass@ | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ | ViaStrategy (XViaStrategy pass) -- ^ @-XDerivingVia@ type instance XViaStrategy GhcPs = LHsSigType GhcPs type instance XViaStrategy GhcRn = LHsSigType GhcRn type instance XViaStrategy GhcTc = Type instance OutputableBndrId p => Outputable (DerivStrategy (GhcPass p)) where ppr StockStrategy = text "stock" ppr AnyclassStrategy = text "anyclass" ppr NewtypeStrategy = text "newtype" ppr (ViaStrategy ty) = text "via" <+> ppr ty -- | A short description of a @DerivStrategy'@. derivStrategyName :: DerivStrategy a -> SDoc derivStrategyName = text . go where go StockStrategy = "stock" go AnyclassStrategy = "anyclass" go NewtypeStrategy = "newtype" go (ViaStrategy {}) = "via" -- | Eliminate a 'DerivStrategy'. foldDerivStrategy :: (p ~ GhcPass pass) => r -> (XViaStrategy p -> r) -> DerivStrategy p -> r foldDerivStrategy other _ StockStrategy = other foldDerivStrategy other _ AnyclassStrategy = other foldDerivStrategy other _ NewtypeStrategy = other foldDerivStrategy _ via (ViaStrategy t) = via t -- | Map over the @via@ type if dealing with 'ViaStrategy'. Otherwise, -- return the 'DerivStrategy' unchanged. mapDerivStrategy :: (p ~ GhcPass pass) => (XViaStrategy p -> XViaStrategy p) -> DerivStrategy p -> DerivStrategy p mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds {- ************************************************************************ * * \subsection[DefaultDecl]{A @default@ declaration} * * ************************************************************************ There can only be one default declaration per module, but it is hard for the parser to check that; we pass them all through in the abstract syntax, and that restriction must be checked in the front end. -} -- | Located Default Declaration type LDefaultDecl pass = Located (DefaultDecl pass) -- | Default Declaration data DefaultDecl pass = DefaultDecl (XCDefaultDecl pass) [LHsType pass] -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault', -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation | XDefaultDecl (XXDefaultDecl pass) type instance XCDefaultDecl (GhcPass _) = NoExtField type instance XXDefaultDecl (GhcPass _) = NoExtCon instance OutputableBndrId p => Outputable (DefaultDecl (GhcPass p)) where ppr (DefaultDecl _ tys) = text "default" <+> parens (interpp'SP tys) ppr (XDefaultDecl x) = ppr x {- ************************************************************************ * * \subsection{Foreign function interface declaration} * * ************************************************************************ -} -- foreign declarations are distinguished as to whether they define or use a -- Haskell name -- -- * the Boolean value indicates whether the pre-standard deprecated syntax -- has been used -- | Located Foreign Declaration type LForeignDecl pass = Located (ForeignDecl pass) -- | Foreign Declaration data ForeignDecl pass = ForeignImport { fd_i_ext :: XForeignImport pass -- Post typechecker, rep_ty ~ sig_ty , fd_name :: Located (IdP pass) -- defines this name , fd_sig_ty :: LHsSigType pass -- sig_ty , fd_fi :: ForeignImport } | ForeignExport { fd_e_ext :: XForeignExport pass -- Post typechecker, rep_ty ~ sig_ty , fd_name :: Located (IdP pass) -- uses this name , fd_sig_ty :: LHsSigType pass -- sig_ty , fd_fe :: ForeignExport } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign', -- 'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport', -- 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation | XForeignDecl (XXForeignDecl pass) {- In both ForeignImport and ForeignExport: sig_ty is the type given in the Haskell code rep_ty is the representation for this type, i.e. with newtypes coerced away and type functions evaluated. Thus if the declaration is valid, then rep_ty will only use types such as Int and IO that we know how to make foreign calls with. -} type instance XForeignImport GhcPs = NoExtField type instance XForeignImport GhcRn = NoExtField type instance XForeignImport GhcTc = Coercion type instance XForeignExport GhcPs = NoExtField type instance XForeignExport GhcRn = NoExtField type instance XForeignExport GhcTc = Coercion type instance XXForeignDecl (GhcPass _) = NoExtCon -- Specification Of an imported external entity in dependence on the calling -- convention -- data ForeignImport = -- import of a C entity -- -- * the two strings specifying a header file or library -- may be empty, which indicates the absence of a -- header or object specification (both are not used -- in the case of `CWrapper' and when `CFunction' -- has a dynamic target) -- -- * the calling convention is irrelevant for code -- generation in the case of `CLabel', but is needed -- for pretty printing -- -- * `Safety' is irrelevant for `CLabel' and `CWrapper' -- CImport (Located CCallConv) -- ccall or stdcall (Located Safety) -- interruptible, safe or unsafe (Maybe Header) -- name of C header CImportSpec -- details of the C entity (Located SourceText) -- original source text for -- the C entity deriving Data -- details of an external C entity -- data CImportSpec = CLabel CLabelString -- import address of a C label | CFunction CCallTarget -- static or dynamic function | CWrapper -- wrapper to expose closures -- (former f.e.d.) deriving Data -- specification of an externally exported entity in dependence on the calling -- convention -- data ForeignExport = CExport (Located CExportSpec) -- contains the calling -- convention (Located SourceText) -- original source text for -- the C entity deriving Data -- pretty printing of foreign declarations -- instance OutputableBndrId p => Outputable (ForeignDecl (GhcPass p)) where ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) = hang (text "foreign import" <+> ppr fimport <+> ppr n) 2 (dcolon <+> ppr ty) ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) = hang (text "foreign export" <+> ppr fexport <+> ppr n) 2 (dcolon <+> ppr ty) ppr (XForeignDecl x) = ppr x instance Outputable ForeignImport where ppr (CImport cconv safety mHeader spec (L _ srcText)) = ppr cconv <+> ppr safety <+> pprWithSourceText srcText (pprCEntity spec "") where pp_hdr = case mHeader of Nothing -> empty Just (Header _ header) -> ftext header pprCEntity (CLabel lbl) _ = doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src = if dqNeeded then doubleQuotes ce else empty where dqNeeded = (take 6 src == "static") || isJust mHeader || not isFun || st /= NoSourceText ce = -- We may need to drop leading spaces first (if take 6 src == "static" then text "static" else empty) <+> pp_hdr <+> (if isFun then empty else text "value") <+> (pprWithSourceText st empty) pprCEntity (CFunction DynamicTarget) _ = doubleQuotes $ text "dynamic" pprCEntity CWrapper _ = doubleQuotes $ text "wrapper" instance Outputable ForeignExport where ppr (CExport (L _ (CExportStatic _ lbl cconv)) _) = ppr cconv <+> char '"' <> ppr lbl <> char '"' {- ************************************************************************ * * \subsection{Transformation rules} * * ************************************************************************ -} -- | Located Rule Declarations type LRuleDecls pass = Located (RuleDecls pass) -- Note [Pragma source text] in BasicTypes -- | Rule Declarations data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass , rds_src :: SourceText , rds_rules :: [LRuleDecl pass] } | XRuleDecls (XXRuleDecls pass) type instance XCRuleDecls (GhcPass _) = NoExtField type instance XXRuleDecls (GhcPass _) = NoExtCon -- | Located Rule Declaration type LRuleDecl pass = Located (RuleDecl pass) -- | Rule Declaration data RuleDecl pass = HsRule -- Source rule { rd_ext :: XHsRule pass -- ^ After renamer, free-vars from the LHS and RHS , rd_name :: Located (SourceText,RuleName) -- ^ Note [Pragma source text] in BasicTypes , rd_act :: Activation , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)] -- ^ Forall'd type vars , rd_tmvs :: [LRuleBndr pass] -- ^ Forall'd term vars, before typechecking; after typechecking -- this includes all forall'd vars , rd_lhs :: Located (HsExpr pass) , rd_rhs :: Located (HsExpr pass) } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde', -- 'ApiAnnotation.AnnVal', -- 'ApiAnnotation.AnnClose', -- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot', -- 'ApiAnnotation.AnnEqual', | XRuleDecl (XXRuleDecl pass) data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS deriving Data type instance XHsRule GhcPs = NoExtField type instance XHsRule GhcRn = HsRuleRn type instance XHsRule GhcTc = HsRuleRn type instance XXRuleDecl (GhcPass _) = NoExtCon flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass] flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls -- | Located Rule Binder type LRuleBndr pass = Located (RuleBndr pass) -- | Rule Binder data RuleBndr pass = RuleBndr (XCRuleBndr pass) (Located (IdP pass)) | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (LHsSigWcType pass) | XRuleBndr (XXRuleBndr pass) -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation type instance XCRuleBndr (GhcPass _) = NoExtField type instance XRuleBndrSig (GhcPass _) = NoExtField type instance XXRuleBndr (GhcPass _) = NoExtCon collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] pprFullRuleName :: Located (SourceText, RuleName) -> SDoc pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where ppr (HsRules { rds_src = st , rds_rules = rules }) = pprWithSourceText st (text "{-# RULES") <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" ppr (XRuleDecls x) = ppr x instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where ppr (HsRule { rd_name = name , rd_act = act , rd_tyvs = tys , rd_tmvs = tms , rd_lhs = lhs , rd_rhs = rhs }) = sep [pprFullRuleName name <+> ppr act, nest 4 (pp_forall_ty tys <+> pp_forall_tm tys <+> pprExpr (unLoc lhs)), nest 6 (equals <+> pprExpr (unLoc rhs)) ] where pp_forall_ty Nothing = empty pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot pp_forall_tm Nothing | null tms = empty pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot ppr (XRuleDecl x) = ppr x instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where ppr (RuleBndr _ name) = ppr name ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty) ppr (XRuleBndr x) = ppr x {- ************************************************************************ * * \subsection[DocDecl]{Document comments} * * ************************************************************************ -} -- | Located Documentation comment Declaration type LDocDecl = Located (DocDecl) -- | Documentation comment Declaration data DocDecl = DocCommentNext HsDocString | DocCommentPrev HsDocString | DocCommentNamed String HsDocString | DocGroup Int HsDocString deriving Data -- Okay, I need to reconstruct the document comments, but for now: instance Outputable DocDecl where ppr _ = text "" docDeclDoc :: DocDecl -> HsDocString docDeclDoc (DocCommentNext d) = d docDeclDoc (DocCommentPrev d) = d docDeclDoc (DocCommentNamed _ d) = d docDeclDoc (DocGroup _ d) = d {- ************************************************************************ * * \subsection[DeprecDecl]{Deprecations} * * ************************************************************************ We use exported entities for things to deprecate. -} -- | Located Warning Declarations type LWarnDecls pass = Located (WarnDecls pass) -- Note [Pragma source text] in BasicTypes -- | Warning pragma Declarations data WarnDecls pass = Warnings { wd_ext :: XWarnings pass , wd_src :: SourceText , wd_warnings :: [LWarnDecl pass] } | XWarnDecls (XXWarnDecls pass) type instance XWarnings (GhcPass _) = NoExtField type instance XXWarnDecls (GhcPass _) = NoExtCon -- | Located Warning pragma Declaration type LWarnDecl pass = Located (WarnDecl pass) -- | Warning pragma Declaration data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt | XWarnDecl (XXWarnDecl pass) type instance XWarning (GhcPass _) = NoExtField type instance XXWarnDecl (GhcPass _) = NoExtCon instance OutputableBndr (IdP (GhcPass p)) => Outputable (WarnDecls (GhcPass p)) where ppr (Warnings _ (SourceText src) decls) = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}" ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls" ppr (XWarnDecls x) = ppr x instance OutputableBndr (IdP (GhcPass p)) => Outputable (WarnDecl (GhcPass p)) where ppr (Warning _ thing txt) = hsep ( punctuate comma (map ppr thing)) <+> ppr txt ppr (XWarnDecl x) = ppr x {- ************************************************************************ * * \subsection[AnnDecl]{Annotations} * * ************************************************************************ -} -- | Located Annotation Declaration type LAnnDecl pass = Located (AnnDecl pass) -- | Annotation Declaration data AnnDecl pass = HsAnnotation (XHsAnnotation pass) SourceText -- Note [Pragma source text] in BasicTypes (AnnProvenance (IdP pass)) (Located (HsExpr pass)) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnType' -- 'ApiAnnotation.AnnModule' -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation | XAnnDecl (XXAnnDecl pass) type instance XHsAnnotation (GhcPass _) = NoExtField type instance XXAnnDecl (GhcPass _) = NoExtCon instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where ppr (HsAnnotation _ _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] ppr (XAnnDecl x) = ppr x -- | Annotation Provenance data AnnProvenance name = ValueAnnProvenance (Located name) | TypeAnnProvenance (Located name) | ModuleAnnProvenance deriving instance Functor AnnProvenance deriving instance Foldable AnnProvenance deriving instance Traversable AnnProvenance deriving instance (Data pass) => Data (AnnProvenance pass) annProvenanceName_maybe :: AnnProvenance name -> Maybe name annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name annProvenanceName_maybe (TypeAnnProvenance (L _ name)) = Just name annProvenanceName_maybe ModuleAnnProvenance = Nothing pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc pprAnnProvenance ModuleAnnProvenance = text "ANN module" pprAnnProvenance (ValueAnnProvenance (L _ name)) = text "ANN" <+> ppr name pprAnnProvenance (TypeAnnProvenance (L _ name)) = text "ANN type" <+> ppr name {- ************************************************************************ * * \subsection[RoleAnnot]{Role annotations} * * ************************************************************************ -} -- | Located Role Annotation Declaration type LRoleAnnotDecl pass = Located (RoleAnnotDecl pass) -- See #8185 for more info about why role annotations are -- top-level declarations -- | Role Annotation Declaration data RoleAnnotDecl pass = RoleAnnotDecl (XCRoleAnnotDecl pass) (Located (IdP pass)) -- type constructor [Located (Maybe Role)] -- optional annotations -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnRole' -- For details on above see note [Api annotations] in ApiAnnotation | XRoleAnnotDecl (XXRoleAnnotDecl pass) type instance XCRoleAnnotDecl (GhcPass _) = NoExtField type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon instance OutputableBndr (IdP (GhcPass p)) => Outputable (RoleAnnotDecl (GhcPass p)) where ppr (RoleAnnotDecl _ ltycon roles) = text "type role" <+> pprPrefixOcc (unLoc ltycon) <+> hsep (map (pp_role . unLoc) roles) where pp_role Nothing = underscore pp_role (Just r) = ppr r ppr (XRoleAnnotDecl x) = ppr x roleAnnotDeclName :: RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p) roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name roleAnnotDeclName (XRoleAnnotDecl nec) = noExtCon nec ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/Doc.hs0000644000000000000000000001055613713635744017343 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Hs.Doc ( HsDocString , LHsDocString , mkHsDocString , mkHsDocStringUtf8ByteString , unpackHDS , hsDocStringToByteString , ppr_mbDoc , appendDocs , concatDocs , DeclDocMap(..) , emptyDeclDocMap , ArgDocMap(..) , emptyArgDocMap ) where #include "GhclibHsVersions.h" import GhcPrelude import Binary import Encoding import FastFunctions import Name import Outputable import SrcLoc import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Internal as BS import Data.Data import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import Foreign -- | Haskell Documentation String -- -- Internally this is a UTF8-Encoded 'ByteString'. newtype HsDocString = HsDocString ByteString -- There are at least two plausible Semigroup instances for this type: -- -- 1. Simple string concatenation. -- 2. Concatenation as documentation paragraphs with newlines in between. -- -- To avoid confusion, we pass on defining an instance at all. deriving (Eq, Show, Data) -- | Located Haskell Documentation String type LHsDocString = Located HsDocString instance Binary HsDocString where put_ bh (HsDocString bs) = put_ bh bs get bh = HsDocString <$> get bh instance Outputable HsDocString where ppr = doubleQuotes . text . unpackHDS mkHsDocString :: String -> HsDocString mkHsDocString s = inlinePerformIO $ do let len = utf8EncodedLength s buf <- mallocForeignPtrBytes len withForeignPtr buf $ \ptr -> do utf8EncodeString ptr s pure (HsDocString (BS.fromForeignPtr buf 0 len)) -- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'. mkHsDocStringUtf8ByteString :: ByteString -> HsDocString mkHsDocStringUtf8ByteString = HsDocString unpackHDS :: HsDocString -> String unpackHDS = utf8DecodeByteString . hsDocStringToByteString -- | Return the contents of a 'HsDocString' as a UTF8-encoded 'ByteString'. hsDocStringToByteString :: HsDocString -> ByteString hsDocStringToByteString (HsDocString bs) = bs ppr_mbDoc :: Maybe LHsDocString -> SDoc ppr_mbDoc (Just doc) = ppr doc ppr_mbDoc Nothing = empty -- | Join two docstrings. -- -- Non-empty docstrings are joined with two newlines in between, -- resulting in separate paragraphs. appendDocs :: HsDocString -> HsDocString -> HsDocString appendDocs x y = fromMaybe (HsDocString BS.empty) (concatDocs [x, y]) -- | Concat docstrings with two newlines in between. -- -- Empty docstrings are skipped. -- -- If all inputs are empty, 'Nothing' is returned. concatDocs :: [HsDocString] -> Maybe HsDocString concatDocs xs = if BS.null b then Nothing else Just (HsDocString b) where b = BS.intercalate (C8.pack "\n\n") . filter (not . BS.null) . map hsDocStringToByteString $ xs -- | Docs for declarations: functions, data types, instances, methods etc. newtype DeclDocMap = DeclDocMap (Map Name HsDocString) instance Binary DeclDocMap where put_ bh (DeclDocMap m) = put_ bh (Map.toList m) -- We can't rely on a deterministic ordering of the `Name`s here. -- See the comments on `Name`'s `Ord` instance for context. get bh = DeclDocMap . Map.fromList <$> get bh instance Outputable DeclDocMap where ppr (DeclDocMap m) = vcat (map pprPair (Map.toAscList m)) where pprPair (name, doc) = ppr name Outputable.<> colon $$ nest 2 (ppr doc) emptyDeclDocMap :: DeclDocMap emptyDeclDocMap = DeclDocMap Map.empty -- | Docs for arguments. E.g. function arguments, method arguments. newtype ArgDocMap = ArgDocMap (Map Name (Map Int HsDocString)) instance Binary ArgDocMap where put_ bh (ArgDocMap m) = put_ bh (Map.toList (Map.toAscList <$> m)) -- We can't rely on a deterministic ordering of the `Name`s here. -- See the comments on `Name`'s `Ord` instance for context. get bh = ArgDocMap . fmap Map.fromDistinctAscList . Map.fromList <$> get bh instance Outputable ArgDocMap where ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m)) where pprPair (name, int_map) = ppr name Outputable.<> colon $$ nest 2 (pprIntMap int_map) pprIntMap im = vcat (map pprIPair (Map.toAscList im)) pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc) emptyArgDocMap :: ArgDocMap emptyArgDocMap = ArgDocMap Map.empty ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/Dump.hs0000644000000000000000000001676613713635744017554 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Contains a debug function to dump parts of the GHC.Hs AST. It uses a syb -- traversal which falls back to displaying based on the constructor name, so -- can be used to dump anything having a @Data.Data@ instance. module GHC.Hs.Dump ( -- * Dumping ASTs showAstData, BlankSrcSpan(..), ) where import GhcPrelude import Data.Data hiding (Fixity) import Bag import BasicTypes import FastString import NameSet import Name import DataCon import SrcLoc import GHC.Hs 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) ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/Expr.hs0000644000000000000000000034152113713635744017553 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} {-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -- | Abstract Haskell syntax for expressions. module GHC.Hs.Expr where #include "GhclibHsVersions.h" -- friends: import GhcPrelude import GHC.Hs.Decls import GHC.Hs.Pat import GHC.Hs.Lit import GHC.Hs.PlaceHolder ( NameOrRdrName ) import GHC.Hs.Extension import GHC.Hs.Types import GHC.Hs.Binds -- others: import TcEvidence import CoreSyn import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) ) import Name import NameSet import RdrName ( GlobalRdrEnv ) import BasicTypes import ConLike import SrcLoc import Util import Outputable import FastString import Type import TysWiredIn (mkTupleStr) import TcType (TcType) import {-# SOURCE #-} TcRnTypes (TcLclEnv) -- libraries: import Data.Data hiding (Fixity(..)) import qualified Data.Data as Data (Fixity(..)) import Data.Maybe (isNothing) import GHCi.RemoteTypes ( ForeignRef ) import qualified Language.Haskell.TH as TH (Q) {- ************************************************************************ * * \subsection{Expressions proper} * * ************************************************************************ -} -- * Expressions proper -- | Located Haskell Expression type LHsExpr p = Located (HsExpr p) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when -- in a list -- For details on above see note [Api annotations] in ApiAnnotation ------------------------- -- | Post-Type checking Expression -- -- PostTcExpr is an evidence expression attached to the syntax tree by the -- type checker (c.f. postTcType). type PostTcExpr = HsExpr GhcTc -- | Post-Type checking Table -- -- We use a PostTcTable where there are a bunch of pieces of evidence, more -- than is convenient to keep individually. type PostTcTable = [(Name, PostTcExpr)] ------------------------- -- | Syntax Expression -- -- SyntaxExpr is like 'PostTcExpr', but it's filled in a little earlier, -- by the renamer. It's used for rebindable syntax. -- -- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for -- @(>>=)@, and then instantiated by the type checker with its type args -- etc -- -- This should desugar to -- -- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0) -- > (syn_arg_wraps[1] arg1) ... -- -- where the actual arguments come from elsewhere in the AST. -- This could be defined using @GhcPass p@ and such, but it's -- harder to get it all to work out that way. ('noSyntaxExpr' is hard to -- write, for example.) data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p , syn_arg_wraps :: [HsWrapper] , syn_res_wrap :: HsWrapper } -- | This is used for rebindable-syntax pieces that are too polymorphic -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) noExpr :: HsExpr (GhcPass p) noExpr = HsLit noExtField (HsString (SourceText "noExpr") (fsLit "noExpr")) noSyntaxExpr :: SyntaxExpr (GhcPass p) -- Before renaming, and sometimes after, -- (if the syntax slot makes no sense) noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExtField (HsString NoSourceText (fsLit "noSyntaxExpr")) , syn_arg_wraps = [] , syn_res_wrap = WpHole } -- | Make a 'SyntaxExpr (HsExpr _)', missing its HsWrappers. mkSyntaxExpr :: HsExpr (GhcPass p) -> SyntaxExpr (GhcPass p) mkSyntaxExpr expr = SyntaxExpr { syn_expr = expr , syn_arg_wraps = [] , syn_res_wrap = WpHole } -- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the -- renamer), missing its HsWrappers. mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn mkRnSyntaxExpr name = mkSyntaxExpr $ HsVar noExtField $ noLoc name -- don't care about filling in syn_arg_wraps because we're clearly -- not past the typechecker instance OutputableBndrId p => Outputable (SyntaxExpr (GhcPass p)) where ppr (SyntaxExpr { syn_expr = expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) = sdocWithDynFlags $ \ dflags -> getPprStyle $ \s -> if debugStyle s || gopt Opt_PrintExplicitCoercions dflags then ppr expr <> braces (pprWithCommas ppr arg_wraps) <> braces (ppr res_wrap) else ppr expr -- | Command Syntax Table (for Arrow syntax) type CmdSyntaxTable p = [(Name, HsExpr p)] -- See Note [CmdSyntaxTable] {- Note [CmdSyntaxtable] ~~~~~~~~~~~~~~~~~~~~~ Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps track of the methods needed for a Cmd. * Before the renamer, this list is an empty list * After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ For example, for the 'arr' method * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) where @arr_22@ is whatever 'arr' is in scope * After the type checker, it takes the form [(std_name, )] where is the evidence for the method. This evidence is instantiated with the class, but is still polymorphic in everything else. For example, in the case of 'arr', the evidence has type forall b c. (b->c) -> a b c where 'a' is the ambient type of the arrow. This polymorphism is important because the desugarer uses the same evidence at multiple different types. This is Less Cool than what we normally do for rebindable syntax, which is to make fully-instantiated piece of evidence at every use site. The Cmd way is Less Cool because * The renamer has to predict which methods are needed. See the tedious RnExpr.methodNamesCmd. * The desugarer has to know the polymorphic type of the instantiated method. This is checked by Inst.tcSyntaxName, but is less flexible than the rest of rebindable syntax, where the type is less pre-ordained. (And this flexibility is useful; for example we can typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) -} -- | An unbound variable; used for treating -- out-of-scope variables as expression holes -- -- Either "x", "y" Plain OutOfScope -- or "_", "_x" A TrueExprHole -- -- Both forms indicate an out-of-scope variable, but the latter -- indicates that the user /expects/ it to be out of scope, and -- just wants GHC to report its type data UnboundVar = OutOfScope OccName GlobalRdrEnv -- ^ An (unqualified) out-of-scope -- variable, together with the GlobalRdrEnv -- with respect to which it is unbound -- See Note [OutOfScope and GlobalRdrEnv] | TrueExprHole OccName -- ^ A "true" expression hole (_ or _x) deriving Data instance Outputable UnboundVar where ppr (OutOfScope occ _) = text "OutOfScope" <> parens (ppr occ) ppr (TrueExprHole occ) = text "ExprHole" <> parens (ppr occ) unboundVarOcc :: UnboundVar -> OccName unboundVarOcc (OutOfScope occ _) = occ unboundVarOcc (TrueExprHole occ) = occ {- Note [OutOfScope and GlobalRdrEnv] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To understand why we bundle a GlobalRdrEnv with an out-of-scope variable, consider the following module: module A where foo :: () foo = bar bat :: [Double] bat = [1.2, 3.4] $(return []) bar = () bad = False When A is compiled, the renamer determines that `bar` is not in scope in the declaration of `foo` (since `bar` is declared in the following inter-splice group). Once it has finished typechecking the entire module, the typechecker then generates the associated error message, which specifies both the type of `bar` and a list of possible in-scope alternatives: A.hs:6:7: error: • Variable not in scope: bar :: () • ‘bar’ (line 13) is not in scope before the splice on line 11 Perhaps you meant ‘bat’ (line 9) When it calls RnEnv.unknownNameSuggestions to identify these alternatives, the typechecker must provide a GlobalRdrEnv. If it provided the current one, which contains top-level declarations for the entire module, the error message would incorrectly suggest the out-of-scope `bar` and `bad` as possible alternatives for `bar` (see #11680). Instead, the typechecker must use the same GlobalRdrEnv the renamer used when it determined that `bar` is out-of-scope. To obtain this GlobalRdrEnv, can the typechecker simply use the out-of-scope `bar`'s location to either reconstruct it (from the current GlobalRdrEnv) or to look it up in some global store? Unfortunately, no. The problem is that location information is not always sufficient for this task. This is most apparent when dealing with the TH function addTopDecls, which adds its declarations to the FOLLOWING inter-splice group. Consider these declarations: ex9 = cat -- cat is NOT in scope here $(do ------------------------------------------------------------- ds <- [d| f = cab -- cat and cap are both in scope here cat = () |] addTopDecls ds [d| g = cab -- only cap is in scope here cap = True |]) ex10 = cat -- cat is NOT in scope here $(return []) ----------------------------------------------------- ex11 = cat -- cat is in scope Here, both occurrences of `cab` are out-of-scope, and so the typechecker needs the GlobalRdrEnvs which were used when they were renamed. These GlobalRdrEnvs are different (`cat` is present only in the GlobalRdrEnv for f's `cab'), but the locations of the two `cab`s are the same (they are both created in the same splice). Thus, we must include some additional information with each `cab` to allow the typechecker to obtain the correct GlobalRdrEnv. Clearly, the simplest information to use is the GlobalRdrEnv itself. -} -- | A Haskell expression. data HsExpr p = HsVar (XVar p) (Located (IdP p)) -- ^ Variable -- See Note [Located RdrNames] | HsUnboundVar (XUnboundVar p) UnboundVar -- ^ Unbound variable; also used for "holes" -- (_ or _x). -- Turned from HsVar to HsUnboundVar by the -- renamer, when it finds an out-of-scope -- variable or hole. -- Turned into HsVar by type checker, to support -- deferred type errors. | HsConLikeOut (XConLikeOut p) ConLike -- ^ After typechecker only; must be different -- HsVar for pretty printing | HsRecFld (XRecFld p) (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector -- Not in use after typechecking | HsOverLabel (XOverLabel p) (Maybe (IdP p)) FastString -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the -- in-scope 'fromLabel'. -- NB: Not in use after typechecking | HsIPVar (XIPVar p) HsIPName -- ^ Implicit parameter (not in use after typechecking) | HsOverLit (XOverLitE p) (HsOverLit p) -- ^ Overloaded literals | HsLit (XLitE p) (HsLit p) -- ^ Simple (non-overloaded) literals | HsLam (XLam p) (MatchGroup p (LHsExpr p)) -- ^ Lambda abstraction. Currently always a single match -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', -- 'ApiAnnotation.AnnRarrow', -- For details on above see note [Api annotations] in ApiAnnotation | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', -- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation | HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application | HsAppType (XAppTypeE p) (LHsExpr p) (LHsWcType (NoGhcTc p)) -- ^ Visible type application -- -- Explicit type argument; e.g f @Int x y -- NB: Has wildcards, but no implicit quantification -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt', -- | Operator applications: -- NB Bracketed ops such as (+) come out as Vars. -- NB We need an expr for the operator in an OpApp/Section since -- the typechecker may need to apply the operator to a few types. | OpApp (XOpApp p) (LHsExpr p) -- left operand (LHsExpr p) -- operator (LHsExpr p) -- right operand -- | Negation operator. Contains the negated expression and the name -- of 'negate' -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus' -- For details on above see note [Api annotations] in ApiAnnotation | NegApp (XNegApp p) (LHsExpr p) (SyntaxExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsPar (XPar p) (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] | SectionL (XSectionL p) (LHsExpr p) -- operand; see Note [Sections in HsSyn] (LHsExpr p) -- operator | SectionR (XSectionR p) (LHsExpr p) -- operator; see Note [Sections in HsSyn] (LHsExpr p) -- operand -- | Used for explicit tuples and sections thereof -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -- Note [ExplicitTuple] | ExplicitTuple (XExplicitTuple p) [LHsTupArg p] Boxity -- | Used for unboxed sum types -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, -- 'ApiAnnotation.AnnVbar', 'ApiAnnotation.AnnClose' @'#)'@, -- -- There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before -- the expression, (arity - alternative) after it | ExplicitSum (XExplicitSum p) ConTag -- Alternative (one-based) Arity -- Sum arity (LHsExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnClose' @'}'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsCase (XCase p) (LHsExpr p) (MatchGroup p (LHsExpr p)) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', -- 'ApiAnnotation.AnnSemi', -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', -- 'ApiAnnotation.AnnElse', -- For details on above see note [Api annotations] in ApiAnnotation | HsIf (XIf p) (Maybe (SyntaxExpr p)) -- cond function -- Nothing => use the built-in 'if' -- See Note [Rebindable if] (LHsExpr p) -- predicate (LHsExpr p) -- then part (LHsExpr p) -- else part -- | Multi-way if -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf' -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', -- For details on above see note [Api annotations] in ApiAnnotation | HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)] -- | let(rec) -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', -- 'ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' -- For details on above see note [Api annotations] in ApiAnnotation | HsLet (XLet p) (LHsLocalBinds p) (LHsExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', -- 'ApiAnnotation.AnnVbar', -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation | HsDo (XDo p) -- Type of the whole expression (HsStmtContext Name) -- The parameterisation is unimportant -- because in this context we never use -- the PatGuard or ParStmt variant (Located [ExprLStmt p]) -- "do":one or more stmts -- | Syntactic list: [a,b,c,...] -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, -- 'ApiAnnotation.AnnClose' @']'@ -- For details on above see note [Api annotations] in ApiAnnotation -- See Note [Empty lists] | ExplicitList (XExplicitList p) -- Gives type of components of list (Maybe (SyntaxExpr p)) -- For OverloadedLists, the fromListN witness [LHsExpr p] -- | Record construction -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ -- For details on above see note [Api annotations] in ApiAnnotation | RecordCon { rcon_ext :: XRecordCon p , rcon_con_name :: Located (IdP p) -- The constructor name; -- not used after type checking , rcon_flds :: HsRecordBinds p } -- The fields -- | Record update -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ -- For details on above see note [Api annotations] in ApiAnnotation | RecordUpd { rupd_ext :: XRecordUpd p , rupd_expr :: LHsExpr p , rupd_flds :: [LHsRecUpdField p] } -- For a type family, the arg types are of the *instance* tycon, -- not the family tycon -- | Expression with an explicit type signature. @e :: type@ -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation | ExprWithTySig (XExprWithTySig p) (LHsExpr p) (LHsSigWcType (NoGhcTc p)) -- | Arithmetic sequence -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, -- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot', -- 'ApiAnnotation.AnnClose' @']'@ -- For details on above see note [Api annotations] in ApiAnnotation | ArithSeq (XArithSeq p) (Maybe (SyntaxExpr p)) -- For OverloadedLists, the fromList witness (ArithSeqInfo p) -- For details on above see note [Api annotations] in ApiAnnotation | HsSCC (XSCC p) SourceText -- Note [Pragma source text] in BasicTypes StringLiteral -- "set cost centre" SCC pragma (LHsExpr p) -- expr whose cost is to be measured -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@, -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsCoreAnn (XCoreAnn p) SourceText -- Note [Pragma source text] in BasicTypes StringLiteral -- hdaume: core annotation (LHsExpr p) ----------------------------------------------------------- -- MetaHaskell Extensions -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnOpenE','ApiAnnotation.AnnOpenEQ', -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ' -- For details on above see note [Api annotations] in ApiAnnotation | HsBracket (XBracket p) (HsBracket p) -- See Note [Pending Splices] | HsRnBracketOut (XRnBracketOut p) (HsBracket GhcRn) -- Output of the renamer is the *original* renamed -- expression, plus [PendingRnSplice] -- _renamed_ splices to be type checked | HsTcBracketOut (XTcBracketOut p) (HsBracket GhcRn) -- Output of the type checker is the *original* -- renamed expression, plus [PendingTcSplice] -- _typechecked_ splices to be -- pasted back in by the desugarer -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation | HsSpliceE (XSpliceE p) (HsSplice p) ----------------------------------------------------------- -- Arrow notation extension -- | @proc@ notation for Arrows -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnProc', -- 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation | HsProc (XProc p) (LPat p) -- arrow abstraction, proc (LHsCmdTop p) -- body of the abstraction -- always has an empty stack --------------------------------------- -- static pointers extension -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic', -- For details on above see note [Api annotations] in ApiAnnotation | HsStatic (XStatic p) -- Free variables of the body (LHsExpr p) -- Body --------------------------------------- -- Haskell program coverage (Hpc) Support | HsTick (XTick p) (Tickish (IdP p)) (LHsExpr p) -- sub-expression | HsBinTick (XBinTick p) Int -- module-local tick number for True Int -- module-local tick number for False (LHsExpr p) -- sub-expression -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@, -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal', -- 'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal', -- 'ApiAnnotation.AnnMinus', -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon', -- 'ApiAnnotation.AnnVal', -- 'ApiAnnotation.AnnClose' @'\#-}'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsTickPragma -- A pragma introduced tick (XTickPragma p) SourceText -- Note [Pragma source text] in BasicTypes (StringLiteral,(Int,Int),(Int,Int)) -- external span for this tick ((SourceText,SourceText),(SourceText,SourceText)) -- Source text for the four integers used in the span. -- See note [Pragma source text] in BasicTypes (LHsExpr p) --------------------------------------- -- Finally, HsWrap appears only in typechecker output -- The contained Expr is *NOT* itself an HsWrap. -- See Note [Detecting forced eta expansion] in DsExpr. This invariant -- is maintained by GHC.Hs.Utils.mkHsWrap. | HsWrap (XWrap p) HsWrapper -- TRANSLATION (HsExpr p) | XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor -- | Extra data fields for a 'RecordCon', added by the type checker data RecordConTc = RecordConTc { rcon_con_like :: ConLike -- The data constructor or pattern synonym , rcon_con_expr :: PostTcExpr -- Instantiated constructor function } -- | Extra data fields for a 'RecordUpd', added by the type checker data RecordUpdTc = RecordUpdTc { rupd_cons :: [ConLike] -- Filled in by the type checker to the -- _non-empty_ list of DataCons that have -- all the upd'd fields , rupd_in_tys :: [Type] -- Argument types of *input* record type , rupd_out_tys :: [Type] -- and *output* record type -- The original type can be reconstructed -- with conLikeResTy , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper] } deriving Data -- --------------------------------------------------------------------- type instance XVar (GhcPass _) = NoExtField type instance XUnboundVar (GhcPass _) = NoExtField type instance XConLikeOut (GhcPass _) = NoExtField type instance XRecFld (GhcPass _) = NoExtField type instance XOverLabel (GhcPass _) = NoExtField type instance XIPVar (GhcPass _) = NoExtField type instance XOverLitE (GhcPass _) = NoExtField type instance XLitE (GhcPass _) = NoExtField type instance XLam (GhcPass _) = NoExtField type instance XLamCase (GhcPass _) = NoExtField type instance XApp (GhcPass _) = NoExtField type instance XAppTypeE (GhcPass _) = NoExtField type instance XOpApp GhcPs = NoExtField type instance XOpApp GhcRn = Fixity type instance XOpApp GhcTc = Fixity type instance XNegApp (GhcPass _) = NoExtField type instance XPar (GhcPass _) = NoExtField type instance XSectionL (GhcPass _) = NoExtField type instance XSectionR (GhcPass _) = NoExtField type instance XExplicitTuple (GhcPass _) = NoExtField type instance XExplicitSum GhcPs = NoExtField type instance XExplicitSum GhcRn = NoExtField type instance XExplicitSum GhcTc = [Type] type instance XCase (GhcPass _) = NoExtField type instance XIf (GhcPass _) = NoExtField type instance XMultiIf GhcPs = NoExtField type instance XMultiIf GhcRn = NoExtField type instance XMultiIf GhcTc = Type type instance XLet (GhcPass _) = NoExtField type instance XDo GhcPs = NoExtField type instance XDo GhcRn = NoExtField type instance XDo GhcTc = Type type instance XExplicitList GhcPs = NoExtField type instance XExplicitList GhcRn = NoExtField type instance XExplicitList GhcTc = Type type instance XRecordCon GhcPs = NoExtField type instance XRecordCon GhcRn = NoExtField type instance XRecordCon GhcTc = RecordConTc type instance XRecordUpd GhcPs = NoExtField type instance XRecordUpd GhcRn = NoExtField type instance XRecordUpd GhcTc = RecordUpdTc type instance XExprWithTySig (GhcPass _) = NoExtField type instance XArithSeq GhcPs = NoExtField type instance XArithSeq GhcRn = NoExtField type instance XArithSeq GhcTc = PostTcExpr type instance XSCC (GhcPass _) = NoExtField type instance XCoreAnn (GhcPass _) = NoExtField type instance XBracket (GhcPass _) = NoExtField type instance XRnBracketOut (GhcPass _) = NoExtField type instance XTcBracketOut (GhcPass _) = NoExtField type instance XSpliceE (GhcPass _) = NoExtField type instance XProc (GhcPass _) = NoExtField type instance XStatic GhcPs = NoExtField type instance XStatic GhcRn = NameSet type instance XStatic GhcTc = NameSet type instance XTick (GhcPass _) = NoExtField type instance XBinTick (GhcPass _) = NoExtField type instance XTickPragma (GhcPass _) = NoExtField type instance XWrap (GhcPass _) = NoExtField type instance XXExpr (GhcPass _) = NoExtCon -- --------------------------------------------------------------------- -- | Located Haskell Tuple Argument -- -- 'HsTupArg' is used for tuple sections -- @(,a,)@ is represented by -- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@ -- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@ type LHsTupArg id = Located (HsTupArg id) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' -- For details on above see note [Api annotations] in ApiAnnotation -- | Haskell Tuple Argument data HsTupArg id = Present (XPresent id) (LHsExpr id) -- ^ The argument | Missing (XMissing id) -- ^ The argument is missing, but this is its type | XTupArg (XXTupArg id) -- ^ Note [Trees that Grow] extension point type instance XPresent (GhcPass _) = NoExtField type instance XMissing GhcPs = NoExtField type instance XMissing GhcRn = NoExtField type instance XMissing GhcTc = Type type instance XXTupArg (GhcPass _) = NoExtCon tupArgPresent :: LHsTupArg id -> Bool tupArgPresent (L _ (Present {})) = True tupArgPresent (L _ (Missing {})) = False tupArgPresent (L _ (XTupArg {})) = False {- Note [Parens in HsSyn] ~~~~~~~~~~~~~~~~~~~~~~ HsPar (and ParPat in patterns, HsParTy in types) is used as follows * HsPar is required; the pretty printer does not add parens. * HsPars are respected when rearranging operator fixities. So a * (b + c) means what it says (where the parens are an HsPar) * For ParPat and HsParTy the pretty printer does add parens but this should be a no-op for ParsedSource, based on the pretty printer round trip feature introduced in https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or not they are strictly necessary. This should be addressed when #13238 is completed, to be treated the same as HsPar. Note [Sections in HsSyn] ~~~~~~~~~~~~~~~~~~~~~~~~ Sections should always appear wrapped in an HsPar, thus HsPar (SectionR ...) The parser parses sections in a wider variety of situations (See Note [Parsing sections]), but the renamer checks for those parens. This invariant makes pretty-printing easier; we don't need a special case for adding the parens round sections. Note [Rebindable if] ~~~~~~~~~~~~~~~~~~~~ The rebindable syntax for 'if' is a bit special, because when rebindable syntax is *off* we do not want to treat (if c then t else e) as if it was an application (ifThenElse c t e). Why not? Because we allow an 'if' to return *unboxed* results, thus if blah then 3# else 4# whereas that would not be possible using a all to a polymorphic function (because you can't call a polymorphic function at an unboxed type). So we use Nothing to mean "use the old built-in typing rule". Note [Record Update HsWrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There is a wrapper in RecordUpd which is used for the *required* constraints for pattern synonyms. This wrapper is created in the typechecking and is then directly used in the desugaring without modification. For example, if we have the record pattern synonym P, pattern P :: (Show a) => a -> Maybe a pattern P{x} = Just x foo = (Just True) { x = False } then `foo` desugars to something like foo = case Just True of P x -> P False hence we need to provide the correct dictionaries to P's matcher on the RHS so that we can build the expression. Note [Located RdrNames] ~~~~~~~~~~~~~~~~~~~~~~~ A number of syntax elements have seemingly redundant locations attached to them. This is deliberate, to allow transformations making use of the API Annotations to easily correlate a Located Name in the RenamedSource with a Located RdrName in the ParsedSource. There are unfortunately enough differences between the ParsedSource and the RenamedSource that the API Annotations cannot be used directly with RenamedSource, so this allows a simple mapping to be used based on the location. Note [ExplicitTuple] ~~~~~~~~~~~~~~~~~~~~ An ExplicitTuple is never just a data constructor like (,,,). That is, the `[LHsTupArg p]` argument of `ExplicitTuple` has at least one `Present` member (and is thus never empty). A tuple data constructor like () or (,,,) is parsed as an `HsVar`, not an `ExplicitTuple`, and stays that way. This is important for two reasons: 1. We don't need -XTupleSections for (,,,) 2. The type variables in (,,,) can be instantiated with visible type application. That is, (,,) :: forall a b c. a -> b -> c -> (a,b,c) (True,,) :: forall {b} {c}. b -> c -> (Bool,b,c) Note that the tuple section has *inferred* arguments, while the data constructor has *specified* ones. (See Note [Required, Specified, and Inferred for types] in TcTyClsDecls for background.) Sadly, the grammar for this is actually ambiguous, and it's only thanks to the preference of a shift in a shift/reduce conflict that the parser works as this Note details. Search for a reference to this Note in Parser.y for further explanation. Note [Empty lists] ~~~~~~~~~~~~~~~~~~ An empty list could be considered either a data constructor (stored with HsVar) or an ExplicitList. This Note describes how empty lists flow through the various phases and why. Parsing ------- An empty list is parsed by the sysdcon nonterminal. It thus comes to life via HsVar nilDataCon (defined in TysWiredIn). A freshly-parsed (HsExpr GhcPs) empty list is never a ExplicitList. Renaming -------- If -XOverloadedLists is enabled, we must type-check the empty list as if it were a call to fromListN. (This is true regardless of the setting of -XRebindableSyntax.) This is very easy if the empty list is an ExplicitList, but an annoying special case if it's an HsVar. So the renamer changes a HsVar nilDataCon to an ExplicitList [], but only if -XOverloadedLists is on. (Why not always? Read on, dear friend.) This happens in the HsVar case of rnExpr. Type-checking ------------- We want to accept an expression like [] @Int. To do this, we must infer that [] :: forall a. [a]. This is easy if [] is a HsVar with the right DataCon inside. However, the type-checking for explicit lists works differently: [x,y,z] is never polymorphic. Instead, we unify the types of x, y, and z together, and use the unified type as the argument to the cons and nil constructors. Thus, treating [] as an empty ExplicitList in the type-checker would prevent [] @Int from working. However, if -XOverloadedLists is on, then [] @Int really shouldn't be allowed: it's just like fromListN 0 [] @Int. Since fromListN :: forall list. IsList list => Int -> [Item list] -> list that expression really should be rejected. Thus, the renamer's behaviour is exactly what we want: treat [] as a datacon when -XNoOverloadedLists, and as an empty ExplicitList when -XOverloadedLists. See also #13680, which requested [] @Int to work. -} instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where ppr expr = pprExpr expr ----------------------- -- pprExpr, pprLExpr, pprBinds call pprDeeper; -- the underscore versions do not pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc pprLExpr (L _ e) = pprExpr e pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e | otherwise = pprDeeper (ppr_expr e) isQuietHsExpr :: HsExpr id -> Bool -- Parentheses do display something, but it gives little info and -- if we go deeper when we go inside them then we get ugly things -- like (...) isQuietHsExpr (HsPar {}) = True -- applications don't display anything themselves isQuietHsExpr (HsApp {}) = True isQuietHsExpr (HsAppType {}) = True isQuietHsExpr (OpApp {}) = True isQuietHsExpr _ = False pprBinds :: (OutputableBndrId idL, OutputableBndrId idR) => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc pprBinds b = pprDeeper (ppr b) ----------------------- ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc ppr_lexpr e = ppr_expr (unLoc e) ppr_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc (unboundVarOcc uv) ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c ppr_expr (HsIPVar _ v) = ppr v ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l ppr_expr (HsLit _ lit) = ppr lit ppr_expr (HsOverLit _ lit) = ppr lit ppr_expr (HsPar _ e) = parens (ppr_lexpr e) ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e) = vcat [pprWithSourceText stc (text "{-# CORE") <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}" , ppr_lexpr e] ppr_expr e@(HsApp {}) = ppr_apps e [] ppr_expr e@(HsAppType {}) = ppr_apps e [] ppr_expr (OpApp _ e1 op e2) | Just pp_op <- ppr_infix_expr (unLoc op) = pp_infixly pp_op | otherwise = pp_prefixly where pp_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear pp_prefixly = hang (ppr op) 2 (sep [pp_e1, pp_e2]) pp_infixly pp_op = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2]) ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e ppr_expr (SectionL _ expr op) | Just pp_op <- ppr_infix_expr (unLoc op) = pp_infixly pp_op | otherwise = pp_prefixly where pp_expr = pprDebugParendExpr opPrec expr pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) 4 (hsep [pp_expr, text "x_ )"]) pp_infixly v = (sep [pp_expr, v]) ppr_expr (SectionR _ op expr) | Just pp_op <- ppr_infix_expr (unLoc op) = pp_infixly pp_op | otherwise = pp_prefixly where pp_expr = pprDebugParendExpr opPrec expr pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) 4 (pp_expr <> rparen) pp_infixly v = sep [v, pp_expr] ppr_expr (ExplicitTuple _ exprs boxity) -- Special-case unary boxed tuples so that they are pretty-printed as -- `Unit x`, not `(x)` | [dL -> L _ (Present _ expr)] <- exprs , Boxed <- boxity = hsep [text (mkTupleStr Boxed 1), ppr expr] | otherwise = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) where ppr_tup_args [] = [] ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es ppr_tup_args (XTupArg x : es) = (ppr x <> punc es) : ppr_tup_args es punc (Present {} : _) = comma <> space punc (Missing {} : _) = comma punc (XTupArg {} : _) = comma <> space punc [] = empty ppr_expr (ExplicitSum _ alt arity expr) = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)" where ppr_bars n = hsep (replicate n (char '|')) ppr_expr (HsLam _ matches) = pprMatches matches ppr_expr (HsLamCase _ matches) = sep [ sep [text "\\case"], nest 2 (pprMatches matches) ] ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] })) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], nest 2 (pprMatches matches) <+> char '}'] ppr_expr (HsCase _ expr matches) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], nest 2 (pprMatches matches) ] ppr_expr (HsIf _ _ e1 e2 e3) = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], nest 4 (ppr e2), text "else", nest 4 (ppr e3)] ppr_expr (HsMultiIf _ alts) = hang (text "if") 3 (vcat (map ppr_alt alts)) where ppr_alt (L _ (GRHS _ guards expr)) = hang vbar 2 (ppr_one one_alt) where ppr_one [] = panic "ppr_exp HsMultiIf" ppr_one (h:t) = hang h 2 (sep t) one_alt = [ interpp'SP guards , text "->" <+> pprDeeper (ppr expr) ] ppr_alt (L _ (XGRHS x)) = ppr x -- special case: let ... in let ... ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _))) = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), ppr_lexpr expr] ppr_expr (HsLet _ (L _ binds) expr) = sep [hang (text "let") 2 (pprBinds binds), hang (text "in") 2 (ppr expr)] ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts ppr_expr (ExplicitList _ _ exprs) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds }) = hang (ppr con_id) 2 (ppr rbinds) ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds }) = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) ppr_expr (ExprWithTySig _ expr sig) = hang (nest 2 (ppr_lexpr expr) <+> dcolon) 4 (ppr sig) ppr_expr (ArithSeq _ _ info) = brackets (ppr info) ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr) = sep [ pprWithSourceText st (text "{-# SCC") -- no doublequotes if stl empty, for the case where the SCC was written -- without quotes. <+> pprWithSourceText stl (ftext lbl) <+> text "#-}", ppr expr ] ppr_expr (HsWrap _ co_fn e) = pprHsWrapper co_fn (\parens -> if parens then pprExpr e else pprExpr e) ppr_expr (HsSpliceE _ s) = pprSplice s ppr_expr (HsBracket _ b) = pprHsBracket b ppr_expr (HsRnBracketOut _ e []) = ppr e ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps ppr_expr (HsTcBracketOut _ e []) = ppr e ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd))) = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] ppr_expr (HsProc _ pat (L _ (XCmdTop x))) = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr x] ppr_expr (HsStatic _ e) = hsep [text "static", ppr e] ppr_expr (HsTick _ tickish exp) = pprTicks (ppr exp) $ ppr tickish <+> ppr_lexpr exp ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp) = pprTicks (ppr exp) $ hcat [text "bintick<", ppr tickIdTrue, text ",", ppr tickIdFalse, text ">(", ppr exp, text ")"] ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp) = pprTicks (ppr exp) $ hcat [text "tickpragma<", pprExternalSrcLoc externalSrcLoc, text ">(", ppr exp, text ")"] ppr_expr (HsRecFld _ f) = ppr f ppr_expr (XExpr x) = ppr x ppr_infix_expr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) ppr_infix_expr (HsConLikeOut _ c) = Just (pprInfixOcc (conLikeName c)) ppr_infix_expr (HsRecFld _ f) = Just (pprInfixOcc f) ppr_infix_expr (HsUnboundVar _ h@TrueExprHole{}) = Just (pprInfixOcc (unboundVarOcc h)) ppr_infix_expr (HsWrap _ _ e) = ppr_infix_expr e ppr_infix_expr _ = Nothing ppr_apps :: (OutputableBndrId p) => HsExpr (GhcPass p) -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] -> SDoc ppr_apps (HsApp _ (L _ fun) arg) args = ppr_apps fun (Left arg : args) ppr_apps (HsAppType _ (L _ fun) arg) args = ppr_apps fun (Right arg : args) ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args)) where pp (Left arg) = ppr arg -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) -- = char '@' <> pprHsType arg pp (Right arg) = char '@' <> ppr arg pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4)) = ppr (src,(n1,n2),(n3,n4)) {- HsSyn records exactly where the user put parens, with HsPar. So generally speaking we print without adding any parens. However, some code is internally generated, and in some places parens are absolutely required; so for these places we use pprParendLExpr (but don't print double parens of course). For operator applications we don't add parens, because the operator fixities should do the job, except in debug mode (-dppr-debug) so we can see the structure of the parse tree. -} pprDebugParendExpr :: (OutputableBndrId p) => PprPrec -> LHsExpr (GhcPass p) -> SDoc pprDebugParendExpr p expr = getPprStyle (\sty -> if debugStyle sty then pprParendLExpr p expr else pprLExpr expr) pprParendLExpr :: (OutputableBndrId p) => PprPrec -> LHsExpr (GhcPass p) -> SDoc pprParendLExpr p (L _ e) = pprParendExpr p e pprParendExpr :: (OutputableBndrId p) => PprPrec -> HsExpr (GhcPass p) -> SDoc pprParendExpr p expr | hsExprNeedsParens p expr = parens (pprExpr expr) | otherwise = pprExpr expr -- Using pprLExpr makes sure that we go 'deeper' -- I think that is usually (always?) right -- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs -- parentheses under precedence @p@. hsExprNeedsParens :: PprPrec -> HsExpr p -> Bool hsExprNeedsParens p = go where go (HsVar{}) = False go (HsUnboundVar{}) = False go (HsConLikeOut{}) = False go (HsIPVar{}) = False go (HsOverLabel{}) = False go (HsLit _ l) = hsLitNeedsParens p l go (HsOverLit _ ol) = hsOverLitNeedsParens p ol go (HsPar{}) = False go (HsCoreAnn _ _ _ (L _ e)) = go e go (HsApp{}) = p >= appPrec go (HsAppType {}) = p >= appPrec go (OpApp{}) = p >= opPrec go (NegApp{}) = p > topPrec go (SectionL{}) = True go (SectionR{}) = True go (ExplicitTuple{}) = False go (ExplicitSum{}) = False go (HsLam{}) = p > topPrec go (HsLamCase{}) = p > topPrec go (HsCase{}) = p > topPrec go (HsIf{}) = p > topPrec go (HsMultiIf{}) = p > topPrec go (HsLet{}) = p > topPrec go (HsDo _ sc _) | isComprehensionContext sc = False | otherwise = p > topPrec go (ExplicitList{}) = False go (RecordUpd{}) = False go (ExprWithTySig{}) = p >= sigPrec go (ArithSeq{}) = False go (HsSCC{}) = p >= appPrec go (HsWrap _ _ e) = go e go (HsSpliceE{}) = False go (HsBracket{}) = False go (HsRnBracketOut{}) = False go (HsTcBracketOut{}) = False go (HsProc{}) = p > topPrec go (HsStatic{}) = p >= appPrec go (HsTick _ _ (L _ e)) = go e go (HsBinTick _ _ _ (L _ e)) = go e go (HsTickPragma _ _ _ _ (L _ e)) = go e go (RecordCon{}) = False go (HsRecFld{}) = False go (XExpr{}) = True -- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true, -- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@. parenthesizeHsExpr :: PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) parenthesizeHsExpr p le@(L loc e) | hsExprNeedsParens p e = L loc (HsPar noExtField le) | otherwise = le isAtomicHsExpr :: HsExpr id -> Bool -- True of a single token isAtomicHsExpr (HsVar {}) = True isAtomicHsExpr (HsConLikeOut {}) = True isAtomicHsExpr (HsLit {}) = True isAtomicHsExpr (HsOverLit {}) = True isAtomicHsExpr (HsIPVar {}) = True isAtomicHsExpr (HsOverLabel {}) = True isAtomicHsExpr (HsUnboundVar {}) = True isAtomicHsExpr (HsWrap _ _ e) = isAtomicHsExpr e isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e) isAtomicHsExpr (HsRecFld{}) = True isAtomicHsExpr _ = False {- ************************************************************************ * * \subsection{Commands (in arrow abstractions)} * * ************************************************************************ We re-use HsExpr to represent these. -} -- | Located Haskell Command (for arrow syntax) type LHsCmd id = Located (HsCmd id) -- | Haskell Command (e.g. a "statement" in an Arrow proc block) data HsCmd id -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail', -- 'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail', -- 'ApiAnnotation.AnnRarrowtail' -- For details on above see note [Api annotations] in ApiAnnotation = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) (XCmdArrApp id) -- type of the arrow expressions f, -- of the form a t t', where arg :: t (LHsExpr id) -- arrow expression, f (LHsExpr id) -- input expression, arg HsArrAppType -- higher-order (-<<) or first-order (-<) Bool -- True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpenB' @'(|'@, -- 'ApiAnnotation.AnnCloseB' @'|)'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) (XCmdArrForm id) (LHsExpr id) -- The operator. -- After type-checking, a type abstraction to be -- applied to the type of the local environment tuple LexicalFixity -- Whether the operator appeared prefix or infix when -- parsed. (Maybe Fixity) -- fixity (filled in by the renamer), for forms that -- were converted from OpApp's by the renamer [LHsCmdTop id] -- argument commands | HsCmdApp (XCmdApp id) (LHsCmd id) (LHsExpr id) | HsCmdLam (XCmdLam id) (MatchGroup id (LHsCmd id)) -- kappa -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', -- 'ApiAnnotation.AnnRarrow', -- For details on above see note [Api annotations] in ApiAnnotation | HsCmdPar (XCmdPar id) (LHsCmd id) -- parenthesised command -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsCmdCase (XCmdCase id) (LHsExpr id) (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnClose' @'}'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsCmdIf (XCmdIf id) (Maybe (SyntaxExpr id)) -- cond function (LHsExpr id) -- predicate (LHsCmd id) -- then part (LHsCmd id) -- else part -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', -- 'ApiAnnotation.AnnSemi', -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', -- 'ApiAnnotation.AnnElse', -- For details on above see note [Api annotations] in ApiAnnotation | HsCmdLet (XCmdLet id) (LHsLocalBinds id) -- let(rec) (LHsCmd id) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', -- 'ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' -- For details on above see note [Api annotations] in ApiAnnotation | HsCmdDo (XCmdDo id) -- Type of the whole expression (Located [CmdLStmt id]) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', -- 'ApiAnnotation.AnnVbar', -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation | HsCmdWrap (XCmdWrap id) HsWrapper (HsCmd id) -- If cmd :: arg1 --> res -- wrap :: arg1 "->" arg2 -- Then (HsCmdWrap wrap cmd) :: arg2 --> res | XCmd (XXCmd id) -- Note [Trees that Grow] extension point type instance XCmdArrApp GhcPs = NoExtField type instance XCmdArrApp GhcRn = NoExtField type instance XCmdArrApp GhcTc = Type type instance XCmdArrForm (GhcPass _) = NoExtField type instance XCmdApp (GhcPass _) = NoExtField type instance XCmdLam (GhcPass _) = NoExtField type instance XCmdPar (GhcPass _) = NoExtField type instance XCmdCase (GhcPass _) = NoExtField type instance XCmdIf (GhcPass _) = NoExtField type instance XCmdLet (GhcPass _) = NoExtField type instance XCmdDo GhcPs = NoExtField type instance XCmdDo GhcRn = NoExtField type instance XCmdDo GhcTc = Type type instance XCmdWrap (GhcPass _) = NoExtField type instance XXCmd (GhcPass _) = NoExtCon -- | Haskell Array Application Type data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp deriving Data {- | Top-level command, introducing a new arrow. This may occur inside a proc (where the stack is empty) or as an argument of a command-forming operator. -} -- | Located Haskell Top-level Command type LHsCmdTop p = Located (HsCmdTop p) -- | Haskell Top-level Command data HsCmdTop p = HsCmdTop (XCmdTop p) (LHsCmd p) | XCmdTop (XXCmdTop p) -- Note [Trees that Grow] extension point data CmdTopTc = CmdTopTc Type -- Nested tuple of inputs on the command's stack Type -- return type of the command (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] type instance XCmdTop GhcPs = NoExtField type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] type instance XCmdTop GhcTc = CmdTopTc type instance XXCmdTop (GhcPass _) = NoExtCon instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where ppr cmd = pprCmd cmd ----------------------- -- pprCmd and pprLCmd call pprDeeper; -- the underscore versions do not pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc pprLCmd (L _ c) = pprCmd c pprCmd :: (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc pprCmd c | isQuietHsCmd c = ppr_cmd c | otherwise = pprDeeper (ppr_cmd c) isQuietHsCmd :: HsCmd id -> Bool -- Parentheses do display something, but it gives little info and -- if we go deeper when we go inside them then we get ugly things -- like (...) isQuietHsCmd (HsCmdPar {}) = True -- applications don't display anything themselves isQuietHsCmd (HsCmdApp {}) = True isQuietHsCmd _ = False ----------------------- ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc ppr_lcmd c = ppr_cmd (unLoc c) ppr_cmd :: forall p. (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c) ppr_cmd (HsCmdApp _ c e) = let (fun, args) = collect_args c [e] in hang (ppr_lcmd fun) 2 (sep (map ppr args)) where collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args) collect_args fun args = (fun, args) ppr_cmd (HsCmdLam _ matches) = pprMatches matches ppr_cmd (HsCmdCase _ expr matches) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], nest 2 (pprMatches matches) ] ppr_cmd (HsCmdIf _ _ e ct ce) = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")], nest 4 (ppr ct), text "else", nest 4 (ppr ce)] -- special case: let ... in let ... ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {}))) = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), ppr_lcmd cmd] ppr_cmd (HsCmdLet _ (L _ binds) cmd) = sep [hang (text "let") 2 (pprBinds binds), hang (text "in") 2 (ppr cmd)] ppr_cmd (HsCmdDo _ (L _ stmts)) = pprDo ArrowExpr stmts ppr_cmd (HsCmdWrap _ w cmd) = pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True) = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False) = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True) = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False) = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v , pprCmdArg (unLoc arg2)]) ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _ [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v , pprCmdArg (unLoc arg2)]) ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) , pprCmdArg (unLoc arg2)]) ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) , pprCmdArg (unLoc arg2)]) ppr_cmd (HsCmdArrForm _ op _ _ args) = hang (text "(|" <+> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") ppr_cmd (XCmd x) = ppr x pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc pprCmdArg (HsCmdTop _ cmd) = ppr_lcmd cmd pprCmdArg (XCmdTop x) = ppr x instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where ppr = pprCmdArg {- ************************************************************************ * * \subsection{Record binds} * * ************************************************************************ -} -- | Haskell Record Bindings type HsRecordBinds p = HsRecFields p (LHsExpr p) {- ************************************************************************ * * \subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} * * ************************************************************************ @Match@es are sets of pattern bindings and right hand sides for functions, patterns or case branches. For example, if a function @g@ is defined as: \begin{verbatim} g (x,y) = y g ((x:ys),y) = y+1, \end{verbatim} then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@. It is always the case that each element of an @[Match]@ list has the same number of @pats@s inside it. This corresponds to saying that a function defined by pattern matching must have the same number of patterns in each equation. -} data MatchGroup p body = MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result , mg_alts :: Located [LMatch p body] -- The alternatives , mg_origin :: Origin } -- The type is the type of the entire group -- t1 -> ... -> tn -> tr -- where there are n patterns | XMatchGroup (XXMatchGroup p body) data MatchGroupTc = MatchGroupTc { mg_arg_tys :: [Type] -- Types of the arguments, t1..tn , mg_res_ty :: Type -- Type of the result, tr } deriving Data type instance XMG GhcPs b = NoExtField type instance XMG GhcRn b = NoExtField type instance XMG GhcTc b = MatchGroupTc type instance XXMatchGroup (GhcPass _) b = NoExtCon -- | Located Match type LMatch id body = Located (Match id body) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a -- list -- For details on above see note [Api annotations] in ApiAnnotation data Match p body = Match { m_ext :: XCMatch p body, m_ctxt :: HsMatchContext (NameOrRdrName (IdP p)), -- See note [m_ctxt in Match] m_pats :: [LPat p], -- The patterns m_grhss :: (GRHSs p body) } | XMatch (XXMatch p body) type instance XCMatch (GhcPass _) b = NoExtField type instance XXMatch (GhcPass _) b = NoExtCon instance (OutputableBndrId pr, Outputable body) => Outputable (Match (GhcPass pr) body) where ppr = pprMatch {- Note [m_ctxt in Match] ~~~~~~~~~~~~~~~~~~~~~~ A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and so on. In order to simplify tooling processing and pretty print output, the provenance is captured in an HsMatchContext. This is particularly important for the API Annotations for a multi-equation FunBind. The parser initially creates a FunBind with a single Match in it for every function definition it sees. These are then grouped together by getMonoBind into a single FunBind, where all the Matches are combined. In the process, all the original FunBind fun_id's bar one are discarded, including the locations. This causes a problem for source to source conversions via API Annotations, so the original fun_ids and infix flags are preserved in the Match, when it originates from a FunBind. Example infix function definition requiring individual API Annotations (&&& ) [] [] = [] xs &&& [] = xs ( &&& ) [] ys = ys -} isInfixMatch :: Match id body -> Bool isInfixMatch match = case m_ctxt match of FunRhs {mc_fixity = Infix} -> True _ -> False isEmptyMatchGroup :: MatchGroup id body -> Bool isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms isEmptyMatchGroup (XMatchGroup {}) = False -- | Is there only one RHS in this list of matches? isSingletonMatchGroup :: [LMatch id body] -> Bool isSingletonMatchGroup matches | [L _ match] <- matches , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match = True | otherwise = False matchGroupArity :: MatchGroup (GhcPass id) body -> Arity -- Precondition: MatchGroup is non-empty -- This is called before type checking, when mg_arg_tys is not set matchGroupArity (MG { mg_alts = alts }) | L _ (alt1:_) <- alts = length (hsLMatchPats alt1) | otherwise = panic "matchGroupArity" matchGroupArity (XMatchGroup nec) = noExtCon nec hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] hsLMatchPats (L _ (Match { m_pats = pats })) = pats hsLMatchPats (L _ (XMatch nec)) = noExtCon nec -- | Guarded Right-Hand Sides -- -- GRHSs are used both for pattern bindings and for Matches -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar', -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -- 'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi' -- For details on above see note [Api annotations] in ApiAnnotation data GRHSs p body = GRHSs { grhssExt :: XCGRHSs p body, grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause } | XGRHSs (XXGRHSs p body) type instance XCGRHSs (GhcPass _) b = NoExtField type instance XXGRHSs (GhcPass _) b = NoExtCon -- | Located Guarded Right-Hand Side type LGRHS id body = Located (GRHS id body) -- | Guarded Right Hand Side. data GRHS p body = GRHS (XCGRHS p body) [GuardLStmt p] -- Guards body -- Right hand side | XGRHS (XXGRHS p body) type instance XCGRHS (GhcPass _) b = NoExtField type instance XXGRHS (GhcPass _) b = NoExtCon -- We know the list must have at least one @Match@ in it. pprMatches :: (OutputableBndrId idR, Outputable body) => MatchGroup (GhcPass idR) body -> SDoc pprMatches MG { mg_alts = matches } = vcat (map pprMatch (map unLoc (unLoc matches))) -- Don't print the type; it's only a place-holder before typechecking pprMatches (XMatchGroup x) = ppr x -- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext pprFunBind :: (OutputableBndrId idR, Outputable body) => MatchGroup (GhcPass idR) body -> SDoc pprFunBind matches = pprMatches matches -- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext pprPatBind :: forall bndr p body. (OutputableBndrId bndr, OutputableBndrId p, Outputable body) => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc pprPatBind pat (grhss) = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)] pprMatch :: (OutputableBndrId idR, Outputable body) => Match (GhcPass idR) body -> SDoc pprMatch match = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats) , nest 2 (pprGRHSs ctxt (m_grhss match)) ] where ctxt = m_ctxt match (herald, other_pats) = case ctxt of FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness} | strictness == SrcStrict -> ASSERT(null $ m_pats match) (char '!'<>pprPrefixOcc fun, m_pats match) -- a strict variable binding | fixity == Prefix -> (pprPrefixOcc fun, m_pats match) -- f x y z = e -- Not pprBndr; the AbsBinds will -- have printed the signature | null pats2 -> (pp_infix, []) -- x &&& y = e | otherwise -> (parens pp_infix, pats2) -- (x &&& y) z = e where pp_infix = pprParendLPat opPrec pat1 <+> pprInfixOcc fun <+> pprParendLPat opPrec pat2 LambdaExpr -> (char '\\', m_pats match) _ -> if null (m_pats match) then (empty, []) else ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 ) (ppr pat1, []) -- No parens around the single pat (pat1:pats1) = m_pats match (pat2:pats2) = pats1 pprGRHSs :: (OutputableBndrId idR, Outputable body) => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc pprGRHSs ctxt (GRHSs _ grhss (L _ binds)) = vcat (map (pprGRHS ctxt . unLoc) grhss) -- Print the "where" even if the contents of the binds is empty. Only -- EmptyLocalBinds means no "where" keyword $$ ppUnless (eqEmptyLocalBinds binds) (text "where" $$ nest 4 (pprBinds binds)) pprGRHSs _ (XGRHSs x) = ppr x pprGRHS :: (OutputableBndrId idR, Outputable body) => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc pprGRHS ctxt (GRHS _ [] body) = pp_rhs ctxt body pprGRHS ctxt (GRHS _ guards body) = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body] pprGRHS _ (XGRHS x) = ppr x pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) {- ************************************************************************ * * \subsection{Do stmts and list comprehensions} * * ************************************************************************ -} -- | Located @do@ block Statement type LStmt id body = Located (StmtLR id id body) -- | Located Statement with separate Left and Right id's type LStmtLR idL idR body = Located (StmtLR idL idR body) -- | @do@ block Statement type Stmt id body = StmtLR id id body -- | Command Located Statement type CmdLStmt id = LStmt id (LHsCmd id) -- | Command Statement type CmdStmt id = Stmt id (LHsCmd id) -- | Expression Located Statement type ExprLStmt id = LStmt id (LHsExpr id) -- | Expression Statement type ExprStmt id = Stmt id (LHsExpr id) -- | Guard Located Statement type GuardLStmt id = LStmt id (LHsExpr id) -- | Guard Statement type GuardStmt id = Stmt id (LHsExpr id) -- | Ghci Located Statement type GhciLStmt id = LStmt id (LHsExpr id) -- | Ghci Statement type GhciStmt id = Stmt id (LHsExpr id) -- The SyntaxExprs in here are used *only* for do-notation and monad -- comprehensions, which have rebindable syntax. Otherwise they are unused. -- | API Annotations when in qualifier lists or guards -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar', -- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnThen', -- 'ApiAnnotation.AnnBy','ApiAnnotation.AnnBy', -- 'ApiAnnotation.AnnGroup','ApiAnnotation.AnnUsing' -- For details on above see note [Api annotations] in ApiAnnotation data StmtLR idL idR body -- body should always be (LHs**** idR) = LastStmt -- Always the last Stmt in ListComp, MonadComp, -- and (after the renamer, see RnExpr.checkLastStmt) DoExpr, MDoExpr -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff (XLastStmt idL idR body) body Bool -- True <=> return was stripped by ApplicativeDo (SyntaxExpr idR) -- The return operator -- The return operator is used only for MonadComp -- For ListComp we use the baked-in 'return' -- For DoExpr, MDoExpr, we don't apply a 'return' at all -- See Note [Monad Comprehensions] -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow' -- For details on above see note [Api annotations] in ApiAnnotation | BindStmt (XBindStmt idL idR body) -- Post typechecking, -- result type of the function passed to bind; -- that is, S in (>>=) :: Q -> (R -> S) -> T (LPat idL) body (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts] (SyntaxExpr idR) -- The fail operator -- The fail operator is noSyntaxExpr -- if the pattern match can't fail -- | 'ApplicativeStmt' represents an applicative expression built with -- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the -- appropriate applicative expression by the desugarer, but it is intended -- to be invisible in error messages. -- -- For full details, see Note [ApplicativeDo] in RnExpr -- | ApplicativeStmt (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body [ ( SyntaxExpr idR , ApplicativeArg idL) ] -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] (Maybe (SyntaxExpr idR)) -- 'join', if necessary | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type -- of the RHS (used for arrows) body -- See Note [BodyStmt] (SyntaxExpr idR) -- The (>>) operator (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp -- See notes [Monad Comprehensions] -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet' -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@, -- For details on above see note [Api annotations] in ApiAnnotation | LetStmt (XLetStmt idL idR body) (LHsLocalBindsLR idL idR) -- ParStmts only occur in a list/monad comprehension | ParStmt (XParStmt idL idR body) -- Post typecheck, -- S in (>>=) :: Q -> (R -> S) -> T [ParStmtBlock idL idR] (HsExpr idR) -- Polymorphic `mzip` for monad comprehensions (SyntaxExpr idR) -- The `>>=` operator -- See notes [Monad Comprehensions] -- After renaming, the ids are the binders -- bound by the stmts and used after themp | TransStmt { trS_ext :: XTransStmt idL idR body, -- Post typecheck, -- R in (>>=) :: Q -> (R -> S) -> T trS_form :: TransForm, trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group' -- which generates the tuples to be grouped trS_bndrs :: [(IdP idR, IdP idR)], -- See Note [TransStmt binder map] trS_using :: LHsExpr idR, trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) -- Invariant: if trS_form = GroupBy, then grp_by = Just e trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for -- the inner monad comprehensions trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator trS_fmap :: HsExpr idR -- The polymorphic 'fmap' function for desugaring -- Only for 'group' forms -- Just a simple HsExpr, because it's -- too polymorphic for tcSyntaxOp } -- See Note [Monad Comprehensions] -- Recursive statement (see Note [How RecStmt works] below) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRec' -- For details on above see note [Api annotations] in ApiAnnotation | RecStmt { recS_ext :: XRecStmt idL idR body , recS_stmts :: [LStmtLR idL idR body] -- The next two fields are only valid after renaming , recS_later_ids :: [IdP idR] -- The ids are a subset of the variables bound by the -- stmts that are used in stmts that follow the RecStmt , recS_rec_ids :: [IdP idR] -- Ditto, but these variables are the "recursive" ones, -- that are used before they are bound in the stmts of -- the RecStmt. -- An Id can be in both groups -- Both sets of Ids are (now) treated monomorphically -- See Note [How RecStmt works] for why they are separate -- Rebindable syntax , recS_bind_fn :: SyntaxExpr idR -- The bind function , recS_ret_fn :: SyntaxExpr idR -- The return function , recS_mfix_fn :: SyntaxExpr idR -- The mfix function } | XStmtLR (XXStmtLR idL idR body) -- Extra fields available post typechecking for RecStmt. data RecStmtTc = RecStmtTc { recS_bind_ty :: Type -- S in (>>=) :: Q -> (R -> S) -> T , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version) , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 -- with recS_later_ids and recS_rec_ids, -- and are the expressions that should be -- returned by the recursion. -- They may not quite be the Ids themselves, -- because the Id may be *polymorphic*, but -- the returned thing has to be *monomorphic*, -- so they may be type applications , recS_ret_ty :: Type -- The type of -- do { stmts; return (a,b,c) } -- With rebindable syntax the type might not -- be quite as simple as (m (tya, tyb, tyc)). } type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExtField type instance XBindStmt (GhcPass _) GhcPs b = NoExtField type instance XBindStmt (GhcPass _) GhcRn b = NoExtField type instance XBindStmt (GhcPass _) GhcTc b = Type type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField type instance XApplicativeStmt (GhcPass _) GhcTc b = Type type instance XBodyStmt (GhcPass _) GhcPs b = NoExtField type instance XBodyStmt (GhcPass _) GhcRn b = NoExtField type instance XBodyStmt (GhcPass _) GhcTc b = Type type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExtField type instance XParStmt (GhcPass _) GhcPs b = NoExtField type instance XParStmt (GhcPass _) GhcRn b = NoExtField type instance XParStmt (GhcPass _) GhcTc b = Type type instance XTransStmt (GhcPass _) GhcPs b = NoExtField type instance XTransStmt (GhcPass _) GhcRn b = NoExtField type instance XTransStmt (GhcPass _) GhcTc b = Type type instance XRecStmt (GhcPass _) GhcPs b = NoExtField type instance XRecStmt (GhcPass _) GhcRn b = NoExtField type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExtCon data TransForm -- The 'f' below is the 'using' function, 'e' is the by function = ThenForm -- then f or then f by e (depending on trS_by) | GroupForm -- then group using f or then group by e using f (depending on trS_by) deriving Data -- | Parenthesised Statement Block data ParStmtBlock idL idR = ParStmtBlock (XParStmtBlock idL idR) [ExprLStmt idL] [IdP idR] -- The variables to be returned (SyntaxExpr idR) -- The return operator | XParStmtBlock (XXParStmtBlock idL idR) type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtField type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon -- | Applicative Argument data ApplicativeArg idL = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) { xarg_app_arg_one :: (XApplicativeArgOne idL) , app_arg_pattern :: (LPat idL) -- WildPat if it was a BodyStmt (see below) , arg_expr :: (LHsExpr idL) , is_body_stmt :: Bool -- True <=> was a BodyStmt -- False <=> was a BindStmt -- See Note [Applicative BodyStmt] , fail_operator :: (SyntaxExpr idL) -- The fail operator -- The fail operator is needed if this is a BindStmt -- where the pattern can fail. E.g.: -- (Just a) <- stmt -- The fail operator will be invoked if the pattern -- match fails. -- The fail operator is noSyntaxExpr -- if the pattern match can't fail } | ApplicativeArgMany -- do { stmts; return vars } { xarg_app_arg_many :: (XApplicativeArgMany idL) , app_stmts :: [ExprLStmt idL] -- stmts , final_expr :: (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) , bv_pattern :: (LPat idL) -- (v1,...,vn) } | XApplicativeArg (XXApplicativeArg idL) type instance XApplicativeArgOne (GhcPass _) = NoExtField type instance XApplicativeArgMany (GhcPass _) = NoExtField type instance XXApplicativeArg (GhcPass _) = NoExtCon {- Note [The type of bind in Stmts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some Stmts, notably BindStmt, keep the (>>=) bind operator. We do NOT assume that it has type (>>=) :: m a -> (a -> m b) -> m b In some cases (see #303, #1537) it might have a more exotic type, such as (>>=) :: m i j a -> (a -> m j k b) -> m i k b So we must be careful not to make assumptions about the type. In particular, the monad may not be uniform throughout. Note [TransStmt binder map] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ The [(idR,idR)] in a TransStmt behaves as follows: * Before renaming: [] * After renaming: [ (x27,x27), ..., (z35,z35) ] These are the variables bound by the stmts to the left of the 'group' and used either in the 'by' clause, or in the stmts following the 'group' Each item is a pair of identical variables. * After typechecking: [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ] Each pair has the same unique, but different *types*. Note [BodyStmt] ~~~~~~~~~~~~~~~ BodyStmts are a bit tricky, because what they mean depends on the context. Consider the following contexts: A do expression of type (m res_ty) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * BodyStmt E any_ty: do { ....; E; ... } E :: m any_ty Translation: E >> ... A list comprehensions of type [elt_ty] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * BodyStmt E Bool: [ .. | .... E ] [ .. | ..., E, ... ] [ .. | .... | ..., E | ... ] E :: Bool Translation: if E then fail else ... A guard list, guarding a RHS of type rhs_ty ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * BodyStmt E BooParStmtBlockl: f x | ..., E, ... = ...rhs... E :: Bool Translation: if E then fail else ... A monad comprehension of type (m res_ty) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * BodyStmt E Bool: [ .. | .... E ] E :: Bool Translation: guard E >> ... Array comprehensions are handled like list comprehensions. Note [How RecStmt works] ~~~~~~~~~~~~~~~~~~~~~~~~ Example: HsDo [ BindStmt x ex , RecStmt { recS_rec_ids = [a, c] , recS_stmts = [ BindStmt b (return (a,c)) , LetStmt a = ...b... , BindStmt c ec ] , recS_later_ids = [a, b] , return (a b) ] Here, the RecStmt binds a,b,c; but - Only a,b are used in the stmts *following* the RecStmt, - Only a,c are used in the stmts *inside* the RecStmt *before* their bindings Why do we need *both* rec_ids and later_ids? For monads they could be combined into a single set of variables, but not for arrows. That follows from the types of the respective feedback operators: mfix :: MonadFix m => (a -> m a) -> m a loop :: ArrowLoop a => a (b,d) (c,d) -> a b c * For mfix, the 'a' covers the union of the later_ids and the rec_ids * For 'loop', 'c' is the later_ids and 'd' is the rec_ids Note [Typing a RecStmt] ~~~~~~~~~~~~~~~~~~~~~~~ A (RecStmt stmts) types as if you had written (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) -> do { stmts ; return (v1,..vn, r1, ..., rm) }) where v1..vn are the later_ids r1..rm are the rec_ids Note [Monad Comprehensions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Monad comprehensions require separate functions like 'return' and '>>=' for desugaring. These functions are stored in the statements used in monad comprehensions. For example, the 'return' of the 'LastStmt' expression is used to lift the body of the monad comprehension: [ body | stmts ] => stmts >>= \bndrs -> return body In transform and grouping statements ('then ..' and 'then group ..') the 'return' function is required for nested monad comprehensions, for example: [ body | stmts, then f, rest ] => f [ env | stmts ] >>= \bndrs -> [ body | rest ] BodyStmts require the 'Control.Monad.guard' function for boolean expressions: [ body | exp, stmts ] => guard exp >> [ body | stmts ] Parallel statements require the 'Control.Monad.Zip.mzip' function: [ body | stmts1 | stmts2 | .. ] => mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body In any other context than 'MonadComp', the fields for most of these 'SyntaxExpr's stay bottom. Note [Applicative BodyStmt] (#12143) For the purposes of ApplicativeDo, we treat any BodyStmt as if it was a BindStmt with a wildcard pattern. For example, do x <- A B return x is transformed as if it were do x <- A _ <- B return x so it transforms to (\(x,_) -> x) <$> A <*> B But we have to remember when we treat a BodyStmt like a BindStmt, because in error messages we want to emit the original syntax the user wrote, not our internal representation. So ApplicativeArgOne has a Bool flag that is True when the original statement was a BodyStmt, so that we can pretty-print it correctly. -} instance (Outputable (StmtLR idL idL (LHsExpr idL)), Outputable (XXParStmtBlock idL idR)) => Outputable (ParStmtBlock idL idR) where ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts ppr (XParStmtBlock x) = ppr x instance (OutputableBndrId pl, OutputableBndrId pr, Outputable body) => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where ppr stmt = pprStmt stmt pprStmt :: forall idL idR body . (OutputableBndrId idL, OutputableBndrId idR, Outputable body) => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc pprStmt (LastStmt _ expr ret_stripped _) = whenPprDebug (text "[last]") <+> (if ret_stripped then text "return" else empty) <+> ppr expr pprStmt (BindStmt _ pat expr _ _) = hsep [ppr pat, larrow, ppr expr] pprStmt (LetStmt _ (L _ binds)) = hsep [text "let", pprBinds binds] pprStmt (BodyStmt _ expr _ _) = ppr expr pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss)) pprStmt (TransStmt { trS_stmts = stmts, trS_by = by , trS_using = using, trS_form = form }) = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids , recS_later_ids = later_ids }) = text "rec" <+> vcat [ ppr_do_stmts segment , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids , text "later_ids=" <> ppr later_ids])] pprStmt (ApplicativeStmt _ args mb_join) = getPprStyle $ \style -> if userStyle style then pp_for_user else pp_debug where -- make all the Applicative stuff invisible in error messages by -- flattening the whole ApplicativeStmt nest back to a sequence -- of statements. pp_for_user = vcat $ concatMap flattenArg args -- ppr directly rather than transforming here, because we need to -- inject a "return" which is hard when we're polymorphic in the id -- type. flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc] flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args flattenStmt stmt = [ppr stmt] flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc] flattenArg (_, ApplicativeArgOne _ pat expr isBody _) | isBody = -- See Note [Applicative BodyStmt] [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr :: ExprStmt (GhcPass idL))] | otherwise = [ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr :: ExprStmt (GhcPass idL))] flattenArg (_, ApplicativeArgMany _ stmts _ _) = concatMap flattenStmt stmts flattenArg (_, XApplicativeArg nec) = noExtCon nec pp_debug = let ap_expr = sep (punctuate (text " |") (map pp_arg args)) in if isNothing mb_join then ap_expr else text "join" <+> parens ap_expr pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc pp_arg (_, applicativeArg) = ppr applicativeArg pprStmt (XStmtLR x) = ppr x instance (OutputableBndrId idL) => Outputable (ApplicativeArg (GhcPass idL)) where ppr = pprArg pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc pprArg (ApplicativeArgOne _ pat expr isBody _) | isBody = -- See Note [Applicative BodyStmt] ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr :: ExprStmt (GhcPass idL)) | otherwise = ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr :: ExprStmt (GhcPass idL)) pprArg (ApplicativeArgMany _ stmts return pat) = ppr pat <+> text "<-" <+> ppr (HsDo (panic "pprStmt") DoExpr (noLoc (stmts ++ [noLoc (LastStmt noExtField (noLoc return) False noSyntaxExpr)]))) pprArg (XApplicativeArg x) = ppr x pprTransformStmt :: (OutputableBndrId p) => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) -> Maybe (LHsExpr (GhcPass p)) -> SDoc pprTransformStmt bndrs using by = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs)) , nest 2 (ppr using) , nest 2 (pprBy by)] pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc pprTransStmt by using ThenForm = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)] pprTransStmt by using GroupForm = sep [ text "then group", nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] pprBy :: Outputable body => Maybe body -> SDoc pprBy Nothing = empty pprBy (Just e) = text "by" <+> ppr e pprDo :: (OutputableBndrId p, Outputable body) => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts pprDo MDoExpr stmts = text "mdo" <+> ppr_do_stmts stmts pprDo ListComp stmts = brackets $ pprComp stmts pprDo MonadComp stmts = brackets $ pprComp stmts pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body) => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc -- Print a bunch of do stmts ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) pprComp :: (OutputableBndrId p, Outputable body) => [LStmt (GhcPass p) body] -> SDoc pprComp quals -- Prints: body | qual1, ..., qualn | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals = if null initStmts -- If there are no statements in a list comprehension besides the last -- one, we simply treat it like a normal list. This does arise -- occasionally in code that GHC generates, e.g., in implementations of -- 'range' for derived 'Ix' instances for product datatypes with exactly -- one constructor (e.g., see #12583). then ppr body else hang (ppr body <+> vbar) 2 (pprQuals initStmts) | otherwise = pprPanic "pprComp" (pprQuals quals) pprQuals :: (OutputableBndrId p, Outputable body) => [LStmt (GhcPass p) body] -> SDoc -- Show list comprehension qualifiers separated by commas pprQuals quals = interpp'SP quals {- ************************************************************************ * * Template Haskell quotation brackets * * ************************************************************************ -} -- | Haskell Splice data HsSplice id = HsTypedSplice -- $$z or $$(f 4) (XTypedSplice id) SpliceDecoration -- Whether $$( ) variant found, for pretty printing (IdP id) -- A unique name to identify this splice point (LHsExpr id) -- See Note [Pending Splices] | HsUntypedSplice -- $z or $(f 4) (XUntypedSplice id) SpliceDecoration -- Whether $( ) variant found, for pretty printing (IdP id) -- A unique name to identify this splice point (LHsExpr id) -- See Note [Pending Splices] | HsQuasiQuote -- See Note [Quasi-quote overview] in TcSplice (XQuasiQuote id) (IdP id) -- Splice point (IdP id) -- Quoter SrcSpan -- The span of the enclosed string FastString -- The enclosed string -- AZ:TODO: use XSplice instead of HsSpliced | HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in -- RnSplice. -- This is the result of splicing a splice. It is produced by -- the renamer and consumed by the typechecker. It lives only -- between the two. (XSpliced id) ThModFinalizers -- TH finalizers produced by the splice. (HsSplicedThing id) -- The result of splicing | HsSplicedT DelayedSplice | XSplice (XXSplice id) -- Note [Trees that Grow] extension point type instance XTypedSplice (GhcPass _) = NoExtField type instance XUntypedSplice (GhcPass _) = NoExtField type instance XQuasiQuote (GhcPass _) = NoExtField type instance XSpliced (GhcPass _) = NoExtField type instance XXSplice (GhcPass _) = NoExtCon -- | A splice can appear with various decorations wrapped around it. This data -- type captures explicitly how it was originally written, for use in the pretty -- printer. data SpliceDecoration = HasParens -- ^ $( splice ) or $$( splice ) | HasDollar -- ^ $splice or $$splice | NoParens -- ^ bare splice deriving (Data, Eq, Show) instance Outputable SpliceDecoration where ppr x = text $ show x isTypedSplice :: HsSplice id -> Bool isTypedSplice (HsTypedSplice {}) = True isTypedSplice _ = False -- Quasi-quotes are untyped splices -- | Finalizers produced by a splice with -- 'Language.Haskell.TH.Syntax.addModFinalizer' -- -- See Note [Delaying modFinalizers in untyped splices] in RnSplice. For how -- this is used. -- newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] -- A Data instance which ignores the argument of 'ThModFinalizers'. instance Data ThModFinalizers where gunfold _ z _ = z $ ThModFinalizers [] toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] -- See Note [Running typed splices in the zonker] -- These are the arguments that are passed to `TcSplice.runTopSplice` data DelayedSplice = DelayedSplice TcLclEnv -- The local environment to run the splice in (LHsExpr GhcRn) -- The original renamed expression TcType -- The result type of running the splice, unzonked (LHsExpr GhcTcId) -- The typechecked expression to run and splice in the result -- A Data instance which ignores the argument of 'DelayedSplice'. instance Data DelayedSplice where gunfold _ _ _ = panic "DelayedSplice" toConstr a = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix dataTypeOf a = mkDataType "HsExpr.DelayedSplice" [toConstr a] -- | Haskell Spliced Thing -- -- Values that can result from running a splice. data HsSplicedThing id = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression | HsSplicedTy (HsType id) -- ^ Haskell Spliced Type | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern -- See Note [Pending Splices] type SplicePointName = Name -- | Pending Renamer Splice data PendingRnSplice = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn) data UntypedSpliceFlavour = UntypedExpSplice | UntypedPatSplice | UntypedTypeSplice | UntypedDeclSplice deriving Data -- | Pending Type-checker Splice data PendingTcSplice = PendingTcSplice SplicePointName (LHsExpr GhcTc) {- Note [Pending Splices] ~~~~~~~~~~~~~~~~~~~~~~ When we rename an untyped bracket, we name and lift out all the nested splices, so that when the typechecker hits the bracket, it can typecheck those nested splices without having to walk over the untyped bracket code. So for example [| f $(g x) |] looks like HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x))) which the renamer rewrites to HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x))) [PendingRnSplice UntypedExpSplice sn (g x)] * The 'sn' is the Name of the splice point, the SplicePointName * The PendingRnExpSplice gives the splice that splice-point name maps to; and the typechecker can now conveniently find these sub-expressions * The other copy of the splice, in the second argument of HsSpliceE in the renamed first arg of HsRnBracketOut is used only for pretty printing There are four varieties of pending splices generated by the renamer, distinguished by their UntypedSpliceFlavour * Pending expression splices (UntypedExpSplice), e.g., [|$(f x) + 2|] UntypedExpSplice is also used for * quasi-quotes, where the pending expression expands to $(quoter "...blah...") (see RnSplice.makePending, HsQuasiQuote case) * cross-stage lifting, where the pending expression expands to $(lift x) (see RnSplice.checkCrossStageLifting) * Pending pattern splices (UntypedPatSplice), e.g., [| \$(f x) -> x |] * Pending type splices (UntypedTypeSplice), e.g., [| f :: $(g x) |] * Pending declaration (UntypedDeclSplice), e.g., [| let $(f x) in ... |] There is a fifth variety of pending splice, which is generated by the type checker: * Pending *typed* expression splices, (PendingTcSplice), e.g., [||1 + $$(f 2)||] It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the output of the renamer. However, when pretty printing the output of the renamer, e.g., in a type error message, we *do not* want to print out the pending splices. In contrast, when pretty printing the output of the type checker, we *do* want to print the pending splices. So splitting them up seems to make sense, although I hate to add another constructor to HsExpr. -} instance OutputableBndrId p => Outputable (HsSplicedThing (GhcPass p)) where ppr (HsSplicedExpr e) = ppr_expr e ppr (HsSplicedTy t) = ppr t ppr (HsSplicedPat p) = ppr p instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where ppr s = pprSplice s pprPendingSplice :: (OutputableBndrId p) => SplicePointName -> LHsExpr (GhcPass p) -> SDoc pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) pprSpliceDecl :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")" pprSpliceDecl e ImplicitSplice = ppr_splice_decl e ppr_splice_decl :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty ppr_splice_decl e = pprSplice e pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc pprSplice (HsTypedSplice _ HasParens n e) = ppr_splice (text "$$(") n e (text ")") pprSplice (HsTypedSplice _ HasDollar n e) = ppr_splice (text "$$") n e empty pprSplice (HsTypedSplice _ NoParens n e) = ppr_splice empty n e empty pprSplice (HsUntypedSplice _ HasParens n e) = ppr_splice (text "$(") n e (text ")") pprSplice (HsUntypedSplice _ HasDollar n e) = ppr_splice (text "$") n e empty pprSplice (HsUntypedSplice _ NoParens n e) = ppr_splice empty n e empty pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s pprSplice (HsSpliced _ _ thing) = ppr thing pprSplice (HsSplicedT {}) = text "Unevaluated typed splice" pprSplice (XSplice x) = ppr x ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> char '[' <> ppr quoter <> vbar <> ppr quote <> text "|]" ppr_splice :: (OutputableBndrId p) => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc ppr_splice herald n e trail = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail -- | Haskell Bracket data HsBracket p = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |] | PatBr (XPatBr p) (LPat p) -- [p| pat |] | DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser | DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer | TypBr (XTypBr p) (LHsType p) -- [t| type |] | VarBr (XVarBr p) Bool (IdP p) -- True: 'x, False: ''T -- (The Bool flag is used only in pprHsBracket) | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||] | XBracket (XXBracket p) -- Note [Trees that Grow] extension point type instance XExpBr (GhcPass _) = NoExtField type instance XPatBr (GhcPass _) = NoExtField type instance XDecBrL (GhcPass _) = NoExtField type instance XDecBrG (GhcPass _) = NoExtField type instance XTypBr (GhcPass _) = NoExtField type instance XVarBr (GhcPass _) = NoExtField type instance XTExpBr (GhcPass _) = NoExtField type instance XXBracket (GhcPass _) = NoExtCon isTypedBracket :: HsBracket id -> Bool isTypedBracket (TExpBr {}) = True isTypedBracket _ = False instance OutputableBndrId p => Outputable (HsBracket (GhcPass p)) where ppr = pprHsBracket pprHsBracket :: (OutputableBndrId p) => HsBracket (GhcPass p) -> SDoc pprHsBracket (ExpBr _ e) = thBrackets empty (ppr e) pprHsBracket (PatBr _ p) = thBrackets (char 'p') (ppr p) pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp) pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds)) pprHsBracket (TypBr _ t) = thBrackets (char 't') (ppr t) pprHsBracket (VarBr _ True n) = char '\'' <> pprPrefixOcc n pprHsBracket (VarBr _ False n) = text "''" <> pprPrefixOcc n pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e) pprHsBracket (XBracket e) = ppr e thBrackets :: SDoc -> SDoc -> SDoc thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> pp_body <+> text "|]" thTyBrackets :: SDoc -> SDoc thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]") instance Outputable PendingRnSplice where ppr (PendingRnSplice _ n e) = pprPendingSplice n e instance Outputable PendingTcSplice where ppr (PendingTcSplice n e) = pprPendingSplice n e {- ************************************************************************ * * \subsection{Enumerations and list comprehensions} * * ************************************************************************ -} -- | Arithmetic Sequence Information data ArithSeqInfo id = From (LHsExpr id) | FromThen (LHsExpr id) (LHsExpr id) | FromTo (LHsExpr id) (LHsExpr id) | FromThenTo (LHsExpr id) (LHsExpr id) (LHsExpr id) -- AZ: Sould ArithSeqInfo have a TTG extension? instance OutputableBndrId p => Outputable (ArithSeqInfo (GhcPass p)) where ppr (From e1) = hcat [ppr e1, pp_dotdot] ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] ppr (FromThenTo e1 e2 e3) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] pp_dotdot :: SDoc pp_dotdot = text " .. " {- ************************************************************************ * * \subsection{HsMatchCtxt} * * ************************************************************************ -} -- | Haskell Match Context -- -- Context of a pattern match. This is more subtle than it would seem. See Note -- [Varieties of pattern matches]. data HsMatchContext id -- Not an extensible tag = FunRhs { mc_fun :: Located id -- ^ function binder of @f@ , mc_fixity :: LexicalFixity -- ^ fixing of @f@ , mc_strictness :: SrcStrictness -- ^ was @f@ banged? -- See Note [FunBind vs PatBind] } -- ^A pattern matching on an argument of a -- function binding | LambdaExpr -- ^Patterns of a lambda | CaseAlt -- ^Patterns and guards on a case alternative | IfAlt -- ^Guards of a multi-way if alternative | ProcExpr -- ^Patterns of a proc | PatBindRhs -- ^A pattern binding eg [y] <- e = e | PatBindGuards -- ^Guards of pattern bindings, e.g., -- (Just b) | Just _ <- x = e -- | otherwise = e' | RecUpd -- ^Record update [used only in DsExpr to -- tell matchWrapper what sort of -- runtime error message to generate] | StmtCtxt (HsStmtContext id) -- ^Pattern of a do-stmt, list comprehension, -- pattern guard, etc | ThPatSplice -- ^A Template Haskell pattern splice | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] | PatSyn -- ^A pattern synonym declaration deriving Functor deriving instance (Data id) => Data (HsMatchContext id) instance OutputableBndr id => Outputable (HsMatchContext id) where ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m) ppr LambdaExpr = text "LambdaExpr" ppr CaseAlt = text "CaseAlt" ppr IfAlt = text "IfAlt" ppr ProcExpr = text "ProcExpr" ppr PatBindRhs = text "PatBindRhs" ppr PatBindGuards = text "PatBindGuards" ppr RecUpd = text "RecUpd" ppr (StmtCtxt _) = text "StmtCtxt _" ppr ThPatSplice = text "ThPatSplice" ppr ThPatQuote = text "ThPatQuote" ppr PatSyn = text "PatSyn" isPatSynCtxt :: HsMatchContext id -> Bool isPatSynCtxt ctxt = case ctxt of PatSyn -> True _ -> False -- | Haskell Statement Context. It expects to be parameterised with one of -- 'RdrName', 'Name' or 'Id' data HsStmtContext id = ListComp | MonadComp | DoExpr -- ^do { ... } | MDoExpr -- ^mdo { ... } ie recursive do-expression | ArrowExpr -- ^do-notation in an arrow-command context | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs | PatGuard (HsMatchContext id) -- ^Pattern guard for specified thing | ParStmtCtxt (HsStmtContext id) -- ^A branch of a parallel stmt | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt deriving Functor deriving instance (Data id) => Data (HsStmtContext id) isComprehensionContext :: HsStmtContext id -> Bool -- Uses comprehension syntax [ e | quals ] isComprehensionContext ListComp = True isComprehensionContext MonadComp = True isComprehensionContext (ParStmtCtxt c) = isComprehensionContext c isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c isComprehensionContext _ = False -- | Should pattern match failure in a 'HsStmtContext' be desugared using -- 'MonadFail'? isMonadFailStmtContext :: HsStmtContext id -> Bool isMonadFailStmtContext MonadComp = True isMonadFailStmtContext DoExpr = True isMonadFailStmtContext MDoExpr = True isMonadFailStmtContext GhciStmtCtxt = True isMonadFailStmtContext (ParStmtCtxt ctxt) = isMonadFailStmtContext ctxt isMonadFailStmtContext (TransStmtCtxt ctxt) = isMonadFailStmtContext ctxt isMonadFailStmtContext _ = False -- ListComp, PatGuard, ArrowExpr isMonadCompContext :: HsStmtContext id -> Bool isMonadCompContext MonadComp = True isMonadCompContext _ = False matchSeparator :: HsMatchContext id -> SDoc matchSeparator (FunRhs {}) = text "=" matchSeparator CaseAlt = text "->" matchSeparator IfAlt = text "->" matchSeparator LambdaExpr = text "->" matchSeparator ProcExpr = text "->" matchSeparator PatBindRhs = text "=" matchSeparator PatBindGuards = text "=" matchSeparator (StmtCtxt _) = text "<-" matchSeparator RecUpd = text "=" -- This can be printed by the pattern -- match checker trace matchSeparator ThPatSplice = panic "unused" matchSeparator ThPatQuote = panic "unused" matchSeparator PatSyn = panic "unused" pprMatchContext :: (Outputable (NameOrRdrName id),Outputable id) => HsMatchContext id -> SDoc pprMatchContext ctxt | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt | otherwise = text "a" <+> pprMatchContextNoun ctxt where want_an (FunRhs {}) = True -- Use "an" in front want_an ProcExpr = True want_an _ = False pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id) => HsMatchContext id -> SDoc pprMatchContextNoun (FunRhs {mc_fun=L _ fun}) = text "equation for" <+> quotes (ppr fun) pprMatchContextNoun CaseAlt = text "case alternative" pprMatchContextNoun IfAlt = text "multi-way if alternative" pprMatchContextNoun RecUpd = text "record-update construct" pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice" pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation" pprMatchContextNoun PatBindRhs = text "pattern binding" pprMatchContextNoun PatBindGuards = text "pattern binding guards" pprMatchContextNoun LambdaExpr = text "lambda abstraction" pprMatchContextNoun ProcExpr = text "arrow abstraction" pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" $$ pprAStmtContext ctxt pprMatchContextNoun PatSyn = text "pattern synonym declaration" ----------------- pprAStmtContext, pprStmtContext :: (Outputable id, Outputable (NameOrRdrName id)) => HsStmtContext id -> SDoc pprAStmtContext ctxt = article <+> pprStmtContext ctxt where pp_an = text "an" pp_a = text "a" article = case ctxt of MDoExpr -> pp_an GhciStmtCtxt -> pp_an _ -> pp_a ----------------- pprStmtContext GhciStmtCtxt = text "interactive GHCi command" pprStmtContext DoExpr = text "'do' block" pprStmtContext MDoExpr = text "'mdo' block" pprStmtContext ArrowExpr = text "'do' block in an arrow command" pprStmtContext ListComp = text "list comprehension" pprStmtContext MonadComp = text "monad comprehension" pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt -- Drop the inner contexts when reporting errors, else we get -- Unexpected transform statement -- in a transformed branch of -- transformed branch of -- transformed branch of monad comprehension pprStmtContext (ParStmtCtxt c) = ifPprDebug (sep [text "parallel branch of", pprAStmtContext c]) (pprStmtContext c) pprStmtContext (TransStmtCtxt c) = ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) (pprStmtContext c) instance (Outputable (GhcPass p), Outputable (NameOrRdrName (GhcPass p))) => Outputable (HsStmtContext (GhcPass p)) where ppr = pprStmtContext -- Used to generate the string for a *runtime* error message matchContextErrString :: Outputable id => HsMatchContext id -> SDoc matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun matchContextErrString CaseAlt = text "case" matchContextErrString IfAlt = text "multi-way if" matchContextErrString PatBindRhs = text "pattern binding" matchContextErrString PatBindGuards = text "pattern binding guards" matchContextErrString RecUpd = text "record update" matchContextErrString LambdaExpr = text "lambda" matchContextErrString ProcExpr = text "proc" matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard" matchContextErrString (StmtCtxt GhciStmtCtxt) = text "interactive GHCi command" matchContextErrString (StmtCtxt DoExpr) = text "'do' block" matchContextErrString (StmtCtxt ArrowExpr) = text "'do' block" matchContextErrString (StmtCtxt MDoExpr) = text "'mdo' block" matchContextErrString (StmtCtxt ListComp) = text "list comprehension" matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" pprMatchInCtxt :: (OutputableBndrId idR, -- TODO:AZ these constraints do not make sense Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))), Outputable body) => Match (GhcPass idR) body -> SDoc pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) <> colon) 4 (pprMatch match) pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body) => HsStmtContext (IdP (GhcPass idL)) -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc pprStmtInCtxt ctxt (LastStmt _ e _ _) | isComprehensionContext ctxt -- For [ e | .. ], do not mutter about "stmts" = hang (text "In the expression:") 2 (ppr e) pprStmtInCtxt ctxt stmt = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon) 2 (ppr_stmt stmt) where -- For Group and Transform Stmts, don't print the nested stmts! ppr_stmt (TransStmt { trS_by = by, trS_using = using , trS_form = form }) = pprTransStmt by using form ppr_stmt stmt = pprStmt stmt ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/Extension.hs0000644000000000000000000010236613713635744020613 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder module GHC.Hs.Extension where -- This module captures the type families to precisely identify the extension -- points for GHC.Hs syntax import GhcPrelude import Data.Data hiding ( Fixity ) import GHC.Hs.PlaceHolder import Name import RdrName import Var import Outputable import SrcLoc (Located) import Data.Kind {- Note [Trees that grow] ~~~~~~~~~~~~~~~~~~~~~~ See https://gitlab.haskell.org/ghc/ghc/wikis/implementing-trees-that-grow The hsSyn AST is reused across multiple compiler passes. We also have the Template Haskell AST, and the haskell-src-exts one (outside of GHC) Supporting multiple passes means the AST has various warts on it to cope with the specifics for the phases, such as the 'ValBindsOut', 'ConPatOut', 'SigPatOut' etc. The growable AST will allow each of these variants to be captured explicitly, such that they only exist in the given compiler pass AST, as selected by the type parameter to the AST. In addition it will allow tool writers to define their own extensions to capture additional information for the tool, in a natural way. A further goal is to provide a means to harmonise the Template Haskell and haskell-src-exts ASTs as well. -} -- | A placeholder type for TTG extension points that are not currently -- unused to represent any particular value. -- -- This should not be confused with 'NoExtCon', which are found in unused -- extension /constructors/ and therefore should never be inhabited. In -- contrast, 'NoExtField' is used in extension /points/ (e.g., as the field of -- some constructor), so it must have an inhabitant to construct AST passes -- that manipulate fields with that extension point as their type. data NoExtField = NoExtField deriving (Data,Eq,Ord) instance Outputable NoExtField where ppr _ = text "NoExtField" -- | Used when constructing a term with an unused extension point. noExtField :: NoExtField noExtField = NoExtField -- | Used in TTG extension constructors that have yet to be extended with -- anything. If an extension constructor has 'NoExtCon' as its field, it is -- not intended to ever be constructed anywhere, and any function that consumes -- the extension constructor can eliminate it by way of 'noExtCon'. -- -- This should not be confused with 'NoExtField', which are found in unused -- extension /points/ (not /constructors/) and therefore can be inhabited. -- See also [NoExtCon and strict fields]. data NoExtCon deriving (Data,Eq,Ord) instance Outputable NoExtCon where ppr = noExtCon -- | Eliminate a 'NoExtCon'. Much like 'Data.Void.absurd'. noExtCon :: NoExtCon -> a noExtCon x = case x of {} {- Note [NoExtCon and strict fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Currently, any unused TTG extension constructor will generally look like the following: type instance XXHsDecl (GhcPass _) = NoExtCon data HsDecl p = ... | XHsDecl (XXHsDecl p) This means that any function that wishes to consume an HsDecl will need to have a case for XHsDecl. This might look like this: ex :: HsDecl GhcPs -> HsDecl GhcRn ... ex (XHsDecl nec) = noExtCon nec Ideally, we wouldn't need a case for XHsDecl at all (it /is/ supposed to be an unused extension constructor, after all). There is a way to achieve this on GHC 8.8 or later: make the field of XHsDecl strict: data HsDecl p = ... | XHsDecl !(XXHsDecl p) If this is done, GHC's pattern-match coverage checker is clever enough to figure out that the XHsDecl case of `ex` is unreachable, so it can simply be omitted. (See Note [Extensions to GADTs Meet Their Match] in Check for more on how this works.) When GHC drops support for bootstrapping with GHC 8.6 and earlier, we can make the strict field changes described above and delete gobs of code involving `noExtCon`. Until then, it is necessary to use, so be aware of it when writing code that consumes unused extension constructors. -} -- | Used as a data type index for the hsSyn AST data GhcPass (c :: Pass) deriving instance Eq (GhcPass c) deriving instance Typeable c => Data (GhcPass c) data Pass = Parsed | Renamed | Typechecked deriving (Data) -- Type synonyms as a shorthand for tagging type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param type GhcRn = GhcPass 'Renamed -- Old 'Name' type param type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, type GhcTcId = GhcTc -- Old 'TcId' type param -- | GHC's L prefixed variants wrap their vanilla variant in this type family, -- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not -- interested in location information can define this instance as @f p@. type family XRec p (f :: * -> *) = r | r -> p f type instance XRec (GhcPass p) f = Located (f (GhcPass p)) -- | Maps the "normal" id type for a given pass type family IdP p type instance IdP GhcPs = RdrName type instance IdP GhcRn = Name type instance IdP GhcTc = Id type LIdP p = Located (IdP p) -- | Marks that a field uses the GhcRn variant even when the pass -- parameter is GhcTc. Useful for storing HsTypes in GHC.Hs.Exprs, say, because -- HsType GhcTc should never occur. type family NoGhcTc (p :: Type) where -- this way, GHC can figure out that the result is a GhcPass NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass) NoGhcTc other = other type family NoGhcTcPass (p :: Pass) :: Pass where NoGhcTcPass 'Typechecked = 'Renamed NoGhcTcPass other = other -- ===================================================================== -- Type families for the HsBinds extension points -- HsLocalBindsLR type families type family XHsValBinds x x' type family XHsIPBinds x x' type family XEmptyLocalBinds x x' type family XXHsLocalBindsLR x x' type ForallXHsLocalBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = ( c (XHsValBinds x x') , c (XHsIPBinds x x') , c (XEmptyLocalBinds x x') , c (XXHsLocalBindsLR x x') ) -- ValBindsLR type families type family XValBinds x x' type family XXValBindsLR x x' type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = ( c (XValBinds x x') , c (XXValBindsLR x x') ) -- HsBindsLR type families type family XFunBind x x' type family XPatBind x x' type family XVarBind x x' type family XAbsBinds x x' type family XPatSynBind x x' type family XXHsBindsLR x x' type ForallXHsBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = ( c (XFunBind x x') , c (XPatBind x x') , c (XVarBind x x') , c (XAbsBinds x x') , c (XPatSynBind x x') , c (XXHsBindsLR x x') ) -- ABExport type families type family XABE x type family XXABExport x type ForallXABExport (c :: * -> Constraint) (x :: *) = ( c (XABE x) , c (XXABExport x) ) -- PatSynBind type families type family XPSB x x' type family XXPatSynBind x x' type ForallXPatSynBind (c :: * -> Constraint) (x :: *) (x' :: *) = ( c (XPSB x x') , c (XXPatSynBind x x') ) -- HsIPBinds type families type family XIPBinds x type family XXHsIPBinds x type ForallXHsIPBinds (c :: * -> Constraint) (x :: *) = ( c (XIPBinds x) , c (XXHsIPBinds x) ) -- IPBind type families type family XCIPBind x type family XXIPBind x type ForallXIPBind (c :: * -> Constraint) (x :: *) = ( c (XCIPBind x) , c (XXIPBind x) ) -- Sig type families type family XTypeSig x type family XPatSynSig x type family XClassOpSig x type family XIdSig x type family XFixSig x type family XInlineSig x type family XSpecSig x type family XSpecInstSig x type family XMinimalSig x type family XSCCFunSig x type family XCompleteMatchSig x type family XXSig x type ForallXSig (c :: * -> Constraint) (x :: *) = ( c (XTypeSig x) , c (XPatSynSig x) , c (XClassOpSig x) , c (XIdSig x) , c (XFixSig x) , c (XInlineSig x) , c (XSpecSig x) , c (XSpecInstSig x) , c (XMinimalSig x) , c (XSCCFunSig x) , c (XCompleteMatchSig x) , c (XXSig x) ) -- FixitySig type families type family XFixitySig x type family XXFixitySig x type ForallXFixitySig (c :: * -> Constraint) (x :: *) = ( c (XFixitySig x) , c (XXFixitySig x) ) -- StandaloneKindSig type families type family XStandaloneKindSig x type family XXStandaloneKindSig x -- ===================================================================== -- Type families for the HsDecls extension points -- HsDecl type families type family XTyClD x type family XInstD x type family XDerivD x type family XValD x type family XSigD x type family XKindSigD x type family XDefD x type family XForD x type family XWarningD x type family XAnnD x type family XRuleD x type family XSpliceD x type family XDocD x type family XRoleAnnotD x type family XXHsDecl x type ForallXHsDecl (c :: * -> Constraint) (x :: *) = ( c (XTyClD x) , c (XInstD x) , c (XDerivD x) , c (XValD x) , c (XSigD x) , c (XKindSigD x) , c (XDefD x) , c (XForD x) , c (XWarningD x) , c (XAnnD x) , c (XRuleD x) , c (XSpliceD x) , c (XDocD x) , c (XRoleAnnotD x) , c (XXHsDecl x) ) -- ------------------------------------- -- HsGroup type families type family XCHsGroup x type family XXHsGroup x type ForallXHsGroup (c :: * -> Constraint) (x :: *) = ( c (XCHsGroup x) , c (XXHsGroup x) ) -- ------------------------------------- -- SpliceDecl type families type family XSpliceDecl x type family XXSpliceDecl x type ForallXSpliceDecl (c :: * -> Constraint) (x :: *) = ( c (XSpliceDecl x) , c (XXSpliceDecl x) ) -- ------------------------------------- -- TyClDecl type families type family XFamDecl x type family XSynDecl x type family XDataDecl x type family XClassDecl x type family XXTyClDecl x type ForallXTyClDecl (c :: * -> Constraint) (x :: *) = ( c (XFamDecl x) , c (XSynDecl x) , c (XDataDecl x) , c (XClassDecl x) , c (XXTyClDecl x) ) -- ------------------------------------- -- TyClGroup type families type family XCTyClGroup x type family XXTyClGroup x type ForallXTyClGroup (c :: * -> Constraint) (x :: *) = ( c (XCTyClGroup x) , c (XXTyClGroup x) ) -- ------------------------------------- -- FamilyResultSig type families type family XNoSig x type family XCKindSig x -- Clashes with XKindSig above type family XTyVarSig x type family XXFamilyResultSig x type ForallXFamilyResultSig (c :: * -> Constraint) (x :: *) = ( c (XNoSig x) , c (XCKindSig x) , c (XTyVarSig x) , c (XXFamilyResultSig x) ) -- ------------------------------------- -- FamilyDecl type families type family XCFamilyDecl x type family XXFamilyDecl x type ForallXFamilyDecl (c :: * -> Constraint) (x :: *) = ( c (XCFamilyDecl x) , c (XXFamilyDecl x) ) -- ------------------------------------- -- HsDataDefn type families type family XCHsDataDefn x type family XXHsDataDefn x type ForallXHsDataDefn (c :: * -> Constraint) (x :: *) = ( c (XCHsDataDefn x) , c (XXHsDataDefn x) ) -- ------------------------------------- -- HsDerivingClause type families type family XCHsDerivingClause x type family XXHsDerivingClause x type ForallXHsDerivingClause (c :: * -> Constraint) (x :: *) = ( c (XCHsDerivingClause x) , c (XXHsDerivingClause x) ) -- ------------------------------------- -- ConDecl type families type family XConDeclGADT x type family XConDeclH98 x type family XXConDecl x type ForallXConDecl (c :: * -> Constraint) (x :: *) = ( c (XConDeclGADT x) , c (XConDeclH98 x) , c (XXConDecl x) ) -- ------------------------------------- -- FamEqn type families type family XCFamEqn x r type family XXFamEqn x r type ForallXFamEqn (c :: * -> Constraint) (x :: *) (r :: *) = ( c (XCFamEqn x r) , c (XXFamEqn x r) ) -- ------------------------------------- -- ClsInstDecl type families type family XCClsInstDecl x type family XXClsInstDecl x type ForallXClsInstDecl (c :: * -> Constraint) (x :: *) = ( c (XCClsInstDecl x) , c (XXClsInstDecl x) ) -- ------------------------------------- -- ClsInstDecl type families type family XClsInstD x type family XDataFamInstD x type family XTyFamInstD x type family XXInstDecl x type ForallXInstDecl (c :: * -> Constraint) (x :: *) = ( c (XClsInstD x) , c (XDataFamInstD x) , c (XTyFamInstD x) , c (XXInstDecl x) ) -- ------------------------------------- -- DerivDecl type families type family XCDerivDecl x type family XXDerivDecl x type ForallXDerivDecl (c :: * -> Constraint) (x :: *) = ( c (XCDerivDecl x) , c (XXDerivDecl x) ) -- ------------------------------------- -- DerivStrategy type family type family XViaStrategy x -- ------------------------------------- -- DefaultDecl type families type family XCDefaultDecl x type family XXDefaultDecl x type ForallXDefaultDecl (c :: * -> Constraint) (x :: *) = ( c (XCDefaultDecl x) , c (XXDefaultDecl x) ) -- ------------------------------------- -- DefaultDecl type families type family XForeignImport x type family XForeignExport x type family XXForeignDecl x type ForallXForeignDecl (c :: * -> Constraint) (x :: *) = ( c (XForeignImport x) , c (XForeignExport x) , c (XXForeignDecl x) ) -- ------------------------------------- -- RuleDecls type families type family XCRuleDecls x type family XXRuleDecls x type ForallXRuleDecls (c :: * -> Constraint) (x :: *) = ( c (XCRuleDecls x) , c (XXRuleDecls x) ) -- ------------------------------------- -- RuleDecl type families type family XHsRule x type family XXRuleDecl x type ForallXRuleDecl (c :: * -> Constraint) (x :: *) = ( c (XHsRule x) , c (XXRuleDecl x) ) -- ------------------------------------- -- RuleBndr type families type family XCRuleBndr x type family XRuleBndrSig x type family XXRuleBndr x type ForallXRuleBndr (c :: * -> Constraint) (x :: *) = ( c (XCRuleBndr x) , c (XRuleBndrSig x) , c (XXRuleBndr x) ) -- ------------------------------------- -- WarnDecls type families type family XWarnings x type family XXWarnDecls x type ForallXWarnDecls (c :: * -> Constraint) (x :: *) = ( c (XWarnings x) , c (XXWarnDecls x) ) -- ------------------------------------- -- AnnDecl type families type family XWarning x type family XXWarnDecl x type ForallXWarnDecl (c :: * -> Constraint) (x :: *) = ( c (XWarning x) , c (XXWarnDecl x) ) -- ------------------------------------- -- AnnDecl type families type family XHsAnnotation x type family XXAnnDecl x type ForallXAnnDecl (c :: * -> Constraint) (x :: *) = ( c (XHsAnnotation x) , c (XXAnnDecl x) ) -- ------------------------------------- -- RoleAnnotDecl type families type family XCRoleAnnotDecl x type family XXRoleAnnotDecl x type ForallXRoleAnnotDecl (c :: * -> Constraint) (x :: *) = ( c (XCRoleAnnotDecl x) , c (XXRoleAnnotDecl x) ) -- ===================================================================== -- Type families for the HsExpr extension points type family XVar x type family XUnboundVar x type family XConLikeOut x type family XRecFld x type family XOverLabel x type family XIPVar x type family XOverLitE x type family XLitE x type family XLam x type family XLamCase x type family XApp x type family XAppTypeE x type family XOpApp x type family XNegApp x type family XPar x type family XSectionL x type family XSectionR x type family XExplicitTuple x type family XExplicitSum x type family XCase x type family XIf x type family XMultiIf x type family XLet x type family XDo x type family XExplicitList x type family XRecordCon x type family XRecordUpd x type family XExprWithTySig x type family XArithSeq x type family XSCC x type family XCoreAnn x type family XBracket x type family XRnBracketOut x type family XTcBracketOut x type family XSpliceE x type family XProc x type family XStatic x type family XTick x type family XBinTick x type family XTickPragma x type family XWrap x type family XXExpr x type ForallXExpr (c :: * -> Constraint) (x :: *) = ( c (XVar x) , c (XUnboundVar x) , c (XConLikeOut x) , c (XRecFld x) , c (XOverLabel x) , c (XIPVar x) , c (XOverLitE x) , c (XLitE x) , c (XLam x) , c (XLamCase x) , c (XApp x) , c (XAppTypeE x) , c (XOpApp x) , c (XNegApp x) , c (XPar x) , c (XSectionL x) , c (XSectionR x) , c (XExplicitTuple x) , c (XExplicitSum x) , c (XCase x) , c (XIf x) , c (XMultiIf x) , c (XLet x) , c (XDo x) , c (XExplicitList x) , c (XRecordCon x) , c (XRecordUpd x) , c (XExprWithTySig x) , c (XArithSeq x) , c (XSCC x) , c (XCoreAnn x) , c (XBracket x) , c (XRnBracketOut x) , c (XTcBracketOut x) , c (XSpliceE x) , c (XProc x) , c (XStatic x) , c (XTick x) , c (XBinTick x) , c (XTickPragma x) , c (XWrap x) , c (XXExpr x) ) -- --------------------------------------------------------------------- type family XUnambiguous x type family XAmbiguous x type family XXAmbiguousFieldOcc x type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) = ( c (XUnambiguous x) , c (XAmbiguous x) , c (XXAmbiguousFieldOcc x) ) -- ---------------------------------------------------------------------- type family XPresent x type family XMissing x type family XXTupArg x type ForallXTupArg (c :: * -> Constraint) (x :: *) = ( c (XPresent x) , c (XMissing x) , c (XXTupArg x) ) -- --------------------------------------------------------------------- type family XTypedSplice x type family XUntypedSplice x type family XQuasiQuote x type family XSpliced x type family XXSplice x type ForallXSplice (c :: * -> Constraint) (x :: *) = ( c (XTypedSplice x) , c (XUntypedSplice x) , c (XQuasiQuote x) , c (XSpliced x) , c (XXSplice x) ) -- --------------------------------------------------------------------- type family XExpBr x type family XPatBr x type family XDecBrL x type family XDecBrG x type family XTypBr x type family XVarBr x type family XTExpBr x type family XXBracket x type ForallXBracket (c :: * -> Constraint) (x :: *) = ( c (XExpBr x) , c (XPatBr x) , c (XDecBrL x) , c (XDecBrG x) , c (XTypBr x) , c (XVarBr x) , c (XTExpBr x) , c (XXBracket x) ) -- --------------------------------------------------------------------- type family XCmdTop x type family XXCmdTop x type ForallXCmdTop (c :: * -> Constraint) (x :: *) = ( c (XCmdTop x) , c (XXCmdTop x) ) -- ------------------------------------- type family XMG x b type family XXMatchGroup x b type ForallXMatchGroup (c :: * -> Constraint) (x :: *) (b :: *) = ( c (XMG x b) , c (XXMatchGroup x b) ) -- ------------------------------------- type family XCMatch x b type family XXMatch x b type ForallXMatch (c :: * -> Constraint) (x :: *) (b :: *) = ( c (XCMatch x b) , c (XXMatch x b) ) -- ------------------------------------- type family XCGRHSs x b type family XXGRHSs x b type ForallXGRHSs (c :: * -> Constraint) (x :: *) (b :: *) = ( c (XCGRHSs x b) , c (XXGRHSs x b) ) -- ------------------------------------- type family XCGRHS x b type family XXGRHS x b type ForallXGRHS (c :: * -> Constraint) (x :: *) (b :: *) = ( c (XCGRHS x b) , c (XXGRHS x b) ) -- ------------------------------------- type family XLastStmt x x' b type family XBindStmt x x' b type family XApplicativeStmt x x' b type family XBodyStmt x x' b type family XLetStmt x x' b type family XParStmt x x' b type family XTransStmt x x' b type family XRecStmt x x' b type family XXStmtLR x x' b type ForallXStmtLR (c :: * -> Constraint) (x :: *) (x' :: *) (b :: *) = ( c (XLastStmt x x' b) , c (XBindStmt x x' b) , c (XApplicativeStmt x x' b) , c (XBodyStmt x x' b) , c (XLetStmt x x' b) , c (XParStmt x x' b) , c (XTransStmt x x' b) , c (XRecStmt x x' b) , c (XXStmtLR x x' b) ) -- --------------------------------------------------------------------- type family XCmdArrApp x type family XCmdArrForm x type family XCmdApp x type family XCmdLam x type family XCmdPar x type family XCmdCase x type family XCmdIf x type family XCmdLet x type family XCmdDo x type family XCmdWrap x type family XXCmd x type ForallXCmd (c :: * -> Constraint) (x :: *) = ( c (XCmdArrApp x) , c (XCmdArrForm x) , c (XCmdApp x) , c (XCmdLam x) , c (XCmdPar x) , c (XCmdCase x) , c (XCmdIf x) , c (XCmdLet x) , c (XCmdDo x) , c (XCmdWrap x) , c (XXCmd x) ) -- --------------------------------------------------------------------- type family XParStmtBlock x x' type family XXParStmtBlock x x' type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) = ( c (XParStmtBlock x x') , c (XXParStmtBlock x x') ) -- --------------------------------------------------------------------- type family XApplicativeArgOne x type family XApplicativeArgMany x type family XXApplicativeArg x type ForallXApplicativeArg (c :: * -> Constraint) (x :: *) = ( c (XApplicativeArgOne x) , c (XApplicativeArgMany x) , c (XXApplicativeArg x) ) -- ===================================================================== -- Type families for the HsImpExp extension points -- TODO -- ===================================================================== -- Type families for the HsLit extension points -- We define a type family for each extension point. This is based on prepending -- 'X' to the constructor name, for ease of reference. type family XHsChar x type family XHsCharPrim x type family XHsString x type family XHsStringPrim x type family XHsInt x type family XHsIntPrim x type family XHsWordPrim x type family XHsInt64Prim x type family XHsWord64Prim x type family XHsInteger x type family XHsRat x type family XHsFloatPrim x type family XHsDoublePrim x type family XXLit x -- | Helper to apply a constraint to all extension points. It has one -- entry per extension point type family. type ForallXHsLit (c :: * -> Constraint) (x :: *) = ( c (XHsChar x) , c (XHsCharPrim x) , c (XHsDoublePrim x) , c (XHsFloatPrim x) , c (XHsInt x) , c (XHsInt64Prim x) , c (XHsIntPrim x) , c (XHsInteger x) , c (XHsRat x) , c (XHsString x) , c (XHsStringPrim x) , c (XHsWord64Prim x) , c (XHsWordPrim x) , c (XXLit x) ) type family XOverLit x type family XXOverLit x type ForallXOverLit (c :: * -> Constraint) (x :: *) = ( c (XOverLit x) , c (XXOverLit x) ) -- ===================================================================== -- Type families for the HsPat extension points type family XWildPat x type family XVarPat x type family XLazyPat x type family XAsPat x type family XParPat x type family XBangPat x type family XListPat x type family XTuplePat x type family XSumPat x type family XConPat x type family XViewPat x type family XSplicePat x type family XLitPat x type family XNPat x type family XNPlusKPat x type family XSigPat x type family XCoPat x type family XXPat x type ForallXPat (c :: * -> Constraint) (x :: *) = ( c (XWildPat x) , c (XVarPat x) , c (XLazyPat x) , c (XAsPat x) , c (XParPat x) , c (XBangPat x) , c (XListPat x) , c (XTuplePat x) , c (XSumPat x) , c (XViewPat x) , c (XSplicePat x) , c (XLitPat x) , c (XNPat x) , c (XNPlusKPat x) , c (XSigPat x) , c (XCoPat x) , c (XXPat x) ) -- ===================================================================== -- Type families for the HsTypes type families type family XHsQTvs x type family XXLHsQTyVars x type ForallXLHsQTyVars (c :: * -> Constraint) (x :: *) = ( c (XHsQTvs x) , c (XXLHsQTyVars x) ) -- ------------------------------------- type family XHsIB x b type family XXHsImplicitBndrs x b type ForallXHsImplicitBndrs (c :: * -> Constraint) (x :: *) (b :: *) = ( c (XHsIB x b) , c (XXHsImplicitBndrs x b) ) -- ------------------------------------- type family XHsWC x b type family XXHsWildCardBndrs x b type ForallXHsWildCardBndrs(c :: * -> Constraint) (x :: *) (b :: *) = ( c (XHsWC x b) , c (XXHsWildCardBndrs x b) ) -- ------------------------------------- type family XForAllTy x type family XQualTy x type family XTyVar x type family XAppTy x type family XAppKindTy x type family XFunTy x type family XListTy x type family XTupleTy x type family XSumTy x type family XOpTy x type family XParTy x type family XIParamTy x type family XStarTy x type family XKindSig x type family XSpliceTy x type family XDocTy x type family XBangTy x type family XRecTy x type family XExplicitListTy x type family XExplicitTupleTy x type family XTyLit x type family XWildCardTy x type family XXType x -- | Helper to apply a constraint to all extension points. It has one -- entry per extension point type family. type ForallXType (c :: * -> Constraint) (x :: *) = ( c (XForAllTy x) , c (XQualTy x) , c (XTyVar x) , c (XAppTy x) , c (XAppKindTy x) , c (XFunTy x) , c (XListTy x) , c (XTupleTy x) , c (XSumTy x) , c (XOpTy x) , c (XParTy x) , c (XIParamTy x) , c (XStarTy x) , c (XKindSig x) , c (XSpliceTy x) , c (XDocTy x) , c (XBangTy x) , c (XRecTy x) , c (XExplicitListTy x) , c (XExplicitTupleTy x) , c (XTyLit x) , c (XWildCardTy x) , c (XXType x) ) -- --------------------------------------------------------------------- type family XUserTyVar x type family XKindedTyVar x type family XXTyVarBndr x type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) = ( c (XUserTyVar x) , c (XKindedTyVar x) , c (XXTyVarBndr x) ) -- --------------------------------------------------------------------- type family XConDeclField x type family XXConDeclField x type ForallXConDeclField (c :: * -> Constraint) (x :: *) = ( c (XConDeclField x) , c (XXConDeclField x) ) -- --------------------------------------------------------------------- type family XCFieldOcc x type family XXFieldOcc x type ForallXFieldOcc (c :: * -> Constraint) (x :: *) = ( c (XCFieldOcc x) , c (XXFieldOcc x) ) -- ===================================================================== -- Type families for the HsImpExp type families type family XCImportDecl x type family XXImportDecl x type ForallXImportDecl (c :: * -> Constraint) (x :: *) = ( c (XCImportDecl x) , c (XXImportDecl x) ) -- ------------------------------------- type family XIEVar x type family XIEThingAbs x type family XIEThingAll x type family XIEThingWith x type family XIEModuleContents x type family XIEGroup x type family XIEDoc x type family XIEDocNamed x type family XXIE x type ForallXIE (c :: * -> Constraint) (x :: *) = ( c (XIEVar x) , c (XIEThingAbs x) , c (XIEThingAll x) , c (XIEThingWith x) , c (XIEModuleContents x) , c (XIEGroup x) , c (XIEDoc x) , c (XIEDocNamed x) , c (XXIE x) ) -- ------------------------------------- -- ===================================================================== -- End of Type family definitions -- ===================================================================== -- ---------------------------------------------------------------------- -- | Conversion of annotations from one type index to another. This is required -- where the AST is converted from one pass to another, and the extension values -- need to be brought along if possible. So for example a 'SourceText' is -- converted via 'id', but needs a type signature to keep the type checker -- happy. class Convertable a b | a -> b where convert :: a -> b instance Convertable a a where convert = id -- | A constraint capturing all the extension points that can be converted via -- @instance Convertable a a@ type ConvertIdX a b = (XHsDoublePrim a ~ XHsDoublePrim b, XHsFloatPrim a ~ XHsFloatPrim b, XHsRat a ~ XHsRat b, XHsInteger a ~ XHsInteger b, XHsWord64Prim a ~ XHsWord64Prim b, XHsInt64Prim a ~ XHsInt64Prim b, XHsWordPrim a ~ XHsWordPrim b, XHsIntPrim a ~ XHsIntPrim b, XHsInt a ~ XHsInt b, XHsStringPrim a ~ XHsStringPrim b, XHsString a ~ XHsString b, XHsCharPrim a ~ XHsCharPrim b, XHsChar a ~ XHsChar b, XXLit a ~ XXLit b) -- ---------------------------------------------------------------------- -- Note [OutputableX] -- ~~~~~~~~~~~~~~~~~~ -- -- is required because the type family resolution -- process cannot determine that all cases are handled for a `GhcPass p` -- case where the cases are listed separately. -- -- So -- -- type instance XXHsIPBinds (GhcPass p) = NoExtCon -- -- will correctly deduce Outputable for (GhcPass p), but -- -- type instance XIPBinds GhcPs = NoExt -- type instance XIPBinds GhcRn = NoExt -- type instance XIPBinds GhcTc = TcEvBinds -- -- will not. -- | Provide a summary constraint that gives all am Outputable constraint to -- extension points needing one type OutputableX p = -- See Note [OutputableX] ( Outputable (XIPBinds p) , Outputable (XViaStrategy p) , Outputable (XViaStrategy GhcRn) ) -- TODO: Should OutputableX be included in OutputableBndrId? -- ---------------------------------------------------------------------- -- |Constraint type to bundle up the requirement for 'OutputableBndr' on both -- the @p@ and the 'NameOrRdrName' type for it type OutputableBndrId pass = ( OutputableBndr (NameOrRdrName (IdP (GhcPass pass))) , OutputableBndr (IdP (GhcPass pass)) , OutputableBndr (NameOrRdrName (IdP (NoGhcTc (GhcPass pass)))) , OutputableBndr (IdP (NoGhcTc (GhcPass pass))) , NoGhcTc (GhcPass pass) ~ NoGhcTc (NoGhcTc (GhcPass pass)) , OutputableX (GhcPass pass) , OutputableX (NoGhcTc (GhcPass pass)) ) ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/ImpExp.hs0000644000000000000000000003466713713635744020051 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces -} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder module GHC.Hs.ImpExp where import GhcPrelude import Module ( ModuleName ) import GHC.Hs.Doc ( HsDocString ) import OccName ( HasOccName(..), isTcOcc, isSymOcc ) import BasicTypes ( SourceText(..), StringLiteral(..), pprWithSourceText ) import FieldLabel ( FieldLbl(..) ) import Outputable import FastString import SrcLoc import GHC.Hs.Extension import Data.Data import Data.Maybe {- ************************************************************************ * * \subsection{Import and export declaration lists} * * ************************************************************************ One per \tr{import} declaration in a module. -} -- | Located Import Declaration type LImportDecl pass = Located (ImportDecl pass) -- ^ When in a list this may have -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' -- For details on above see note [Api annotations] in ApiAnnotation -- | If/how an import is 'qualified'. data ImportDeclQualifiedStyle = QualifiedPre -- ^ 'qualified' appears in prepositive position. | QualifiedPost -- ^ 'qualified' appears in postpositive position. | NotQualified -- ^ Not qualified. deriving (Eq, Data) -- | Given two possible located 'qualified' tokens, compute a style -- (in a conforming Haskell program only one of the two can be not -- 'Nothing'). This is called from 'Parser.y'. importDeclQualifiedStyle :: Maybe (Located a) -> Maybe (Located a) -> ImportDeclQualifiedStyle importDeclQualifiedStyle mPre mPost = if isJust mPre then QualifiedPre else if isJust mPost then QualifiedPost else NotQualified -- | Convenience function to answer the question if an import decl. is -- qualified. isImportDeclQualified :: ImportDeclQualifiedStyle -> Bool isImportDeclQualified NotQualified = False isImportDeclQualified _ = True -- | Import Declaration -- -- A single Haskell @import@ declaration. data ImportDecl pass = ImportDecl { ideclExt :: XCImportDecl pass, ideclSourceSrc :: SourceText, -- Note [Pragma source text] in BasicTypes ideclName :: Located ModuleName, -- ^ Module name. ideclPkgQual :: Maybe StringLiteral, -- ^ Package qualifier. ideclSource :: Bool, -- ^ True <=> {-\# SOURCE \#-} import ideclSafe :: Bool, -- ^ True => safe import ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified. ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude) ideclAs :: Maybe (Located ModuleName), -- ^ as Module ideclHiding :: Maybe (Bool, Located [LIE pass]) -- ^ (True => hiding, names) } | XImportDecl (XXImportDecl pass) -- ^ -- 'ApiAnnotation.AnnKeywordId's -- -- - 'ApiAnnotation.AnnImport' -- -- - 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnClose' for ideclSource -- -- - 'ApiAnnotation.AnnSafe','ApiAnnotation.AnnQualified', -- 'ApiAnnotation.AnnPackageName','ApiAnnotation.AnnAs', -- 'ApiAnnotation.AnnVal' -- -- - 'ApiAnnotation.AnnHiding','ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose' attached -- to location in ideclHiding -- For details on above see note [Api annotations] in ApiAnnotation type instance XCImportDecl (GhcPass _) = NoExtField type instance XXImportDecl (GhcPass _) = NoExtCon simpleImportDecl :: ModuleName -> ImportDecl (GhcPass p) simpleImportDecl mn = ImportDecl { ideclExt = noExtField, ideclSourceSrc = NoSourceText, ideclName = noLoc mn, ideclPkgQual = Nothing, ideclSource = False, ideclSafe = False, ideclImplicit = False, ideclQualified = NotQualified, ideclAs = Nothing, ideclHiding = Nothing } instance OutputableBndrId p => Outputable (ImportDecl (GhcPass p)) where ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod' , ideclPkgQual = pkg , ideclSource = from, ideclSafe = safe , ideclQualified = qual, ideclImplicit = implicit , ideclAs = as, ideclHiding = spec }) = hang (hsep [text "import", ppr_imp from, pp_implicit implicit, pp_safe safe, pp_qual qual False, pp_pkg pkg, ppr mod', pp_qual qual True, pp_as as]) 4 (pp_spec spec) where pp_implicit False = empty pp_implicit True = ptext (sLit ("(implicit)")) pp_pkg Nothing = empty pp_pkg (Just (StringLiteral st p)) = pprWithSourceText st (doubleQuotes (ftext p)) pp_qual QualifiedPre False = text "qualified" -- Prepositive qualifier/prepositive position. pp_qual QualifiedPost True = text "qualified" -- Postpositive qualifier/postpositive position. pp_qual QualifiedPre True = empty -- Prepositive qualifier/postpositive position. pp_qual QualifiedPost False = empty -- Postpositive qualifier/prepositive position. pp_qual NotQualified _ = empty pp_safe False = empty pp_safe True = text "safe" pp_as Nothing = empty pp_as (Just a) = text "as" <+> ppr a ppr_imp True = case mSrcText of NoSourceText -> text "{-# SOURCE #-}" SourceText src -> text src <+> text "#-}" ppr_imp False = empty pp_spec Nothing = empty pp_spec (Just (False, (L _ ies))) = ppr_ies ies pp_spec (Just (True, (L _ ies))) = text "hiding" <+> ppr_ies ies ppr_ies [] = text "()" ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')' ppr (XImportDecl x) = ppr x {- ************************************************************************ * * \subsection{Imported and exported entities} * * ************************************************************************ -} -- | A name in an import or export specification which may have adornments. Used -- primarily for accurate pretty printing of ParsedSource, and API Annotation -- placement. data IEWrappedName name = IEName (Located name) -- ^ no extra | IEPattern (Located name) -- ^ pattern X | IEType (Located name) -- ^ type (:+:) deriving (Eq,Data) -- | Located name with possible adornment -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnPattern' type LIEWrappedName name = Located (IEWrappedName name) -- For details on above see note [Api annotations] in ApiAnnotation -- | Located Import or Export type LIE pass = Located (IE pass) -- ^ When in a list this may have -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' -- For details on above see note [Api annotations] in ApiAnnotation -- | Imported or exported entity. data IE pass = IEVar (XIEVar pass) (LIEWrappedName (IdP pass)) -- ^ Imported or Exported Variable | IEThingAbs (XIEThingAbs pass) (LIEWrappedName (IdP pass)) -- ^ Imported or exported Thing with Absent list -- -- The thing is a Class/Type (can't tell) -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern', -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnVal' -- For details on above see note [Api annotations] in ApiAnnotation -- See Note [Located RdrNames] in GHC.Hs.Expr | IEThingAll (XIEThingAll pass) (LIEWrappedName (IdP pass)) -- ^ Imported or exported Thing with All imported or exported -- -- The thing is a Class/Type and the All refers to methods/constructors -- -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose', -- 'ApiAnnotation.AnnType' -- For details on above see note [Api annotations] in ApiAnnotation -- See Note [Located RdrNames] in GHC.Hs.Expr | IEThingWith (XIEThingWith pass) (LIEWrappedName (IdP pass)) IEWildcard [LIEWrappedName (IdP pass)] [Located (FieldLbl (IdP pass))] -- ^ Imported or exported Thing With given imported or exported -- -- The thing is a Class/Type and the imported or exported things are -- methods/constructors and record fields; see Note [IEThingWith] -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose', -- 'ApiAnnotation.AnnComma', -- 'ApiAnnotation.AnnType' -- For details on above see note [Api annotations] in ApiAnnotation | IEModuleContents (XIEModuleContents pass) (Located ModuleName) -- ^ Imported or exported module contents -- -- (Export Only) -- -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnModule' -- For details on above see note [Api annotations] in ApiAnnotation | IEGroup (XIEGroup pass) Int HsDocString -- ^ Doc section heading | IEDoc (XIEDoc pass) HsDocString -- ^ Some documentation | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc | XIE (XXIE pass) type instance XIEVar (GhcPass _) = NoExtField type instance XIEThingAbs (GhcPass _) = NoExtField type instance XIEThingAll (GhcPass _) = NoExtField type instance XIEThingWith (GhcPass _) = NoExtField type instance XIEModuleContents (GhcPass _) = NoExtField type instance XIEGroup (GhcPass _) = NoExtField type instance XIEDoc (GhcPass _) = NoExtField type instance XIEDocNamed (GhcPass _) = NoExtField type instance XXIE (GhcPass _) = NoExtCon -- | Imported or Exported Wildcard data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data) {- Note [IEThingWith] ~~~~~~~~~~~~~~~~~~ A definition like module M ( T(MkT, x) ) where data T = MkT { x :: Int } gives rise to IEThingWith T [MkT] [FieldLabel "x" False x)] (without DuplicateRecordFields) IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)] (with DuplicateRecordFields) See Note [Representing fields in AvailInfo] in Avail for more details. -} ieName :: IE (GhcPass p) -> IdP (GhcPass p) ieName (IEVar _ (L _ n)) = ieWrappedName n ieName (IEThingAbs _ (L _ n)) = ieWrappedName n ieName (IEThingWith _ (L _ n) _ _ _) = ieWrappedName n ieName (IEThingAll _ (L _ n)) = ieWrappedName n ieName _ = panic "ieName failed pattern match!" ieNames :: IE (GhcPass p) -> [IdP (GhcPass p)] ieNames (IEVar _ (L _ n) ) = [ieWrappedName n] ieNames (IEThingAbs _ (L _ n) ) = [ieWrappedName n] ieNames (IEThingAll _ (L _ n) ) = [ieWrappedName n] ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n : map (ieWrappedName . unLoc) ns ieNames (IEModuleContents {}) = [] ieNames (IEGroup {}) = [] ieNames (IEDoc {}) = [] ieNames (IEDocNamed {}) = [] ieNames (XIE nec) = noExtCon nec ieWrappedName :: IEWrappedName name -> name ieWrappedName (IEName (L _ n)) = n ieWrappedName (IEPattern (L _ n)) = n ieWrappedName (IEType (L _ n)) = n lieWrappedName :: LIEWrappedName name -> name lieWrappedName (L _ n) = ieWrappedName n ieLWrappedName :: LIEWrappedName name -> Located name ieLWrappedName (L l n) = L l (ieWrappedName n) replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2 replaceWrappedName (IEName (L l _)) n = IEName (L l n) replaceWrappedName (IEPattern (L l _)) n = IEPattern (L l n) replaceWrappedName (IEType (L l _)) n = IEType (L l n) replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2 replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') instance OutputableBndrId p => Outputable (IE (GhcPass p)) where ppr (IEVar _ var) = ppr (unLoc var) ppr (IEThingAbs _ thing) = ppr (unLoc thing) ppr (IEThingAll _ thing) = hcat [ppr (unLoc thing), text "(..)"] ppr (IEThingWith _ thing wc withs flds) = ppr (unLoc thing) <> parens (fsep (punctuate comma (ppWiths ++ map (ppr . flLabel . unLoc) flds))) where ppWiths = case wc of NoIEWildcard -> map (ppr . unLoc) withs IEWildcard pos -> let (bs, as) = splitAt pos (map (ppr . unLoc) withs) in bs ++ [text ".."] ++ as ppr (IEModuleContents _ mod') = text "module" <+> ppr mod' ppr (IEGroup _ n _) = text ("") ppr (IEDoc _ doc) = ppr doc ppr (IEDocNamed _ string) = text ("") ppr (XIE x) = ppr x instance (HasOccName name) => HasOccName (IEWrappedName name) where occName w = occName (ieWrappedName w) instance (OutputableBndr name) => OutputableBndr (IEWrappedName name) where pprBndr bs w = pprBndr bs (ieWrappedName w) pprPrefixOcc w = pprPrefixOcc (ieWrappedName w) pprInfixOcc w = pprInfixOcc (ieWrappedName w) instance (OutputableBndr name) => Outputable (IEWrappedName name) where ppr (IEName n) = pprPrefixOcc (unLoc n) ppr (IEPattern n) = text "pattern" <+> pprPrefixOcc (unLoc n) ppr (IEType n) = text "type" <+> pprPrefixOcc (unLoc n) pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc pprImpExp name = type_pref <+> pprPrefixOcc name where occ = occName name type_pref | isTcOcc occ && isSymOcc occ = text "type" | otherwise = empty ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/Instances.hs0000644000000000000000000004015013713635744020556 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module GHC.Hs.Instances where -- This module defines the Data instances for the hsSyn AST. -- It happens here to avoid massive constraint types on the AST with concomitant -- slow GHC bootstrap times. -- UndecidableInstances ? import Data.Data hiding ( Fixity ) import GhcPrelude import GHC.Hs.Extension import GHC.Hs.Binds import GHC.Hs.Decls import GHC.Hs.Expr import GHC.Hs.Lit import GHC.Hs.Types import GHC.Hs.Pat import GHC.Hs.ImpExp -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs----------------------------------------- -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Binds ---------------------------------- -- deriving instance (DataIdLR pL pR) => Data (HsLocalBindsLR pL pR) deriving instance Data (HsLocalBindsLR GhcPs GhcPs) deriving instance Data (HsLocalBindsLR GhcPs GhcRn) deriving instance Data (HsLocalBindsLR GhcRn GhcRn) deriving instance Data (HsLocalBindsLR GhcTc GhcTc) -- deriving instance (DataIdLR pL pR) => Data (HsValBindsLR pL pR) deriving instance Data (HsValBindsLR GhcPs GhcPs) deriving instance Data (HsValBindsLR GhcPs GhcRn) deriving instance Data (HsValBindsLR GhcRn GhcRn) deriving instance Data (HsValBindsLR GhcTc GhcTc) -- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL) deriving instance Data (NHsValBindsLR GhcPs) deriving instance Data (NHsValBindsLR GhcRn) deriving instance Data (NHsValBindsLR GhcTc) -- deriving instance (DataIdLR pL pR) => Data (HsBindLR pL pR) deriving instance Data (HsBindLR GhcPs GhcPs) deriving instance Data (HsBindLR GhcPs GhcRn) deriving instance Data (HsBindLR GhcRn GhcRn) deriving instance Data (HsBindLR GhcTc GhcTc) -- deriving instance (DataId p) => Data (ABExport p) deriving instance Data (ABExport GhcPs) deriving instance Data (ABExport GhcRn) deriving instance Data (ABExport GhcTc) -- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR) deriving instance Data (PatSynBind GhcPs GhcPs) deriving instance Data (PatSynBind GhcPs GhcRn) deriving instance Data (PatSynBind GhcRn GhcRn) deriving instance Data (PatSynBind GhcTc GhcTc) -- deriving instance (DataIdLR p p) => Data (HsIPBinds p) deriving instance Data (HsIPBinds GhcPs) deriving instance Data (HsIPBinds GhcRn) deriving instance Data (HsIPBinds GhcTc) -- deriving instance (DataIdLR p p) => Data (IPBind p) deriving instance Data (IPBind GhcPs) deriving instance Data (IPBind GhcRn) deriving instance Data (IPBind GhcTc) -- deriving instance (DataIdLR p p) => Data (Sig p) deriving instance Data (Sig GhcPs) deriving instance Data (Sig GhcRn) deriving instance Data (Sig GhcTc) -- deriving instance (DataId p) => Data (FixitySig p) deriving instance Data (FixitySig GhcPs) deriving instance Data (FixitySig GhcRn) deriving instance Data (FixitySig GhcTc) -- deriving instance (DataId p) => Data (StandaloneKindSig p) deriving instance Data (StandaloneKindSig GhcPs) deriving instance Data (StandaloneKindSig GhcRn) deriving instance Data (StandaloneKindSig GhcTc) -- deriving instance (DataIdLR p p) => Data (HsPatSynDir p) deriving instance Data (HsPatSynDir GhcPs) deriving instance Data (HsPatSynDir GhcRn) deriving instance Data (HsPatSynDir GhcTc) -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Decls ---------------------------------- -- deriving instance (DataIdLR p p) => Data (HsDecl p) deriving instance Data (HsDecl GhcPs) deriving instance Data (HsDecl GhcRn) deriving instance Data (HsDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (HsGroup p) deriving instance Data (HsGroup GhcPs) deriving instance Data (HsGroup GhcRn) deriving instance Data (HsGroup GhcTc) -- deriving instance (DataIdLR p p) => Data (SpliceDecl p) deriving instance Data (SpliceDecl GhcPs) deriving instance Data (SpliceDecl GhcRn) deriving instance Data (SpliceDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (TyClDecl p) deriving instance Data (TyClDecl GhcPs) deriving instance Data (TyClDecl GhcRn) deriving instance Data (TyClDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (TyClGroup p) deriving instance Data (TyClGroup GhcPs) deriving instance Data (TyClGroup GhcRn) deriving instance Data (TyClGroup GhcTc) -- deriving instance (DataIdLR p p) => Data (FamilyResultSig p) deriving instance Data (FamilyResultSig GhcPs) deriving instance Data (FamilyResultSig GhcRn) deriving instance Data (FamilyResultSig GhcTc) -- deriving instance (DataIdLR p p) => Data (FamilyDecl p) deriving instance Data (FamilyDecl GhcPs) deriving instance Data (FamilyDecl GhcRn) deriving instance Data (FamilyDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (InjectivityAnn p) deriving instance Data (InjectivityAnn GhcPs) deriving instance Data (InjectivityAnn GhcRn) deriving instance Data (InjectivityAnn GhcTc) -- deriving instance (DataIdLR p p) => Data (FamilyInfo p) deriving instance Data (FamilyInfo GhcPs) deriving instance Data (FamilyInfo GhcRn) deriving instance Data (FamilyInfo GhcTc) -- deriving instance (DataIdLR p p) => Data (HsDataDefn p) deriving instance Data (HsDataDefn GhcPs) deriving instance Data (HsDataDefn GhcRn) deriving instance Data (HsDataDefn GhcTc) -- deriving instance (DataIdLR p p) => Data (HsDerivingClause p) deriving instance Data (HsDerivingClause GhcPs) deriving instance Data (HsDerivingClause GhcRn) deriving instance Data (HsDerivingClause GhcTc) -- deriving instance (DataIdLR p p) => Data (ConDecl p) deriving instance Data (ConDecl GhcPs) deriving instance Data (ConDecl GhcRn) deriving instance Data (ConDecl GhcTc) -- deriving instance DataIdLR p p => Data (TyFamInstDecl p) deriving instance Data (TyFamInstDecl GhcPs) deriving instance Data (TyFamInstDecl GhcRn) deriving instance Data (TyFamInstDecl GhcTc) -- deriving instance DataIdLR p p => Data (DataFamInstDecl p) deriving instance Data (DataFamInstDecl GhcPs) deriving instance Data (DataFamInstDecl GhcRn) deriving instance Data (DataFamInstDecl GhcTc) -- deriving instance (DataIdLR p p,Data rhs)=>Data (FamEqn p rhs) deriving instance Data rhs => Data (FamEqn GhcPs rhs) deriving instance Data rhs => Data (FamEqn GhcRn rhs) deriving instance Data rhs => Data (FamEqn GhcTc rhs) -- deriving instance (DataIdLR p p) => Data (ClsInstDecl p) deriving instance Data (ClsInstDecl GhcPs) deriving instance Data (ClsInstDecl GhcRn) deriving instance Data (ClsInstDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (InstDecl p) deriving instance Data (InstDecl GhcPs) deriving instance Data (InstDecl GhcRn) deriving instance Data (InstDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (DerivDecl p) deriving instance Data (DerivDecl GhcPs) deriving instance Data (DerivDecl GhcRn) deriving instance Data (DerivDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (DerivStrategy p) deriving instance Data (DerivStrategy GhcPs) deriving instance Data (DerivStrategy GhcRn) deriving instance Data (DerivStrategy GhcTc) -- deriving instance (DataIdLR p p) => Data (DefaultDecl p) deriving instance Data (DefaultDecl GhcPs) deriving instance Data (DefaultDecl GhcRn) deriving instance Data (DefaultDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (ForeignDecl p) deriving instance Data (ForeignDecl GhcPs) deriving instance Data (ForeignDecl GhcRn) deriving instance Data (ForeignDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (RuleDecls p) deriving instance Data (RuleDecls GhcPs) deriving instance Data (RuleDecls GhcRn) deriving instance Data (RuleDecls GhcTc) -- deriving instance (DataIdLR p p) => Data (RuleDecl p) deriving instance Data (RuleDecl GhcPs) deriving instance Data (RuleDecl GhcRn) deriving instance Data (RuleDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (RuleBndr p) deriving instance Data (RuleBndr GhcPs) deriving instance Data (RuleBndr GhcRn) deriving instance Data (RuleBndr GhcTc) -- deriving instance (DataId p) => Data (WarnDecls p) deriving instance Data (WarnDecls GhcPs) deriving instance Data (WarnDecls GhcRn) deriving instance Data (WarnDecls GhcTc) -- deriving instance (DataId p) => Data (WarnDecl p) deriving instance Data (WarnDecl GhcPs) deriving instance Data (WarnDecl GhcRn) deriving instance Data (WarnDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (AnnDecl p) deriving instance Data (AnnDecl GhcPs) deriving instance Data (AnnDecl GhcRn) deriving instance Data (AnnDecl GhcTc) -- deriving instance (DataId p) => Data (RoleAnnotDecl p) deriving instance Data (RoleAnnotDecl GhcPs) deriving instance Data (RoleAnnotDecl GhcRn) deriving instance Data (RoleAnnotDecl GhcTc) -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Expr ----------------------------------- -- deriving instance (DataIdLR p p) => Data (SyntaxExpr p) deriving instance Data (SyntaxExpr GhcPs) deriving instance Data (SyntaxExpr GhcRn) deriving instance Data (SyntaxExpr GhcTc) -- deriving instance (DataIdLR p p) => Data (HsExpr p) deriving instance Data (HsExpr GhcPs) deriving instance Data (HsExpr GhcRn) deriving instance Data (HsExpr GhcTc) -- deriving instance (DataIdLR p p) => Data (HsTupArg p) deriving instance Data (HsTupArg GhcPs) deriving instance Data (HsTupArg GhcRn) deriving instance Data (HsTupArg GhcTc) -- deriving instance (DataIdLR p p) => Data (HsCmd p) deriving instance Data (HsCmd GhcPs) deriving instance Data (HsCmd GhcRn) deriving instance Data (HsCmd GhcTc) -- deriving instance (DataIdLR p p) => Data (HsCmdTop p) deriving instance Data (HsCmdTop GhcPs) deriving instance Data (HsCmdTop GhcRn) deriving instance Data (HsCmdTop GhcTc) -- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body) deriving instance (Data body) => Data (MatchGroup GhcPs body) deriving instance (Data body) => Data (MatchGroup GhcRn body) deriving instance (Data body) => Data (MatchGroup GhcTc body) -- deriving instance (DataIdLR p p,Data body) => Data (Match p body) deriving instance (Data body) => Data (Match GhcPs body) deriving instance (Data body) => Data (Match GhcRn body) deriving instance (Data body) => Data (Match GhcTc body) -- deriving instance (DataIdLR p p,Data body) => Data (GRHSs p body) deriving instance (Data body) => Data (GRHSs GhcPs body) deriving instance (Data body) => Data (GRHSs GhcRn body) deriving instance (Data body) => Data (GRHSs GhcTc body) -- deriving instance (DataIdLR p p,Data body) => Data (GRHS p body) deriving instance (Data body) => Data (GRHS GhcPs body) deriving instance (Data body) => Data (GRHS GhcRn body) deriving instance (Data body) => Data (GRHS GhcTc body) -- deriving instance (DataIdLR p p,Data body) => Data (StmtLR p p body) deriving instance (Data body) => Data (StmtLR GhcPs GhcPs body) deriving instance (Data body) => Data (StmtLR GhcPs GhcRn body) deriving instance (Data body) => Data (StmtLR GhcRn GhcRn body) deriving instance (Data body) => Data (StmtLR GhcTc GhcTc body) deriving instance Data RecStmtTc -- deriving instance (DataIdLR p p) => Data (ParStmtBlock p p) deriving instance Data (ParStmtBlock GhcPs GhcPs) deriving instance Data (ParStmtBlock GhcPs GhcRn) deriving instance Data (ParStmtBlock GhcRn GhcRn) deriving instance Data (ParStmtBlock GhcTc GhcTc) -- deriving instance (DataIdLR p p) => Data (ApplicativeArg p) deriving instance Data (ApplicativeArg GhcPs) deriving instance Data (ApplicativeArg GhcRn) deriving instance Data (ApplicativeArg GhcTc) -- deriving instance (DataIdLR p p) => Data (HsSplice p) deriving instance Data (HsSplice GhcPs) deriving instance Data (HsSplice GhcRn) deriving instance Data (HsSplice GhcTc) -- deriving instance (DataIdLR p p) => Data (HsSplicedThing p) deriving instance Data (HsSplicedThing GhcPs) deriving instance Data (HsSplicedThing GhcRn) deriving instance Data (HsSplicedThing GhcTc) -- deriving instance (DataIdLR p p) => Data (HsBracket p) deriving instance Data (HsBracket GhcPs) deriving instance Data (HsBracket GhcRn) deriving instance Data (HsBracket GhcTc) -- deriving instance (DataIdLR p p) => Data (ArithSeqInfo p) deriving instance Data (ArithSeqInfo GhcPs) deriving instance Data (ArithSeqInfo GhcRn) deriving instance Data (ArithSeqInfo GhcTc) deriving instance Data RecordConTc deriving instance Data CmdTopTc deriving instance Data PendingRnSplice deriving instance Data PendingTcSplice -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Lit ------------------------------------ -- deriving instance (DataId p) => Data (HsLit p) deriving instance Data (HsLit GhcPs) deriving instance Data (HsLit GhcRn) deriving instance Data (HsLit GhcTc) -- deriving instance (DataIdLR p p) => Data (HsOverLit p) deriving instance Data (HsOverLit GhcPs) deriving instance Data (HsOverLit GhcRn) deriving instance Data (HsOverLit GhcTc) -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Pat ------------------------------------ -- deriving instance (DataIdLR p p) => Data (Pat p) deriving instance Data (Pat GhcPs) deriving instance Data (Pat GhcRn) deriving instance Data (Pat GhcTc) deriving instance Data ListPatTc -- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body) deriving instance (Data body) => Data (HsRecFields GhcPs body) deriving instance (Data body) => Data (HsRecFields GhcRn body) deriving instance (Data body) => Data (HsRecFields GhcTc body) -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Types ---------------------------------- -- deriving instance (DataIdLR p p) => Data (LHsQTyVars p) deriving instance Data (LHsQTyVars GhcPs) deriving instance Data (LHsQTyVars GhcRn) deriving instance Data (LHsQTyVars GhcTc) -- deriving instance (DataIdLR p p, Data thing) =>Data (HsImplicitBndrs p thing) deriving instance (Data thing) => Data (HsImplicitBndrs GhcPs thing) deriving instance (Data thing) => Data (HsImplicitBndrs GhcRn thing) deriving instance (Data thing) => Data (HsImplicitBndrs GhcTc thing) -- deriving instance (DataIdLR p p, Data thing) =>Data (HsWildCardBndrs p thing) deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing) deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing) deriving instance (Data thing) => Data (HsWildCardBndrs GhcTc thing) -- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p) deriving instance Data (HsTyVarBndr GhcPs) deriving instance Data (HsTyVarBndr GhcRn) deriving instance Data (HsTyVarBndr GhcTc) -- deriving instance (DataIdLR p p) => Data (HsType p) deriving instance Data (HsType GhcPs) deriving instance Data (HsType GhcRn) deriving instance Data (HsType GhcTc) deriving instance Data (LHsTypeArg GhcPs) deriving instance Data (LHsTypeArg GhcRn) deriving instance Data (LHsTypeArg GhcTc) -- deriving instance (DataIdLR p p) => Data (ConDeclField p) deriving instance Data (ConDeclField GhcPs) deriving instance Data (ConDeclField GhcRn) deriving instance Data (ConDeclField GhcTc) -- deriving instance (DataId p) => Data (FieldOcc p) deriving instance Data (FieldOcc GhcPs) deriving instance Data (FieldOcc GhcRn) deriving instance Data (FieldOcc GhcTc) -- deriving instance DataId p => Data (AmbiguousFieldOcc p) deriving instance Data (AmbiguousFieldOcc GhcPs) deriving instance Data (AmbiguousFieldOcc GhcRn) deriving instance Data (AmbiguousFieldOcc GhcTc) -- deriving instance (DataId name) => Data (ImportDecl name) deriving instance Data (ImportDecl GhcPs) deriving instance Data (ImportDecl GhcRn) deriving instance Data (ImportDecl GhcTc) -- deriving instance (DataId name) => Data (IE name) deriving instance Data (IE GhcPs) deriving instance Data (IE GhcRn) deriving instance Data (IE GhcTc) -- deriving instance (Eq name, Eq (IdP name)) => Eq (IE name) deriving instance Eq (IE GhcPs) deriving instance Eq (IE GhcRn) deriving instance Eq (IE GhcTc) -- --------------------------------------------------------------------- ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/Lit.hs0000644000000000000000000003125613713635744017366 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[HsLit]{Abstract syntax: source-language literals} -} {-# LANGUAGE CPP, DeriveDataTypeable #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} module GHC.Hs.Lit where #include "GhclibHsVersions.h" import GhcPrelude import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, pprExpr ) import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit, negateFractionalLit,SourceText(..),pprWithSourceText, PprPrec(..), topPrec ) import Type import Outputable import FastString import GHC.Hs.Extension import Data.ByteString (ByteString) import Data.Data hiding ( Fixity ) {- ************************************************************************ * * \subsection[HsLit]{Literals} * * ************************************************************************ -} -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following -- Note [Trees that grow] in GHC.Hs.Extension for the Xxxxx fields in the following -- | Haskell Literal data HsLit x = HsChar (XHsChar x) {- SourceText -} Char -- ^ Character | HsCharPrim (XHsCharPrim x) {- SourceText -} Char -- ^ Unboxed character | HsString (XHsString x) {- SourceText -} FastString -- ^ String | HsStringPrim (XHsStringPrim x) {- SourceText -} ByteString -- ^ Packed bytes | HsInt (XHsInt x) IntegralLit -- ^ Genuinely an Int; arises from -- @TcGenDeriv@, and from TRANSLATION | HsIntPrim (XHsIntPrim x) {- SourceText -} Integer -- ^ literal @Int#@ | HsWordPrim (XHsWordPrim x) {- SourceText -} Integer -- ^ literal @Word#@ | HsInt64Prim (XHsInt64Prim x) {- SourceText -} Integer -- ^ literal @Int64#@ | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer -- ^ literal @Word64#@ | HsInteger (XHsInteger x) {- SourceText -} Integer Type -- ^ Genuinely an integer; arises only -- from TRANSLATION (overloaded -- literals are done with HsOverLit) | HsRat (XHsRat x) FractionalLit Type -- ^ Genuinely a rational; arises only from -- TRANSLATION (overloaded literals are -- done with HsOverLit) | HsFloatPrim (XHsFloatPrim x) FractionalLit -- ^ Unboxed Float | HsDoublePrim (XHsDoublePrim x) FractionalLit -- ^ Unboxed Double | XLit (XXLit x) type instance XHsChar (GhcPass _) = SourceText type instance XHsCharPrim (GhcPass _) = SourceText type instance XHsString (GhcPass _) = SourceText type instance XHsStringPrim (GhcPass _) = SourceText type instance XHsInt (GhcPass _) = NoExtField type instance XHsIntPrim (GhcPass _) = SourceText type instance XHsWordPrim (GhcPass _) = SourceText type instance XHsInt64Prim (GhcPass _) = SourceText type instance XHsWord64Prim (GhcPass _) = SourceText type instance XHsInteger (GhcPass _) = SourceText type instance XHsRat (GhcPass _) = NoExtField type instance XHsFloatPrim (GhcPass _) = NoExtField type instance XHsDoublePrim (GhcPass _) = NoExtField type instance XXLit (GhcPass _) = NoExtCon instance Eq (HsLit x) where (HsChar _ x1) == (HsChar _ x2) = x1==x2 (HsCharPrim _ x1) == (HsCharPrim _ x2) = x1==x2 (HsString _ x1) == (HsString _ x2) = x1==x2 (HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2 (HsInt _ x1) == (HsInt _ x2) = x1==x2 (HsIntPrim _ x1) == (HsIntPrim _ x2) = x1==x2 (HsWordPrim _ x1) == (HsWordPrim _ x2) = x1==x2 (HsInt64Prim _ x1) == (HsInt64Prim _ x2) = x1==x2 (HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2 (HsInteger _ x1 _) == (HsInteger _ x2 _) = x1==x2 (HsRat _ x1 _) == (HsRat _ x2 _) = x1==x2 (HsFloatPrim _ x1) == (HsFloatPrim _ x2) = x1==x2 (HsDoublePrim _ x1) == (HsDoublePrim _ x2) = x1==x2 _ == _ = False -- | Haskell Overloaded Literal data HsOverLit p = OverLit { ol_ext :: (XOverLit p), ol_val :: OverLitVal, ol_witness :: HsExpr p} -- Note [Overloaded literal witnesses] | XOverLit (XXOverLit p) data OverLitTc = OverLitTc { ol_rebindable :: Bool, -- Note [ol_rebindable] ol_type :: Type } deriving Data type instance XOverLit GhcPs = NoExtField type instance XOverLit GhcRn = Bool -- Note [ol_rebindable] type instance XOverLit GhcTc = OverLitTc type instance XXOverLit (GhcPass _) = NoExtCon -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following -- | Overloaded Literal Value data OverLitVal = HsIntegral !IntegralLit -- ^ Integer-looking literals; | HsFractional !FractionalLit -- ^ Frac-looking literals | HsIsString !SourceText !FastString -- ^ String-looking literals deriving Data negateOverLitVal :: OverLitVal -> OverLitVal negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i) negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f) negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" overLitType :: HsOverLit GhcTc -> Type overLitType (OverLit (OverLitTc _ ty) _ _) = ty overLitType (XOverLit nec) = noExtCon nec -- | Convert a literal from one index type to another, updating the annotations -- according to the relevant 'Convertable' instance convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b convertLit (HsChar a x) = (HsChar (convert a) x) convertLit (HsCharPrim a x) = (HsCharPrim (convert a) x) convertLit (HsString a x) = (HsString (convert a) x) convertLit (HsStringPrim a x) = (HsStringPrim (convert a) x) convertLit (HsInt a x) = (HsInt (convert a) x) convertLit (HsIntPrim a x) = (HsIntPrim (convert a) x) convertLit (HsWordPrim a x) = (HsWordPrim (convert a) x) convertLit (HsInt64Prim a x) = (HsInt64Prim (convert a) x) convertLit (HsWord64Prim a x) = (HsWord64Prim (convert a) x) convertLit (HsInteger a x b) = (HsInteger (convert a) x b) convertLit (HsRat a x b) = (HsRat (convert a) x b) convertLit (HsFloatPrim a x) = (HsFloatPrim (convert a) x) convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x) convertLit (XLit a) = (XLit (convert a)) {- Note [ol_rebindable] ~~~~~~~~~~~~~~~~~~~~ The ol_rebindable field is True if this literal is actually using rebindable syntax. Specifically: False iff ol_witness is the standard one True iff ol_witness is non-standard Equivalently it's True if a) RebindableSyntax is on b) the witness for fromInteger/fromRational/fromString that happens to be in scope isn't the standard one Note [Overloaded literal witnesses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *Before* type checking, the HsExpr in an HsOverLit is the name of the coercion function, 'fromInteger' or 'fromRational'. *After* type checking, it is a witness for the literal, such as (fromInteger 3) or lit_78 This witness should replace the literal. This dual role is unusual, because we're replacing 'fromInteger' with a call to fromInteger. Reason: it allows commoning up of the fromInteger calls, which wouldn't be possible if the desugarer made the application. The PostTcType in each branch records the type the overload literal is found to have. -} -- Comparison operations are needed when grouping literals -- for compiling pattern-matching (module MatchLit) instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2 (XOverLit val1) == (XOverLit val2) = val1 == val2 _ == _ = panic "Eq HsOverLit" instance Eq OverLitVal where (HsIntegral i1) == (HsIntegral i2) = i1 == i2 (HsFractional f1) == (HsFractional f2) = f1 == f2 (HsIsString _ s1) == (HsIsString _ s2) = s1 == s2 _ == _ = False instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2 compare (XOverLit val1) (XOverLit val2) = val1 `compare` val2 compare _ _ = panic "Ord HsOverLit" instance Ord OverLitVal where compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2 compare (HsIntegral _) (HsFractional _) = LT compare (HsIntegral _) (HsIsString _ _) = LT compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2 compare (HsFractional _) (HsIntegral _) = GT compare (HsFractional _) (HsIsString _ _) = LT compare (HsIsString _ s1) (HsIsString _ s2) = s1 `compare` s2 compare (HsIsString _ _) (HsIntegral _) = GT compare (HsIsString _ _) (HsFractional _) = GT -- Instance specific to GhcPs, need the SourceText instance Outputable (HsLit (GhcPass p)) where ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c) ppr (HsString st s) = pprWithSourceText st (pprHsString s) ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s) ppr (HsInt _ i) = pprWithSourceText (il_text i) (integer (il_value i)) ppr (HsInteger st i _) = pprWithSourceText st (integer i) ppr (HsRat _ f _) = ppr f ppr (HsFloatPrim _ f) = ppr f <> primFloatSuffix ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i) ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i) ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w) ppr (XLit x) = ppr x pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc pp_st_suffix NoSourceText _ doc = doc pp_st_suffix (SourceText st) suffix _ = text st <> suffix -- in debug mode, print the expression that it's resolved to, too instance OutputableBndrId p => Outputable (HsOverLit (GhcPass p)) where ppr (OverLit {ol_val=val, ol_witness=witness}) = ppr val <+> (whenPprDebug (parens (pprExpr witness))) ppr (XOverLit x) = ppr x instance Outputable OverLitVal where ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) ppr (HsFractional f) = ppr f ppr (HsIsString st s) = pprWithSourceText st (pprHsString s) -- | pmPprHsLit pretty prints literals and is used when pretty printing pattern -- match warnings. All are printed the same (i.e., without hashes if they are -- primitive and not wrapped in constructors if they are boxed). This happens -- mainly for too reasons: -- * We do not want to expose their internal representation -- * The warnings become too messy pmPprHsLit :: HsLit (GhcPass x) -> SDoc pmPprHsLit (HsChar _ c) = pprHsChar c pmPprHsLit (HsCharPrim _ c) = pprHsChar c pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s) pmPprHsLit (HsStringPrim _ s) = pprHsBytes s pmPprHsLit (HsInt _ i) = integer (il_value i) pmPprHsLit (HsIntPrim _ i) = integer i pmPprHsLit (HsWordPrim _ w) = integer w pmPprHsLit (HsInt64Prim _ i) = integer i pmPprHsLit (HsWord64Prim _ w) = integer w pmPprHsLit (HsInteger _ i _) = integer i pmPprHsLit (HsRat _ f _) = ppr f pmPprHsLit (HsFloatPrim _ f) = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d pmPprHsLit (XLit x) = ppr x -- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs -- to be parenthesized under precedence @p@. hsLitNeedsParens :: PprPrec -> HsLit x -> Bool hsLitNeedsParens p = go where go (HsChar {}) = False go (HsCharPrim {}) = False go (HsString {}) = False go (HsStringPrim {}) = False go (HsInt _ x) = p > topPrec && il_neg x go (HsIntPrim _ x) = p > topPrec && x < 0 go (HsWordPrim {}) = False go (HsInt64Prim _ x) = p > topPrec && x < 0 go (HsWord64Prim {}) = False go (HsInteger _ x _) = p > topPrec && x < 0 go (HsRat _ x _) = p > topPrec && fl_neg x go (HsFloatPrim _ x) = p > topPrec && fl_neg x go (HsDoublePrim _ x) = p > topPrec && fl_neg x go (XLit _) = False -- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal -- @ol@ needs to be parenthesized under precedence @p@. hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv where go :: OverLitVal -> Bool go (HsIntegral x) = p > topPrec && il_neg x go (HsFractional x) = p > topPrec && fl_neg x go (HsIsString {}) = False hsOverLitNeedsParens _ (XOverLit { }) = False ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/Pat.hs0000644000000000000000000007743413713635744017372 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[PatSyntax]{Abstract Haskell syntax---patterns} -} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} module GHC.Hs.Pat ( Pat(..), InPat, OutPat, LPat, ListPatTc(..), HsConPatDetails, hsConPatArgs, HsRecFields(..), HsRecField'(..), LHsRecField', HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField, hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs, hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr, mkPrefixConPat, mkCharLitPat, mkNilPat, looksLazyPatBind, isBangedLPat, patNeedsParens, parenthesizePat, isIrrefutableHsPat, collectEvVarsPat, collectEvVarsPats, pprParendLPat, pprConArgs ) where import GhcPrelude import {-# SOURCE #-} GHC.Hs.Expr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice) -- friends: import GHC.Hs.Binds import GHC.Hs.Lit import GHC.Hs.Extension import GHC.Hs.Types import TcEvidence import BasicTypes -- others: import PprCore ( {- instance OutputableBndr TyVar -} ) import TysWiredIn import Var import RdrName ( RdrName ) import ConLike import DataCon import TyCon import Outputable import Type import SrcLoc import Bag -- collect ev vars from pats import DynFlags( gopt, GeneralFlag(..) ) import Maybes -- libraries: import Data.Data hiding (TyCon,Fixity) type InPat p = LPat p -- No 'Out' constructors type OutPat p = LPat p -- No 'In' constructors type LPat p = XRec p Pat -- | Pattern -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' -- For details on above see note [Api annotations] in ApiAnnotation data Pat p = ------------ Simple patterns --------------- WildPat (XWildPat p) -- ^ Wildcard Pattern -- The sole reason for a type on a WildPat is to -- support hsPatType :: Pat Id -> Type -- AZ:TODO above comment needs to be updated | VarPat (XVarPat p) (Located (IdP p)) -- ^ Variable Pattern -- See Note [Located RdrNames] in GHC.Hs.Expr | LazyPat (XLazyPat p) (LPat p) -- ^ Lazy Pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' -- For details on above see note [Api annotations] in ApiAnnotation | AsPat (XAsPat p) (Located (IdP p)) (LPat p) -- ^ As pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' -- For details on above see note [Api annotations] in ApiAnnotation | ParPat (XParPat p) (LPat p) -- ^ Parenthesised pattern -- See Note [Parens in HsSyn] in GHC.Hs.Expr -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation | BangPat (XBangPat p) (LPat p) -- ^ Bang pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' -- For details on above see note [Api annotations] in ApiAnnotation ------------ Lists, tuples, arrays --------------- | ListPat (XListPat p) [LPat p] -- For OverloadedLists a Just (ty,fn) gives -- overall type of the pattern, and the toList -- function to convert the scrutinee to a list value -- ^ Syntactic List -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, -- 'ApiAnnotation.AnnClose' @']'@ -- For details on above see note [Api annotations] in ApiAnnotation | TuplePat (XTuplePat p) -- after typechecking, holds the types of the tuple components [LPat p] -- Tuple sub-patterns Boxity -- UnitPat is TuplePat [] -- You might think that the post typechecking Type was redundant, -- because we can get the pattern type by getting the types of the -- sub-patterns. -- But it's essential -- data T a where -- T1 :: Int -> T Int -- f :: (T a, a) -> Int -- f (T1 x, z) = z -- When desugaring, we must generate -- f = /\a. \v::a. case v of (t::T a, w::a) -> -- case t of (T1 (x::Int)) -> -- Note the (w::a), NOT (w::Int), because we have not yet -- refined 'a' to Int. So we must know that the second component -- of the tuple is of type 'a' not Int. See selectMatchVar -- (June 14: I'm not sure this comment is right; the sub-patterns -- will be wrapped in CoPats, no?) -- ^ Tuple sub-patterns -- -- - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@, -- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@ | SumPat (XSumPat p) -- GHC.Hs.PlaceHolder before typechecker, filled in -- afterwards with the types of the -- alternative (LPat p) -- Sum sub-pattern ConTag -- Alternative (one-based) Arity -- Arity (INVARIANT: ≥ 2) -- ^ Anonymous sum pattern -- -- - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpen' @'(#'@, -- 'ApiAnnotation.AnnClose' @'#)'@ -- For details on above see note [Api annotations] in ApiAnnotation ------------ Constructor patterns --------------- | ConPatIn (Located (IdP p)) (HsConPatDetails p) -- ^ Constructor Pattern In | ConPatOut { pat_con :: Located ConLike, pat_arg_tys :: [Type], -- The universal arg types, 1-1 with the universal -- tyvars of the constructor/pattern synonym -- Use (conLikeResTy pat_con pat_arg_tys) to get -- the type of the pattern pat_tvs :: [TyVar], -- Existentially bound type variables -- in correctly-scoped order e.g. [k:*, x:k] pat_dicts :: [EvVar], -- Ditto *coercion variables* and *dictionaries* -- One reason for putting coercion variable here, I think, -- is to ensure their kinds are zonked pat_binds :: TcEvBinds, -- Bindings involving those dictionaries pat_args :: HsConPatDetails p, pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher -- Only relevant for pattern-synonyms; -- ignored for data cons } -- ^ Constructor Pattern Out ------------ View patterns --------------- -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation | ViewPat (XViewPat p) -- The overall type of the pattern -- (= the argument type of the view function) -- for hsPatType. (LHsExpr p) (LPat p) -- ^ View Pattern ------------ Pattern splices --------------- -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@ -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation | SplicePat (XSplicePat p) (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes) ------------ Literal and n+k patterns --------------- | LitPat (XLitPat p) (HsLit p) -- ^ Literal Pattern -- Used for *non-overloaded* literal patterns: -- Int#, Char#, Int, Char, String, etc. | NPat -- Natural Pattern -- Used for all overloaded literals, -- including overloaded strings with -XOverloadedStrings (XNPat p) -- Overall type of pattern. Might be -- different than the literal's type -- if (==) or negate changes the type (Located (HsOverLit p)) -- ALWAYS positive (Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for -- negative patterns, Nothing -- otherwise (SyntaxExpr p) -- Equality checker, of type t->t->Bool -- ^ Natural Pattern -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@ -- For details on above see note [Api annotations] in ApiAnnotation | NPlusKPat (XNPlusKPat p) -- Type of overall pattern (Located (IdP p)) -- n+k pattern (Located (HsOverLit p)) -- It'll always be an HsIntegral (HsOverLit p) -- See Note [NPlusK patterns] in TcPat -- NB: This could be (PostTc ...), but that induced a -- a new hs-boot file. Not worth it. (SyntaxExpr p) -- (>=) function, of type t1->t2->Bool (SyntaxExpr p) -- Name of '-' (see RnEnv.lookupSyntaxName) -- ^ n+k pattern ------------ Pattern type signatures --------------- -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation | SigPat (XSigPat p) -- After typechecker: Type (LPat p) -- Pattern with a type signature (LHsSigWcType (NoGhcTc p)) -- Signature can bind both -- kind and type vars -- ^ Pattern with a type signature ------------ Pattern coercions (translation only) --------------- | CoPat (XCoPat p) HsWrapper -- Coercion Pattern -- If co :: t1 ~ t2, p :: t2, -- then (CoPat co p) :: t1 (Pat p) -- Why not LPat? Ans: existing locn will do Type -- Type of whole pattern, t1 -- During desugaring a (CoPat co pat) turns into a cast with 'co' on -- the scrutinee, followed by a match on 'pat' -- ^ Coercion Pattern -- | Trees that Grow extension point for new constructors | XPat (XXPat p) -- --------------------------------------------------------------------- data ListPatTc = ListPatTc Type -- The type of the elements (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax type instance XWildPat GhcPs = NoExtField type instance XWildPat GhcRn = NoExtField type instance XWildPat GhcTc = Type type instance XVarPat (GhcPass _) = NoExtField type instance XLazyPat (GhcPass _) = NoExtField type instance XAsPat (GhcPass _) = NoExtField type instance XParPat (GhcPass _) = NoExtField type instance XBangPat (GhcPass _) = NoExtField -- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap -- compiler, as it triggers https://gitlab.haskell.org/ghc/ghc/issues/14396 for -- `SyntaxExpr` type instance XListPat GhcPs = NoExtField type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn) type instance XListPat GhcTc = ListPatTc type instance XTuplePat GhcPs = NoExtField type instance XTuplePat GhcRn = NoExtField type instance XTuplePat GhcTc = [Type] type instance XSumPat GhcPs = NoExtField type instance XSumPat GhcRn = NoExtField type instance XSumPat GhcTc = [Type] type instance XViewPat GhcPs = NoExtField type instance XViewPat GhcRn = NoExtField type instance XViewPat GhcTc = Type type instance XSplicePat (GhcPass _) = NoExtField type instance XLitPat (GhcPass _) = NoExtField type instance XNPat GhcPs = NoExtField type instance XNPat GhcRn = NoExtField type instance XNPat GhcTc = Type type instance XNPlusKPat GhcPs = NoExtField type instance XNPlusKPat GhcRn = NoExtField type instance XNPlusKPat GhcTc = Type type instance XSigPat GhcPs = NoExtField type instance XSigPat GhcRn = NoExtField type instance XSigPat GhcTc = Type type instance XCoPat (GhcPass _) = NoExtField type instance XXPat (GhcPass _) = NoExtCon -- --------------------------------------------------------------------- -- | Haskell Constructor Pattern Details type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p)) hsConPatArgs :: HsConPatDetails p -> [LPat p] hsConPatArgs (PrefixCon ps) = ps hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2] -- | Haskell Record Fields -- -- HsRecFields is used only for patterns and expressions (not data type -- declarations) data HsRecFields p arg -- A bunch of record fields -- { x = 3, y = True } -- Used for both expressions and patterns = HsRecFields { rec_flds :: [LHsRecField p arg], rec_dotdot :: Maybe (Located Int) } -- Note [DotDot fields] deriving (Functor, Foldable, Traversable) -- Note [DotDot fields] -- ~~~~~~~~~~~~~~~~~~~~ -- The rec_dotdot field means this: -- Nothing => the normal case -- Just n => the group uses ".." notation, -- -- In the latter case: -- -- *before* renamer: rec_flds are exactly the n user-written fields -- -- *after* renamer: rec_flds includes *all* fields, with -- the first 'n' being the user-written ones -- and the remainder being 'filled in' implicitly -- | Located Haskell Record Field type LHsRecField' p arg = Located (HsRecField' p arg) -- | Located Haskell Record Field type LHsRecField p arg = Located (HsRecField p arg) -- | Located Haskell Record Update Field type LHsRecUpdField p = Located (HsRecUpdField p) -- | Haskell Record Field type HsRecField p arg = HsRecField' (FieldOcc p) arg -- | Haskell Record Update Field type HsRecUpdField p = HsRecField' (AmbiguousFieldOcc p) (LHsExpr p) -- | Haskell Record Field -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual', -- -- For details on above see note [Api annotations] in ApiAnnotation data HsRecField' id arg = HsRecField { hsRecFieldLbl :: Located id, hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning hsRecPun :: Bool -- ^ Note [Punning] } deriving (Data, Functor, Foldable, Traversable) -- Note [Punning] -- ~~~~~~~~~~~~~~ -- If you write T { x, y = v+1 }, the HsRecFields will be -- HsRecField x x True ... -- HsRecField y (v+1) False ... -- That is, for "punned" field x is expanded (in the renamer) -- to x=x; but with a punning flag so we can detect it later -- (e.g. when pretty printing) -- -- If the original field was qualified, we un-qualify it, thus -- T { A.x } means T { A.x = x } -- Note [HsRecField and HsRecUpdField] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- A HsRecField (used for record construction and pattern matching) -- contains an unambiguous occurrence of a field (i.e. a FieldOcc). -- We can't just store the Name, because thanks to -- DuplicateRecordFields this may not correspond to the label the user -- wrote. -- -- A HsRecUpdField (used for record update) contains a potentially -- ambiguous occurrence of a field (an AmbiguousFieldOcc). The -- renamer will fill in the selector function if it can, but if the -- selector is ambiguous the renamer will defer to the typechecker. -- After the typechecker, a unique selector will have been determined. -- -- The renamer produces an Unambiguous result if it can, rather than -- just doing the lookup in the typechecker, so that completely -- unambiguous updates can be represented by 'DsMeta.repUpdFields'. -- -- For example, suppose we have: -- -- data S = MkS { x :: Int } -- data T = MkT { x :: Int } -- -- f z = (z { x = 3 }) :: S -- -- The parsed HsRecUpdField corresponding to the record update will have: -- -- hsRecFieldLbl = Unambiguous "x" noExtField :: AmbiguousFieldOcc RdrName -- -- After the renamer, this will become: -- -- hsRecFieldLbl = Ambiguous "x" noExtField :: AmbiguousFieldOcc Name -- -- (note that the Unambiguous constructor is not type-correct here). -- The typechecker will determine the particular selector: -- -- hsRecFieldLbl = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id -- -- See also Note [Disambiguating record fields] in TcExpr. hsRecFields :: HsRecFields p arg -> [XCFieldOcc p] hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds) -- Probably won't typecheck at once, things have changed :/ hsRecFieldsArgs :: HsRecFields p arg -> [arg] hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds) hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass) hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl hsRecFieldId :: HsRecField GhcTc arg -> Located Id hsRecFieldId = hsRecFieldSel hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl {- ************************************************************************ * * * Printing patterns * * ************************************************************************ -} instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where ppr = pprPat pprPatBndr :: OutputableBndr name => name -> SDoc pprPatBndr var -- Print with type info if -dppr-debug is on = getPprStyle $ \ sty -> if debugStyle sty then parens (pprBndr LambdaBind var) -- Could pass the site to pprPat -- but is it worth it? else pprPrefixOcc var pprParendLPat :: (OutputableBndrId p) => PprPrec -> LPat (GhcPass p) -> SDoc pprParendLPat p = pprParendPat p . unLoc pprParendPat :: (OutputableBndrId p) => PprPrec -> Pat (GhcPass p) -> SDoc pprParendPat p pat = sdocWithDynFlags $ \ dflags -> if need_parens dflags pat then parens (pprPat pat) else pprPat pat where need_parens dflags pat | CoPat {} <- pat = gopt Opt_PrintTypecheckerElaboration dflags | otherwise = patNeedsParens p pat -- For a CoPat we need parens if we are going to show it, which -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper) -- But otherwise the CoPat is discarded, so it -- is the pattern inside that matters. Sigh. pprPat :: (OutputableBndrId p) => Pat (GhcPass p) -> SDoc pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar) pprPat (WildPat _) = char '_' pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat pprPat (BangPat _ pat) = char '!' <> pprParendLPat appPrec pat pprPat (AsPat _ name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat appPrec pat] pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat] pprPat (ParPat _ pat) = parens (ppr pat) pprPat (LitPat _ s) = ppr s pprPat (NPat _ l Nothing _) = ppr l pprPat (NPat _ l (Just _) _) = char '-' <> ppr l pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr n, char '+', ppr k] pprPat (SplicePat _ splice) = pprSplice splice pprPat (CoPat _ co pat _) = pprHsWrapper co $ \parens -> if parens then pprParendPat appPrec pat else pprPat pat pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (ListPat _ pats) = brackets (interpp'SP pats) pprPat (TuplePat _ pats bx) -- Special-case unary boxed tuples so that they are pretty-printed as -- `Unit x`, not `(x)` | [pat] <- pats , Boxed <- bx = hcat [text (mkTupleStr Boxed 1), pprParendLPat appPrec pat] | otherwise = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity) pprPat (ConPatIn con details) = pprUserCon (unLoc con) details pprPat (ConPatOut { pat_con = con , pat_tvs = tvs , pat_dicts = dicts , pat_binds = binds , pat_args = details }) = sdocWithDynFlags $ \dflags -> -- Tiresome; in TcBinds.tcRhs we print out a -- typechecked Pat in an error message, -- and we want to make sure it prints nicely if gopt Opt_PrintTypecheckerElaboration dflags then ppr con <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) , ppr binds]) <+> pprConArgs details else pprUserCon (unLoc con) details pprPat (XPat n) = noExtCon n pprUserCon :: (OutputableBndr con, OutputableBndrId p) => con -> HsConPatDetails (GhcPass p) -> SDoc pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 pprUserCon c details = pprPrefixOcc c <+> pprConArgs details pprConArgs :: (OutputableBndrId p) => HsConPatDetails (GhcPass p) -> SDoc pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats) pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 , pprParendLPat appPrec p2 ] pprConArgs (RecCon rpats) = ppr rpats instance (Outputable arg) => Outputable (HsRecFields p arg) where ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) = braces (fsep (punctuate comma (map ppr flds))) ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) }) = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) where dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) instance (Outputable p, Outputable arg) => Outputable (HsRecField' p arg) where ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg, hsRecPun = pun }) = ppr f <+> (ppUnless pun $ equals <+> ppr arg) {- ************************************************************************ * * * Building patterns * * ************************************************************************ -} mkPrefixConPat :: DataCon -> [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p) -- Make a vanilla Prefix constructor pattern mkPrefixConPat dc pats tys = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc) , pat_tvs = [] , pat_dicts = [] , pat_binds = emptyTcEvBinds , pat_args = PrefixCon pats , pat_arg_tys = tys , pat_wrap = idHsWrapper } mkNilPat :: Type -> OutPat (GhcPass p) mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p) mkCharLitPat src c = mkPrefixConPat charDataCon [noLoc $ LitPat noExtField (HsCharPrim src c)] [] {- ************************************************************************ * * * Predicates for checking things about pattern-lists in EquationInfo * * * ************************************************************************ \subsection[Pat-list-predicates]{Look for interesting things in patterns} Unlike in the Wadler chapter, where patterns are either ``variables'' or ``constructors,'' here we distinguish between: \begin{description} \item[unfailable:] Patterns that cannot fail to match: variables, wildcards, and lazy patterns. These are the irrefutable patterns; the two other categories are refutable patterns. \item[constructor:] A non-literal constructor pattern (see next category). \item[literal patterns:] At least the numeric ones may be overloaded. \end{description} A pattern is in {\em exactly one} of the above three categories; `as' patterns are treated specially, of course. The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. -} isBangedLPat :: LPat (GhcPass p) -> Bool isBangedLPat = isBangedPat . unLoc isBangedPat :: Pat (GhcPass p) -> Bool isBangedPat (ParPat _ p) = isBangedLPat p isBangedPat (BangPat {}) = True isBangedPat _ = False looksLazyPatBind :: HsBind (GhcPass p) -> Bool -- Returns True of anything *except* -- a StrictHsBind (as above) or -- a VarPat -- In particular, returns True of a pattern binding with a compound pattern, like (I# x) -- Looks through AbsBinds looksLazyPatBind (PatBind { pat_lhs = p }) = looksLazyLPat p looksLazyPatBind (AbsBinds { abs_binds = binds }) = anyBag (looksLazyPatBind . unLoc) binds looksLazyPatBind _ = False looksLazyLPat :: LPat (GhcPass p) -> Bool looksLazyLPat = looksLazyPat . unLoc looksLazyPat :: Pat (GhcPass p) -> Bool looksLazyPat (ParPat _ p) = looksLazyLPat p looksLazyPat (AsPat _ _ p) = looksLazyLPat p looksLazyPat (BangPat {}) = False looksLazyPat (VarPat {}) = False looksLazyPat (WildPat {}) = False looksLazyPat _ = True isIrrefutableHsPat :: (OutputableBndrId p) => LPat (GhcPass p) -> Bool -- (isIrrefutableHsPat p) is true if matching against p cannot fail, -- in the sense of falling through to the next pattern. -- (NB: this is not quite the same as the (silly) defn -- in 3.17.2 of the Haskell 98 report.) -- -- WARNING: isIrrefutableHsPat returns False if it's in doubt. -- Specifically on a ConPatIn, which is what it sees for a -- (LPat Name) in the renamer, it doesn't know the size of the -- constructor family, so it returns False. Result: only -- tuple patterns are considered irrefuable at the renamer stage. -- -- But if it returns True, the pattern is definitely irrefutable isIrrefutableHsPat = goL where goL = go . unLoc go (WildPat {}) = True go (VarPat {}) = True go (LazyPat {}) = True go (BangPat _ pat) = goL pat go (CoPat _ _ pat _) = go pat go (ParPat _ pat) = goL pat go (AsPat _ _ pat) = goL pat go (ViewPat _ _ pat) = goL pat go (SigPat _ pat _) = goL pat go (TuplePat _ pats _) = all goL pats go (SumPat {}) = False -- See Note [Unboxed sum patterns aren't irrefutable] go (ListPat {}) = False go (ConPatIn {}) = False -- Conservative go (ConPatOut { pat_con = (dL->L _ (RealDataCon con)) , pat_args = details }) = isJust (tyConSingleDataCon_maybe (dataConTyCon con)) -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because -- the latter is false of existentials. See #4439 && all goL (hsConPatArgs details) go (ConPatOut { pat_con = (dL->L _ (PatSynCon _pat)) }) = False -- Conservative go (ConPatOut{}) = panic "ConPatOut:Impossible Match" -- due to #15884 go (LitPat {}) = False go (NPat {}) = False go (NPlusKPat {}) = False -- We conservatively assume that no TH splices are irrefutable -- since we cannot know until the splice is evaluated. go (SplicePat {}) = False go (XPat {}) = False {- Note [Unboxed sum patterns aren't irrefutable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as patterns. A simple example that demonstrates this is from #14228: pattern Just' x = (# x | #) pattern Nothing' = (# | () #) foo x = case x of Nothing' -> putStrLn "nothing" Just' -> putStrLn "just" In foo, the pattern Nothing' (that is, (# x | #)) is certainly not irrefutable, as does not match an unboxed sum value of the same arity—namely, (# | y #) (covered by Just'). In fact, no unboxed sum pattern is irrefutable, since the minimum unboxed sum arity is 2. Failing to mark unboxed sum patterns as non-irrefutable would cause the Just' case in foo to be unreachable, as GHC would mistakenly believe that Nothing' is the only thing that could possibly be matched! -} -- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs -- parentheses under precedence @p@. patNeedsParens :: PprPrec -> Pat p -> Bool patNeedsParens p = go where go (NPlusKPat {}) = p > opPrec go (SplicePat {}) = False go (ConPatIn _ ds) = conPatNeedsParens p ds go cp@(ConPatOut {}) = conPatNeedsParens p (pat_args cp) go (SigPat {}) = p >= sigPrec go (ViewPat {}) = True go (CoPat _ _ p _) = go p go (WildPat {}) = False go (VarPat {}) = False go (LazyPat {}) = False go (BangPat {}) = False go (ParPat {}) = False go (AsPat {}) = False go (TuplePat {}) = False go (SumPat {}) = False go (ListPat {}) = False go (LitPat _ l) = hsLitNeedsParens p l go (NPat _ lol _ _) = hsOverLitNeedsParens p (unLoc lol) go (XPat {}) = True -- conservative default -- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@ -- needs parentheses under precedence @p@. conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool conPatNeedsParens p = go where go (PrefixCon args) = p >= appPrec && not (null args) go (InfixCon {}) = p >= opPrec go (RecCon {}) = False -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p) parenthesizePat p lpat@(dL->L loc pat) | patNeedsParens p pat = cL loc (ParPat noExtField lpat) | otherwise = lpat {- % Collect all EvVars from all constructor patterns -} -- May need to add more cases collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar collectEvVarsPats = unionManyBags . map collectEvVarsPat collectEvVarsLPat :: LPat GhcTc -> Bag EvVar collectEvVarsLPat = collectEvVarsPat . unLoc collectEvVarsPat :: Pat GhcTc -> Bag EvVar collectEvVarsPat pat = case pat of LazyPat _ p -> collectEvVarsLPat p AsPat _ _ p -> collectEvVarsLPat p ParPat _ p -> collectEvVarsLPat p BangPat _ p -> collectEvVarsLPat p ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps SumPat _ p _ _ -> collectEvVarsLPat p ConPatOut {pat_dicts = dicts, pat_args = args} -> unionBags (listToBag dicts) $ unionManyBags $ map collectEvVarsLPat $ hsConPatArgs args SigPat _ p _ -> collectEvVarsLPat p CoPat _ _ p _ -> collectEvVarsPat p ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn" _other_pat -> emptyBag ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/PlaceHolder.hs0000644000000000000000000000420013713635744021005 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} module GHC.Hs.PlaceHolder where import Name import NameSet import RdrName import Var {- %************************************************************************ %* * \subsection{Annotating the syntax} %* * %************************************************************************ -} -- NB: These are intentionally open, allowing API consumers (like Haddock) -- to declare new instances placeHolderNamesTc :: NameSet placeHolderNamesTc = emptyNameSet {- TODO:AZ: remove this, and check if we still need all the UndecidableInstances Note [Pass sensitive types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Since the same AST types are re-used through parsing,renaming and type checking there are naturally some places in the AST that do not have any meaningful value prior to the pass they are assigned a value. Historically these have been filled in with place holder values of the form panic "error message" This has meant the AST is difficult to traverse using standard generic programming techniques. The problem is addressed by introducing pass-specific data types, implemented as a pair of open type families, one for PostTc and one for PostRn. These are then explicitly populated with a PlaceHolder value when they do not yet have meaning. In terms of actual usage, we have the following PostTc id Kind PostTc id Type PostRn id Fixity PostRn id NameSet TcId and Var are synonyms for Id Unfortunately the type checker termination checking conditions fail for the DataId constraint type based on this, so even though it is safe the UndecidableInstances pragma is required where this is used. -} -- |Follow the @id@, but never beyond Name. This is used in a 'HsMatchContext', -- for printing messages related to a 'Match' type family NameOrRdrName id where NameOrRdrName Id = Name NameOrRdrName Name = Name NameOrRdrName RdrName = RdrName ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/Types.hs0000644000000000000000000020454513713635744017745 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 GHC.Hs.Types: Abstract syntax: user-defined types -} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} module GHC.Hs.Types ( HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind, HsTyVarBndr(..), LHsTyVarBndr, ForallVisFlag(..), LHsQTyVars(..), HsImplicitBndrs(..), HsWildCardBndrs(..), LHsSigType, LHsSigWcType, LHsWcType, HsTupleSort(..), HsContext, LHsContext, noLHsContext, HsTyLit(..), HsIPName(..), hsIPNameFS, HsArg(..), numVisibleArgs, LHsTypeArg, LBangType, BangType, HsSrcBang(..), HsImplBang(..), SrcStrictness(..), SrcUnpackedness(..), getBangType, getBangStrictness, ConDeclField(..), LConDeclField, pprConDeclFields, HsConDetails(..), FieldOcc(..), LFieldOcc, mkFieldOcc, AmbiguousFieldOcc(..), mkAmbiguousFieldOcc, rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, unambiguousFieldOcc, ambiguousFieldOcc, mkAnonWildCardTy, pprAnonWildCard, mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs, isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy, hsScopedTvs, hsWcScopedTvs, dropWildCards, hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames, splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, splitLHsPatSynTy, splitLHsForAllTyInvis, splitLHsQualTy, splitLHsSigmaTyInvis, splitHsFunType, hsTyGetAppHead_maybe, mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, ignoreParens, hsSigType, hsSigWcType, hsLTyVarBndrToType, hsLTyVarBndrsToTypes, hsTyKindSig, hsConDetailsArgs, -- Printing pprHsType, pprHsForAll, pprHsForAllExtra, pprHsExplicitForAll, pprLHsContext, hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext ) where #include "GhclibHsVersions.h" import GhcPrelude import {-# SOURCE #-} GHC.Hs.Expr ( HsSplice, pprSplice ) import GHC.Hs.Extension import Id ( Id ) import Name( Name, NamedThing(getName) ) import RdrName ( RdrName ) import DataCon( HsSrcBang(..), HsImplBang(..), SrcStrictness(..), SrcUnpackedness(..) ) import TysPrim( funTyConName ) import TysWiredIn( mkTupleStr ) import Type import GHC.Hs.Doc import BasicTypes import SrcLoc import Outputable import FastString import Maybes( isJust ) import Util ( count, debugIsOn ) import Data.Data hiding ( Fixity, Prefix, Infix ) {- ************************************************************************ * * \subsection{Bang annotations} * * ************************************************************************ -} -- | Located Bang Type type LBangType pass = Located (BangType pass) -- | Bang Type -- -- In the parser, strictness and packedness annotations bind more tightly -- than docstrings. This means that when consuming a 'BangType' (and looking -- for 'HsBangTy') we must be ready to peer behind a potential layer of -- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example. type BangType pass = HsType pass -- Bangs are in the HsType data type getBangType :: LHsType a -> LHsType a getBangType (L _ (HsBangTy _ _ lty)) = lty getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) = addCLoc lty lds (HsDocTy x lty lds) getBangType lty = lty getBangStrictness :: LHsType a -> HsSrcBang getBangStrictness (L _ (HsBangTy _ s _)) = s getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict) {- ************************************************************************ * * \subsection{Data types} * * ************************************************************************ This is the syntax for types as seen in type signatures. Note [HsBSig binder lists] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a binder (or pattern) decorated with a type or kind, \ (x :: a -> a). blah forall (a :: k -> *) (b :: k). blah Then we use a LHsBndrSig on the binder, so that the renamer can decorate it with the variables bound by the pattern ('a' in the first example, 'k' in the second), assuming that neither of them is in scope already See also Note [Kind and type-variable binders] in RnTypes Note [HsType binders] ~~~~~~~~~~~~~~~~~~~~~ The system for recording type and kind-variable binders in HsTypes is a bit complicated. Here's how it works. * In a HsType, HsForAllTy represents an /explicit, user-written/ 'forall' e.g. forall a b. {...} or forall a b -> {...} HsQualTy represents an /explicit, user-written/ context e.g. (Eq a, Show a) => ... The context can be empty if that's what the user wrote These constructors represent what the user wrote, no more and no less. * The ForallVisFlag field of HsForAllTy represents whether a forall is invisible (e.g., forall a b. {...}, with a dot) or visible (e.g., forall a b -> {...}, with an arrow). * HsTyVarBndr describes a quantified type variable written by the user. For example f :: forall a (b :: *). blah here 'a' and '(b::*)' are each a HsTyVarBndr. A HsForAllTy has a list of LHsTyVarBndrs. * HsImplicitBndrs is a wrapper that gives the implicitly-quantified kind and type variables of the wrapped thing. It is filled in by the renamer. For example, if the user writes f :: a -> a the HsImplicitBinders binds the 'a' (not a HsForAllTy!). NB: this implicit quantification is purely lexical: we bind any type or kind variables that are not in scope. The type checker may subsequently quantify over further kind variables. * HsWildCardBndrs is a wrapper that binds the wildcard variables of the wrapped thing. It is filled in by the renamer f :: _a -> _ The enclosing HsWildCardBndrs binds the wildcards _a and _. * The explicit presence of these wrappers specifies, in the HsSyn, exactly where implicit quantification is allowed, and where wildcards are allowed. * LHsQTyVars is used in data/class declarations, where the user gives explicit *type* variable bindings, but we need to implicitly bind *kind* variables. For example class C (a :: k -> *) where ... The 'k' is implicitly bound in the hsq_tvs field of LHsQTyVars Note [The wildcard story for types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Types can have wildcards in them, to support partial type signatures, like f :: Int -> (_ , _a) -> _a A wildcard in a type can be * An anonymous wildcard, written '_' In HsType this is represented by HsWildCardTy. The renamer leaves it untouched, and it is later given fresh meta tyvars in the typechecker. * A named wildcard, written '_a', '_foo', etc In HsType this is represented by (HsTyVar "_a") i.e. a perfectly ordinary type variable that happens to start with an underscore Note carefully: * When NamedWildCards is off, type variables that start with an underscore really /are/ ordinary type variables. And indeed, even when NamedWildCards is on you can bind _a explicitly as an ordinary type variable: data T _a _b = MkT _b _a Or even: f :: forall _a. _a -> _b Here _a is an ordinary forall'd binder, but (With NamedWildCards) _b is a named wildcard. (See the comments in #10982) * Named wildcards are bound by the HsWildCardBndrs construct, which wraps types that are allowed to have wildcards. Unnamed wildcards however are left unchanged until typechecking, where we give them fresh wild tyavrs and determine whether or not to emit hole constraints on each wildcard (we don't if it's a visible type/kind argument or a type family pattern). See related notes Note [Wildcards in visible kind application] and Note [Wildcards in visible type application] in TcHsType.hs * After type checking is done, we report what types the wildcards got unified with. Note [Ordering of implicit variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Since the advent of -XTypeApplications, GHC makes promises about the ordering of implicit variable quantification. Specifically, we offer that implicitly quantified variables (such as those in const :: a -> b -> a, without a `forall`) will occur in left-to-right order of first occurrence. Here are a few examples: const :: a -> b -> a -- forall a b. ... f :: Eq a => b -> a -> a -- forall a b. ... contexts are included type a <-< b = b -> a g :: a <-< b -- forall a b. ... type synonyms matter class Functor f where fmap :: (a -> b) -> f a -> f b -- forall f a b. ... -- The f is quantified by the class, so only a and b are considered in fmap This simple story is complicated by the possibility of dependency: all variables must come after any variables mentioned in their kinds. typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ... The k comes first because a depends on k, even though the k appears later than the a in the code. Thus, GHC does a *stable topological sort* on the variables. By "stable", we mean that any two variables who do not depend on each other preserve their existing left-to-right ordering. Implicitly bound variables are collected by the extract- family of functions (extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.) in RnTypes. These functions thus promise to keep left-to-right ordering. Look for pointers to this note to see the places where the action happens. Note that we also maintain this ordering in kind signatures. Even though there's no visible kind application (yet), having implicit variables be quantified in left-to-right order in kind signatures is nice since: * It's consistent with the treatment for type signatures. * It can affect how types are displayed with -fprint-explicit-kinds (see #15568 for an example), which is a situation where knowing the order in which implicit variables are quantified can be useful. * In the event that visible kind application is implemented, the order in which we would expect implicit variables to be ordered in kinds will have already been established. -} -- | Located Haskell Context type LHsContext pass = Located (HsContext pass) -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit' -- For details on above see note [Api annotations] in ApiAnnotation noLHsContext :: LHsContext pass -- Use this when there is no context in the original program -- It would really be more kosher to use a Maybe, to distinguish -- class () => C a where ... -- from -- class C a where ... noLHsContext = noLoc [] -- | Haskell Context type HsContext pass = [LHsType pass] -- | Located Haskell Type type LHsType pass = Located (HsType pass) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when -- in a list -- For details on above see note [Api annotations] in ApiAnnotation -- | Haskell Kind type HsKind pass = HsType pass -- | Located Haskell Kind type LHsKind pass = Located (HsKind pass) -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation -------------------------------------------------- -- LHsQTyVars -- The explicitly-quantified binders in a data/type declaration -- | Located Haskell Type Variable Binder type LHsTyVarBndr pass = Located (HsTyVarBndr pass) -- See Note [HsType binders] -- | Located Haskell Quantified Type Variables data LHsQTyVars pass -- See Note [HsType binders] = HsQTvs { hsq_ext :: XHsQTvs pass , hsq_explicit :: [LHsTyVarBndr pass] -- Explicit variables, written by the user -- See Note [HsForAllTy tyvar binders] } | XLHsQTyVars (XXLHsQTyVars pass) type HsQTvsRn = [Name] -- Implicit variables -- For example, in data T (a :: k1 -> k2) = ... -- the 'a' is explicit while 'k1', 'k2' are implicit type instance XHsQTvs GhcPs = NoExtField type instance XHsQTvs GhcRn = HsQTvsRn type instance XHsQTvs GhcTc = HsQTvsRn type instance XXLHsQTyVars (GhcPass _) = NoExtCon mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs } hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass] hsQTvExplicit = hsq_explicit emptyLHsQTvs :: LHsQTyVars GhcRn emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] } isEmptyLHsQTvs :: LHsQTyVars GhcRn -> Bool isEmptyLHsQTvs (HsQTvs { hsq_ext = imp, hsq_explicit = exp }) = null imp && null exp isEmptyLHsQTvs _ = False ------------------------------------------------ -- HsImplicitBndrs -- Used to quantify the implicit binders of a type -- * Implicit binders of a type signature (LHsSigType/LHsSigWcType) -- * Patterns in a type/data family instance (HsTyPats) -- | Haskell Implicit Binders data HsImplicitBndrs pass thing -- See Note [HsType binders] = HsIB { hsib_ext :: XHsIB pass thing -- after renamer: [Name] -- Implicitly-bound kind & type vars -- Order is important; see -- Note [Ordering of implicit variables] -- in RnTypes , hsib_body :: thing -- Main payload (type or list of types) } | XHsImplicitBndrs (XXHsImplicitBndrs pass thing) type instance XHsIB GhcPs _ = NoExtField type instance XHsIB GhcRn _ = [Name] type instance XHsIB GhcTc _ = [Name] type instance XXHsImplicitBndrs (GhcPass _) _ = NoExtCon -- | Haskell Wildcard Binders data HsWildCardBndrs pass thing -- See Note [HsType binders] -- See Note [The wildcard story for types] = HsWC { hswc_ext :: XHsWC pass thing -- after the renamer -- Wild cards, only named -- See Note [Wildcards in visible kind application] , hswc_body :: thing -- Main payload (type or list of types) -- If there is an extra-constraints wildcard, -- it's still there in the hsc_body. } | XHsWildCardBndrs (XXHsWildCardBndrs pass thing) type instance XHsWC GhcPs b = NoExtField type instance XHsWC GhcRn b = [Name] type instance XHsWC GhcTc b = [Name] type instance XXHsWildCardBndrs (GhcPass _) b = NoExtCon -- | Located Haskell Signature Type type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only -- | Located Haskell Wildcard Type type LHsWcType pass = HsWildCardBndrs pass (LHsType pass) -- Wildcard only -- | Located Haskell Signature Wildcard Type type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both -- See Note [Representing type signatures] hsImplicitBody :: HsImplicitBndrs (GhcPass p) thing -> thing hsImplicitBody (HsIB { hsib_body = body }) = body hsImplicitBody (XHsImplicitBndrs nec) = noExtCon nec hsSigType :: LHsSigType (GhcPass p) -> LHsType (GhcPass p) hsSigType = hsImplicitBody hsSigWcType :: LHsSigWcType pass -> LHsType pass hsSigWcType sig_ty = hsib_body (hswc_body sig_ty) dropWildCards :: LHsSigWcType pass -> LHsSigType pass -- Drop the wildcard part of a LHsSigWcType dropWildCards sig_ty = hswc_body sig_ty {- Note [Representing type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ HsSigType is used to represent an explicit user type signature such as f :: a -> a or g (x :: a -> a) = x A HsSigType is just a HsImplicitBndrs wrapping a LHsType. * The HsImplicitBndrs binds the /implicitly/ quantified tyvars * The LHsType binds the /explicitly/ quantified tyvars E.g. For a signature like f :: forall (a::k). blah we get HsIB { hsib_vars = [k] , hsib_body = HsForAllTy { hst_bndrs = [(a::*)] , hst_body = blah } The implicit kind variable 'k' is bound by the HsIB; the explicitly forall'd tyvar 'a' is bound by the HsForAllTy -} mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing mkHsImplicitBndrs x = HsIB { hsib_ext = noExtField , hsib_body = x } mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing mkHsWildCardBndrs x = HsWC { hswc_body = x , hswc_ext = noExtField } -- Add empty binders. This is a bit suspicious; what if -- the wrapped thing had free type variables? mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing mkEmptyImplicitBndrs x = HsIB { hsib_ext = [] , hsib_body = x } mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing mkEmptyWildCardBndrs x = HsWC { hswc_body = x , hswc_ext = [] } -------------------------------------------------- -- | These names are used early on to store the names of implicit -- parameters. They completely disappear after type-checking. newtype HsIPName = HsIPName FastString deriving( Eq, Data ) hsIPNameFS :: HsIPName -> FastString hsIPNameFS (HsIPName n) = n instance Outputable HsIPName where ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters instance OutputableBndr HsIPName where pprBndr _ n = ppr n -- Simple for now pprInfixOcc n = ppr n pprPrefixOcc n = ppr n -------------------------------------------------- -- | Haskell Type Variable Binder data HsTyVarBndr pass = UserTyVar -- no explicit kinding (XUserTyVar pass) (Located (IdP pass)) -- See Note [Located RdrNames] in GHC.Hs.Expr | KindedTyVar (XKindedTyVar pass) (Located (IdP pass)) (LHsKind pass) -- The user-supplied kind signature -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation | XTyVarBndr (XXTyVarBndr pass) type instance XUserTyVar (GhcPass _) = NoExtField type instance XKindedTyVar (GhcPass _) = NoExtField type instance XXTyVarBndr (GhcPass _) = NoExtCon -- | Does this 'HsTyVarBndr' come with an explicit kind annotation? isHsKindedTyVar :: HsTyVarBndr pass -> Bool isHsKindedTyVar (UserTyVar {}) = False isHsKindedTyVar (KindedTyVar {}) = True isHsKindedTyVar (XTyVarBndr {}) = False -- | Do all type variables in this 'LHsQTyVars' come with kind annotations? hsTvbAllKinded :: LHsQTyVars pass -> Bool hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit instance NamedThing (HsTyVarBndr GhcRn) where getName (UserTyVar _ v) = unLoc v getName (KindedTyVar _ v _) = unLoc v getName (XTyVarBndr nec) = noExtCon nec -- | Haskell Type data HsType pass = HsForAllTy -- See Note [HsType binders] { hst_xforall :: XForAllTy pass , hst_fvf :: ForallVisFlag -- Is this `forall a -> {...}` or -- `forall a. {...}`? , hst_bndrs :: [LHsTyVarBndr pass] -- Explicit, user-supplied 'forall a b c' , hst_body :: LHsType pass -- body type } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall', -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' -- For details on above see note [Api annotations] in ApiAnnotation | HsQualTy -- See Note [HsType binders] { hst_xqual :: XQualTy pass , hst_ctxt :: LHsContext pass -- Context C => blah , hst_body :: LHsType pass } | HsTyVar (XTyVar pass) PromotionFlag -- Whether explicitly promoted, -- for the pretty printer (Located (IdP pass)) -- Type variable, type constructor, or data constructor -- see Note [Promotions (HsTyVar)] -- See Note [Located RdrNames] in GHC.Hs.Expr -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation | HsAppTy (XAppTy pass) (LHsType pass) (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation | HsAppKindTy (XAppKindTy pass) -- type level type app (LHsType pass) (LHsKind pass) | HsFunTy (XFunTy pass) (LHsType pass) -- function type (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow', -- For details on above see note [Api annotations] in ApiAnnotation | HsListTy (XListTy pass) (LHsType pass) -- Element type -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, -- 'ApiAnnotation.AnnClose' @']'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsTupleTy (XTupleTy pass) HsTupleSort [LHsType pass] -- Element types (length gives arity) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@, -- 'ApiAnnotation.AnnClose' @')' or '#)'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsSumTy (XSumTy pass) [LHsType pass] -- Element types (length gives arity) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, -- 'ApiAnnotation.AnnClose' '#)'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsOpTy (XOpTy pass) (LHsType pass) (Located (IdP pass)) (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation | HsParTy (XParTy pass) (LHsType pass) -- See Note [Parens in HsSyn] in GHC.Hs.Expr -- Parenthesis preserved for the precedence re-arrangement in RnTypes -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsIParamTy (XIParamTy pass) (Located HsIPName) -- (?x :: ty) (LHsType pass) -- Implicit parameters as they occur in -- contexts -- ^ -- > (?x :: ty) -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation | HsStarTy (XStarTy pass) Bool -- Is this the Unicode variant? -- Note [HsStarTy] -- ^ - 'ApiAnnotation.AnnKeywordId' : None | HsKindSig (XKindSig pass) (LHsType pass) -- (ty :: kind) (LHsKind pass) -- A type with a kind signature -- ^ -- > (ty :: kind) -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsSpliceTy (XSpliceTy pass) (HsSplice pass) -- Includes quasi-quotes -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsDocTy (XDocTy pass) (LHsType pass) LHsDocString -- A documented type -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation | HsBangTy (XBangTy pass) HsSrcBang (LHsType pass) -- Bang-style type annotations -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@, -- 'ApiAnnotation.AnnClose' @'#-}'@ -- 'ApiAnnotation.AnnBang' @\'!\'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsRecTy (XRecTy pass) [LConDeclField pass] -- Only in data type declarations -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnClose' @'}'@ -- For details on above see note [Api annotations] in ApiAnnotation -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed* -- -- Core Type through HsSyn. -- -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation | HsExplicitListTy -- A promoted explicit list (XExplicitListTy pass) PromotionFlag -- whether explcitly promoted, for pretty printer [LHsType pass] -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@, -- 'ApiAnnotation.AnnClose' @']'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsExplicitTupleTy -- A promoted explicit tuple (XExplicitTupleTy pass) [LHsType pass] -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation | HsTyLit (XTyLit pass) HsTyLit -- A promoted numeric literal. -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation | HsWildCardTy (XWildCardTy pass) -- A type wildcard -- See Note [The wildcard story for types] -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation -- For adding new constructors via Trees that Grow | XHsType (XXType pass) data NewHsTypeX = NHsCoreTy Type -- An escape hatch for tunnelling a *closed* -- Core Type through HsSyn. deriving Data -- ^ - 'ApiAnnotation.AnnKeywordId' : None instance Outputable NewHsTypeX where ppr (NHsCoreTy ty) = ppr ty type instance XForAllTy (GhcPass _) = NoExtField type instance XQualTy (GhcPass _) = NoExtField type instance XTyVar (GhcPass _) = NoExtField type instance XAppTy (GhcPass _) = NoExtField type instance XFunTy (GhcPass _) = NoExtField type instance XListTy (GhcPass _) = NoExtField type instance XTupleTy (GhcPass _) = NoExtField type instance XSumTy (GhcPass _) = NoExtField type instance XOpTy (GhcPass _) = NoExtField type instance XParTy (GhcPass _) = NoExtField type instance XIParamTy (GhcPass _) = NoExtField type instance XStarTy (GhcPass _) = NoExtField type instance XKindSig (GhcPass _) = NoExtField type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives type instance XSpliceTy GhcPs = NoExtField type instance XSpliceTy GhcRn = NoExtField type instance XSpliceTy GhcTc = Kind type instance XDocTy (GhcPass _) = NoExtField type instance XBangTy (GhcPass _) = NoExtField type instance XRecTy (GhcPass _) = NoExtField type instance XExplicitListTy GhcPs = NoExtField type instance XExplicitListTy GhcRn = NoExtField type instance XExplicitListTy GhcTc = Kind type instance XExplicitTupleTy GhcPs = NoExtField type instance XExplicitTupleTy GhcRn = NoExtField type instance XExplicitTupleTy GhcTc = [Kind] type instance XTyLit (GhcPass _) = NoExtField type instance XWildCardTy (GhcPass _) = NoExtField type instance XXType (GhcPass _) = NewHsTypeX -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following -- | Haskell Type Literal data HsTyLit = HsNumTy SourceText Integer | HsStrTy SourceText FastString deriving Data {- Note [HsForAllTy tyvar binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ After parsing: * Implicit => empty Explicit => the variables the user wrote After renaming * Implicit => the *type* variables free in the type Explicit => the variables the user wrote (renamed) Qualified currently behaves exactly as Implicit, but it is deprecated to use it for implicit quantification. In this case, GHC 7.10 gives a warning; see Note [Context quantification] in RnTypes, and #4426. In GHC 8.0, Qualified will no longer bind variables and this will become an error. The kind variables bound in the hsq_implicit field come both a) from the kind signatures on the kind vars (eg k1) b) from the scope of the forall (eg k2) Example: f :: forall (a::k1) b. T a (b::k2) Note [Unit tuples] ~~~~~~~~~~~~~~~~~~ Consider the type type instance F Int = () We want to parse that "()" as HsTupleTy HsBoxedOrConstraintTuple [], NOT as HsTyVar unitTyCon Why? Because F might have kind (* -> Constraint), so we when parsing we don't know if that tuple is going to be a constraint tuple or an ordinary unit tuple. The HsTupleSort flag is specifically designed to deal with that, but it has to work for unit tuples too. Note [Promotions (HsTyVar)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ HsTyVar: A name in a type or kind. Here are the allowed namespaces for the name. In a type: Var: not allowed Data: promoted data constructor Tv: type variable TcCls before renamer: type constructor, class constructor, or promoted data constructor TcCls after renamer: type constructor or class constructor In a kind: Var, Data: not allowed Tv: kind variable TcCls: kind constructor or promoted type constructor The 'Promoted' field in an HsTyVar captures whether the type was promoted in the source code by prefixing an apostrophe. Note [HsStarTy] ~~~~~~~~~~~~~~~ When the StarIsType extension is enabled, we want to treat '*' and its Unicode variant identically to 'Data.Kind.Type'. Unfortunately, doing so in the parser would mean that when we pretty-print it back, we don't know whether the user wrote '*' or 'Type', and lose the parse/ppr roundtrip property. As a workaround, we parse '*' as HsStarTy (if it stands for 'Data.Kind.Type') and then desugar it to 'Data.Kind.Type' in the typechecker (see tc_hs_type). When '*' is a regular type operator (StarIsType is disabled), HsStarTy is not involved. Note [Promoted lists and tuples] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Notice the difference between HsListTy HsExplicitListTy HsTupleTy HsExplicitListTupleTy E.g. f :: [Int] HsListTy g3 :: T '[] All these use g2 :: T '[True] HsExplicitListTy g1 :: T '[True,False] g1a :: T [True,False] (can omit ' where unambiguous) kind of T :: [Bool] -> * This kind uses HsListTy! E.g. h :: (Int,Bool) HsTupleTy; f is a pair k :: S '(True,False) HsExplicitTypleTy; S is indexed by a type-level pair of booleans kind of S :: (Bool,Bool) -> * This kind uses HsExplicitTupleTy Note [Distinguishing tuple kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Apart from promotion, tuples can have one of three different kinds: x :: (Int, Bool) -- Regular boxed tuples f :: Int# -> (# Int#, Int# #) -- Unboxed tuples g :: (Eq a, Ord a) => a -- Constraint tuples For convenience, internally we use a single constructor for all of these, namely HsTupleTy, but keep track of the tuple kind (in the first argument to HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing, because of the #. However, with -XConstraintKinds we can only distinguish between constraint and boxed tuples during type checking, in general. Hence the four constructors of HsTupleSort: HsUnboxedTuple -> Produced by the parser HsBoxedTuple -> Certainly a boxed tuple HsConstraintTuple -> Certainly a constraint tuple HsBoxedOrConstraintTuple -> Could be a boxed or a constraint tuple. Produced by the parser only, disappears after type checking -} -- | Haskell Tuple Sort data HsTupleSort = HsUnboxedTuple | HsBoxedTuple | HsConstraintTuple | HsBoxedOrConstraintTuple deriving Data -- | Located Constructor Declaration Field type LConDeclField pass = Located (ConDeclField pass) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when -- in a list -- For details on above see note [Api annotations] in ApiAnnotation -- | Constructor Declaration Field data ConDeclField pass -- Record fields have Haddoc docs on them = ConDeclField { cd_fld_ext :: XConDeclField pass, cd_fld_names :: [LFieldOcc pass], -- ^ See Note [ConDeclField passs] cd_fld_type :: LBangType pass, cd_fld_doc :: Maybe LHsDocString } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation | XConDeclField (XXConDeclField pass) type instance XConDeclField (GhcPass _) = NoExtField type instance XXConDeclField (GhcPass _) = NoExtCon instance OutputableBndrId p => Outputable (ConDeclField (GhcPass p)) where ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty ppr (XConDeclField x) = ppr x -- HsConDetails is used for patterns/expressions *and* for data type -- declarations -- | Haskell Constructor Details data HsConDetails arg rec = PrefixCon [arg] -- C p1 p2 p3 | RecCon rec -- C { x = p1, y = p2 } | InfixCon arg arg -- p1 `C` p2 deriving Data instance (Outputable arg, Outputable rec) => Outputable (HsConDetails arg rec) where ppr (PrefixCon args) = text "PrefixCon" <+> ppr args ppr (RecCon rec) = text "RecCon:" <+> ppr rec ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] hsConDetailsArgs :: HsConDetails (LHsType a) (Located [LConDeclField a]) -> [LHsType a] hsConDetailsArgs details = case details of InfixCon a b -> [a,b] PrefixCon xs -> xs RecCon r -> map (cd_fld_type . unLoc) (unLoc r) {- Note [ConDeclField passs] ~~~~~~~~~~~~~~~~~~~~~~~~~ A ConDeclField contains a list of field occurrences: these always include the field label as the user wrote it. After the renamer, it will additionally contain the identity of the selector function in the second component. Due to DuplicateRecordFields, the OccName of the selector function may have been mangled, which is why we keep the original field label separately. For example, when DuplicateRecordFields is enabled data T = MkT { x :: Int } gives ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }. -} ----------------------- -- A valid type must have a for-all at the top of the type, or of the fn arg -- types --------------------- hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name] -- Get the lexically-scoped type variables of a HsSigType -- - the explicitly-given forall'd type variables -- - the named wildcars; see Note [Scoping of named wildcards] -- because they scope in the same way hsWcScopedTvs sig_ty | HsWC { hswc_ext = nwcs, hswc_body = sig_ty1 } <- sig_ty , HsIB { hsib_ext = vars , hsib_body = sig_ty2 } <- sig_ty1 = case sig_ty2 of L _ (HsForAllTy { hst_fvf = vis_flag , hst_bndrs = tvs }) -> ASSERT( vis_flag == ForallInvis ) -- See Note [hsScopedTvs vis_flag] vars ++ nwcs ++ hsLTyVarNames tvs _ -> nwcs hsWcScopedTvs (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec hsWcScopedTvs (XHsWildCardBndrs nec) = noExtCon nec hsScopedTvs :: LHsSigType GhcRn -> [Name] -- Same as hsWcScopedTvs, but for a LHsSigType hsScopedTvs sig_ty | HsIB { hsib_ext = vars , hsib_body = sig_ty2 } <- sig_ty , L _ (HsForAllTy { hst_fvf = vis_flag , hst_bndrs = tvs }) <- sig_ty2 = ASSERT( vis_flag == ForallInvis ) -- See Note [hsScopedTvs vis_flag] vars ++ hsLTyVarNames tvs | otherwise = [] {- Note [Scoping of named wildcards] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider f :: _a -> _a f x = let g :: _a -> _a g = ... in ... Currently, for better or worse, the "_a" variables are all the same. So although there is no explicit forall, the "_a" scopes over the definition. I don't know if this is a good idea, but there it is. -} {- Note [hsScopedTvs vis_flag] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -XScopedTypeVariables can be defined in terms of a desugaring to -XTypeAbstractions (GHC Proposal #50): fn :: forall a b c. tau(a,b,c) fn :: forall a b c. tau(a,b,c) fn = defn(a,b,c) ==> fn @x @y @z = defn(x,y,z) That is, for every type variable of the leading 'forall' in the type signature, we add an invisible binder at term level. This model does not extend to visible forall, as discussed here: * https://gitlab.haskell.org/ghc/ghc/issues/16734#note_203412 * https://github.com/ghc-proposals/ghc-proposals/pull/238 The conclusion of these discussions can be summarized as follows: > Assuming support for visible 'forall' in terms, consider this example: > > vfn :: forall x y -> tau(x,y) > vfn = \a b -> ... > > The user has written their own binders 'a' and 'b' to stand for 'x' and > 'y', and we definitely should not desugar this into: > > vfn :: forall x y -> tau(x,y) > vfn x y = \a b -> ... -- bad! At the moment, GHC does not support visible 'forall' in terms, so we simply cement our assumptions with an assert: hsScopedTvs (HsForAllTy { hst_fvf = vis_flag, ... }) = ASSERT( vis_flag == ForallInvis ) ... In the future, this assert can be safely turned into a pattern match to support visible forall in terms: hsScopedTvs (HsForAllTy { hst_fvf = ForallInvis, ... }) = ... -} --------------------- hsTyVarName :: HsTyVarBndr (GhcPass p) -> IdP (GhcPass p) hsTyVarName (UserTyVar _ (L _ n)) = n hsTyVarName (KindedTyVar _ (L _ n) _) = n hsTyVarName (XTyVarBndr nec) = noExtCon nec hsLTyVarName :: LHsTyVarBndr (GhcPass p) -> IdP (GhcPass p) hsLTyVarName = hsTyVarName . unLoc hsLTyVarNames :: [LHsTyVarBndr (GhcPass p)] -> [IdP (GhcPass p)] hsLTyVarNames = map hsLTyVarName hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)] -- Explicit variables only hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs) hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name] -- All variables hsAllLTyVarNames (HsQTvs { hsq_ext = kvs , hsq_explicit = tvs }) = kvs ++ hsLTyVarNames tvs hsAllLTyVarNames (XLHsQTyVars nec) = noExtCon nec hsLTyVarLocName :: LHsTyVarBndr (GhcPass p) -> Located (IdP (GhcPass p)) hsLTyVarLocName = onHasSrcSpan hsTyVarName hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))] hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) -- | Convert a LHsTyVarBndr to an equivalent LHsType. hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p) hsLTyVarBndrToType = onHasSrcSpan cvt where cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n cvt (KindedTyVar _ (L name_loc n) kind) = HsKindSig noExtField (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind cvt (XTyVarBndr nec) = noExtCon nec -- | Convert a LHsTyVarBndrs to a list of types. -- Works on *type* variable only, no kind vars. hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)] hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs hsLTyVarBndrsToTypes (XLHsQTyVars nec) = noExtCon nec -- | Get the kind signature of a type, ignoring parentheses: -- -- hsTyKindSig `Maybe ` = Nothing -- hsTyKindSig `Maybe :: Type -> Type ` = Just `Type -> Type` -- hsTyKindSig `Maybe :: ((Type -> Type))` = Just `Type -> Type` -- -- This is used to extract the result kind of type synonyms with a CUSK: -- -- type S = (F :: res_kind) -- ^^^^^^^^ -- hsTyKindSig :: LHsType pass -> Maybe (LHsKind pass) hsTyKindSig lty = case unLoc lty of HsParTy _ lty' -> hsTyKindSig lty' HsKindSig _ _ k -> Just k _ -> Nothing --------------------- ignoreParens :: LHsType pass -> LHsType pass ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty ignoreParens ty = ty isLHsForAllTy :: LHsType p -> Bool isLHsForAllTy (L _ (HsForAllTy {})) = True isLHsForAllTy _ = False {- ************************************************************************ * * Building types * * ************************************************************************ -} mkAnonWildCardTy :: HsType GhcPs mkAnonWildCardTy = HsWildCardTy noExtField mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p)) -> LHsType (GhcPass p) -> HsType (GhcPass p) mkHsOpTy ty1 op ty2 = HsOpTy noExtField ty1 op ty2 mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2)) mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) mkHsAppTys = foldl' mkHsAppTy mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) mkHsAppKindTy ext ty k = addCLoc ty k (HsAppKindTy ext ty k) {- ************************************************************************ * * Decomposing HsTypes * * ************************************************************************ -} --------------------------------- -- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) -- Breaks up any parens in the result type: -- splitHsFunType (a -> (b -> c)) = ([a,b], c) -- Also deals with (->) t1 t2; that is why it only works on LHsType Name -- (see #9096) splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn) splitHsFunType (L _ (HsParTy _ ty)) = splitHsFunType ty splitHsFunType (L _ (HsFunTy _ x y)) | (args, res) <- splitHsFunType y = (x:args, res) {- This is not so correct, because it won't work with visible kind app, in case someone wants to write '(->) @k1 @k2 t1 t2'. Fixing this would require changing ConDeclGADT abstract syntax -} splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2)) = go t1 [t2] where -- Look for (->) t1 t2, possibly with parenthesisation go (L _ (HsTyVar _ _ (L _ fn))) tys | fn == funTyConName , [t1,t2] <- tys , (args, res) <- splitHsFunType t2 = (t1:args, res) go (L _ (HsAppTy _ t1 t2)) tys = go t1 (t2:tys) go (L _ (HsParTy _ ty)) tys = go ty tys go _ _ = ([], orig_ty) -- Failure to match splitHsFunType other = ([], other) -- retrieve the name of the "head" of a nested type application -- somewhat like splitHsAppTys, but a little more thorough -- used to examine the result of a GADT-like datacon, so it doesn't handle -- *all* cases (like lists, tuples, (~), etc.) hsTyGetAppHead_maybe :: LHsType (GhcPass p) -> Maybe (Located (IdP (GhcPass p))) hsTyGetAppHead_maybe = go where go (L _ (HsTyVar _ _ ln)) = Just ln go (L _ (HsAppTy _ l _)) = go l go (L _ (HsAppKindTy _ t _)) = go t go (L _ (HsOpTy _ _ (L loc n) _)) = Just (L loc n) go (L _ (HsParTy _ t)) = go t go (L _ (HsKindSig _ t _)) = go t go _ = Nothing ------------------------------------------------------------ -- Arguments in an expression/type after splitting data HsArg tm ty = HsValArg tm -- Argument is an ordinary expression (f arg) | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty) -- SrcSpan is location of the `@` | HsArgPar SrcSpan -- See Note [HsArgPar] numVisibleArgs :: [HsArg tm ty] -> Arity numVisibleArgs = count is_vis where is_vis (HsValArg _) = True is_vis _ = False -- type level equivalent type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where ppr (HsValArg tm) = ppr tm ppr (HsTypeArg _ ty) = char '@' <> ppr ty ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp {- Note [HsArgPar] A HsArgPar indicates that everything to the left of this in the argument list is enclosed in parentheses together with the function itself. It is necessary so that we can recreate the parenthesis structure in the original source after typechecking the arguments. The SrcSpan is the span of the original HsPar ((f arg1) arg2 arg3) results in an input argument list of [HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2] -} -------------------------------- -- | Decompose a pattern synonym type signature into its constituent parts. -- -- Note that this function looks through parentheses, so it will work on types -- such as @(forall a. <...>)@. The downside to this is that it is not -- generally possible to take the returned types and reconstruct the original -- type (parentheses and all) from them. splitLHsPatSynTy :: LHsType pass -> ( [LHsTyVarBndr pass] -- universals , LHsContext pass -- required constraints , [LHsTyVarBndr pass] -- existentials , LHsContext pass -- provided constraints , LHsType pass) -- body type splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) where (univs, ty1) = splitLHsForAllTyInvis ty (reqs, ty2) = splitLHsQualTy ty1 (exis, ty3) = splitLHsForAllTyInvis ty2 (provs, ty4) = splitLHsQualTy ty3 -- | Decompose a sigma type (of the form @forall . context => body@) -- into its constituent parts. Note that only /invisible/ @forall@s -- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s -- (i.e., @forall a ->@, with an arrow) are left untouched. -- -- This function is used to split apart certain types, such as instance -- declaration types, which disallow visible @forall@s. For instance, if GHC -- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that -- declaration would mistakenly be accepted! -- -- Note that this function looks through parentheses, so it will work on types -- such as @(forall a. <...>)@. The downside to this is that it is not -- generally possible to take the returned types and reconstruct the original -- type (parentheses and all) from them. splitLHsSigmaTyInvis :: LHsType pass -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass) splitLHsSigmaTyInvis ty | (tvs, ty1) <- splitLHsForAllTyInvis ty , (ctxt, ty2) <- splitLHsQualTy ty1 = (tvs, ctxt, ty2) -- | Decompose a type of the form @forall . body@ into its constituent -- parts. Note that only /invisible/ @forall@s -- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s -- (i.e., @forall a ->@, with an arrow) are left untouched. -- -- This function is used to split apart certain types, such as instance -- declaration types, which disallow visible @forall@s. For instance, if GHC -- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that -- declaration would mistakenly be accepted! -- -- Note that this function looks through parentheses, so it will work on types -- such as @(forall a. <...>)@. The downside to this is that it is not -- generally possible to take the returned types and reconstruct the original -- type (parentheses and all) from them. splitLHsForAllTyInvis :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) splitLHsForAllTyInvis lty@(L _ ty) = case ty of HsParTy _ ty' -> splitLHsForAllTyInvis ty' HsForAllTy { hst_fvf = fvf', hst_bndrs = tvs', hst_body = body' } | fvf' == ForallInvis -> (tvs', body') _ -> ([], lty) -- | Decompose a type of the form @context => body@ into its constituent parts. -- -- Note that this function looks through parentheses, so it will work on types -- such as @(context => <...>)@. The downside to this is that it is not -- generally possible to take the returned types and reconstruct the original -- type (parentheses and all) from them. splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass) splitLHsQualTy (L _ (HsParTy _ ty)) = splitLHsQualTy ty splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body) splitLHsQualTy body = (noLHsContext, body) -- | Decompose a type class instance type (of the form -- @forall . context => instance_head@) into its constituent parts. -- -- Note that this function looks through parentheses, so it will work on types -- such as @(forall . <...>)@. The downside to this is that it is not -- generally possible to take the returned types and reconstruct the original -- type (parentheses and all) from them. splitLHsInstDeclTy :: LHsSigType GhcRn -> ([Name], LHsContext GhcRn, LHsType GhcRn) -- Split up an instance decl type, returning the pieces splitLHsInstDeclTy (HsIB { hsib_ext = itkvs , hsib_body = inst_ty }) | (tvs, cxt, body_ty) <- splitLHsSigmaTyInvis inst_ty = (itkvs ++ hsLTyVarNames tvs, cxt, body_ty) -- Return implicitly bound type and kind vars -- For an instance decl, all of them are in scope splitLHsInstDeclTy (XHsImplicitBndrs nec) = noExtCon nec getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p) getLHsInstDeclHead inst_ty | (_tvs, _cxt, body_ty) <- splitLHsSigmaTyInvis (hsSigType inst_ty) = body_ty getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p) -> Maybe (Located (IdP (GhcPass p))) -- Works on (HsSigType RdrName) getLHsInstDeclClass_maybe inst_ty = do { let head_ty = getLHsInstDeclHead inst_ty ; cls <- hsTyGetAppHead_maybe head_ty ; return cls } {- ************************************************************************ * * FieldOcc * * ************************************************************************ -} -- | Located Field Occurrence type LFieldOcc pass = Located (FieldOcc pass) -- | Field Occurrence -- -- Represents an *occurrence* of an unambiguous field. We store -- both the 'RdrName' the user originally wrote, and after the -- renamer, the selector function. data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass , rdrNameFieldOcc :: Located RdrName -- ^ See Note [Located RdrNames] in GHC.Hs.Expr } | XFieldOcc (XXFieldOcc pass) deriving instance Eq (XCFieldOcc (GhcPass p)) => Eq (FieldOcc (GhcPass p)) deriving instance Ord (XCFieldOcc (GhcPass p)) => Ord (FieldOcc (GhcPass p)) type instance XCFieldOcc GhcPs = NoExtField type instance XCFieldOcc GhcRn = Name type instance XCFieldOcc GhcTc = Id type instance XXFieldOcc (GhcPass _) = NoExtCon instance Outputable (FieldOcc pass) where ppr = ppr . rdrNameFieldOcc mkFieldOcc :: Located RdrName -> FieldOcc GhcPs mkFieldOcc rdr = FieldOcc noExtField rdr -- | Ambiguous Field Occurrence -- -- Represents an *occurrence* of a field that is potentially -- ambiguous after the renamer, with the ambiguity resolved by the -- typechecker. We always store the 'RdrName' that the user -- originally wrote, and store the selector function after the renamer -- (for unambiguous occurrences) or the typechecker (for ambiguous -- occurrences). -- -- See Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat and -- Note [Disambiguating record fields] in TcExpr. -- See Note [Located RdrNames] in GHC.Hs.Expr data AmbiguousFieldOcc pass = Unambiguous (XUnambiguous pass) (Located RdrName) | Ambiguous (XAmbiguous pass) (Located RdrName) | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass) type instance XUnambiguous GhcPs = NoExtField type instance XUnambiguous GhcRn = Name type instance XUnambiguous GhcTc = Id type instance XAmbiguous GhcPs = NoExtField type instance XAmbiguous GhcRn = NoExtField type instance XAmbiguous GhcTc = Id type instance XXAmbiguousFieldOcc (GhcPass _) = NoExtCon instance Outputable (AmbiguousFieldOcc (GhcPass p)) where ppr = ppr . rdrNameAmbiguousFieldOcc instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc nec) = noExtCon nec selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id selectorAmbiguousFieldOcc (Unambiguous sel _) = sel selectorAmbiguousFieldOcc (Ambiguous sel _) = sel selectorAmbiguousFieldOcc (XAmbiguousFieldOcc nec) = noExtCon nec unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel unambiguousFieldOcc (XAmbiguousFieldOcc nec) = noExtCon nec ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr ambiguousFieldOcc (XFieldOcc nec) = noExtCon nec {- ************************************************************************ * * \subsection{Pretty printing} * * ************************************************************************ -} instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where ppr ty = pprHsType ty instance Outputable HsTyLit where ppr = ppr_tylit instance OutputableBndrId p => Outputable (LHsQTyVars (GhcPass p)) where ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs ppr (XLHsQTyVars x) = ppr x instance OutputableBndrId p => Outputable (HsTyVarBndr (GhcPass p)) where ppr (UserTyVar _ n) = ppr n ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k] ppr (XTyVarBndr nec) = noExtCon nec instance Outputable thing => Outputable (HsImplicitBndrs (GhcPass p) thing) where ppr (HsIB { hsib_body = ty }) = ppr ty ppr (XHsImplicitBndrs x) = ppr x instance Outputable thing => Outputable (HsWildCardBndrs (GhcPass p) thing) where ppr (HsWC { hswc_body = ty }) = ppr ty ppr (XHsWildCardBndrs x) = ppr x pprAnonWildCard :: SDoc pprAnonWildCard = char '_' -- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@ -- only when @-dppr-debug@ is enabled. pprHsForAll :: (OutputableBndrId p) => ForallVisFlag -> [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc pprHsForAll = pprHsForAllExtra Nothing -- | Version of 'pprHsForAll' that can also print an extra-constraints -- wildcard, e.g. @_ => a -> Bool@ or @(Show a, _) => a -> String@. This -- underscore will be printed when the 'Maybe SrcSpan' argument is a 'Just' -- containing the location of the extra-constraints wildcard. A special -- function for this is needed, as the extra-constraints wildcard is removed -- from the actual context and type, and stored in a separate field, thus just -- printing the type will not print the extra-constraints wildcard. pprHsForAllExtra :: (OutputableBndrId p) => Maybe SrcSpan -> ForallVisFlag -> [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc pprHsForAllExtra extra fvf qtvs cxt = pp_forall <+> pprLHsContextExtra (isJust extra) cxt where pp_forall | null qtvs = whenPprDebug (forAllLit <> separator) | otherwise = forAllLit <+> interppSP qtvs <> separator separator = ppr_forall_separator fvf -- | Version of 'pprHsForAll' or 'pprHsForAllExtra' that will always print -- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing' pprHsExplicitForAll :: (OutputableBndrId p) => ForallVisFlag -> Maybe [LHsTyVarBndr (GhcPass p)] -> SDoc pprHsExplicitForAll fvf (Just qtvs) = forAllLit <+> interppSP qtvs <> ppr_forall_separator fvf pprHsExplicitForAll _ Nothing = empty -- | Prints an arrow for visible @forall@s (e.g., @forall a ->@) and a dot for -- invisible @forall@s (e.g., @forall a.@). ppr_forall_separator :: ForallVisFlag -> SDoc ppr_forall_separator ForallVis = space <> arrow ppr_forall_separator ForallInvis = dot pprLHsContext :: (OutputableBndrId p) => LHsContext (GhcPass p) -> SDoc pprLHsContext lctxt | null (unLoc lctxt) = empty | otherwise = pprLHsContextAlways lctxt -- For use in a HsQualTy, which always gets printed if it exists. pprLHsContextAlways :: (OutputableBndrId p) => LHsContext (GhcPass p) -> SDoc pprLHsContextAlways (L _ ctxt) = case ctxt of [] -> parens empty <+> darrow [L _ ty] -> ppr_mono_ty ty <+> darrow _ -> parens (interpp'SP ctxt) <+> darrow -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ pprLHsContextExtra :: (OutputableBndrId p) => Bool -> LHsContext (GhcPass p) -> SDoc pprLHsContextExtra show_extra lctxt@(L _ ctxt) | not show_extra = pprLHsContext lctxt | null ctxt = char '_' <+> darrow | otherwise = parens (sep (punctuate comma ctxt')) <+> darrow where ctxt' = map ppr ctxt ++ [char '_'] pprConDeclFields :: (OutputableBndrId p) => [LConDeclField (GhcPass p)] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, cd_fld_doc = doc })) = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc ppr_fld (L _ (XConDeclField x)) = ppr x ppr_names [n] = ppr n ppr_names ns = sep (punctuate comma (map ppr ns)) {- Note [Printing KindedTyVars] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #3830 reminded me that we should really only print the kind signature on a KindedTyVar if the kind signature was put there by the programmer. During kind inference GHC now adds a PostTcKind to UserTyVars, rather than converting to KindedTyVars as before. (As it happens, the message in #3830 comes out a different way now, and the problem doesn't show up; but having the flag on a KindedTyVar seems like the Right Thing anyway.) -} -- Printing works more-or-less as for Types pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc pprHsType ty = ppr_mono_ty ty ppr_mono_lty :: (OutputableBndrId p) => LHsType (GhcPass p) -> SDoc ppr_mono_lty ty = ppr_mono_ty (unLoc ty) ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc ppr_mono_ty (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty }) = sep [pprHsForAll fvf tvs noLHsContext, ppr_mono_lty ty] ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty] ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds ppr_mono_ty (HsTyVar _ prom (L _ name)) | isPromoted prom = quote (pprPrefixOcc name) | otherwise = pprPrefixOcc name ppr_mono_ty (HsFunTy _ ty1 ty2) = ppr_fun_ty ty1 ty2 ppr_mono_ty (HsTupleTy _ con tys) -- Special-case unary boxed tuples so that they are pretty-printed as -- `Unit x`, not `(x)` | [ty] <- tys , BoxedTuple <- std_con = sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty] | otherwise = tupleParens std_con (pprWithCommas ppr tys) where std_con = case con of HsUnboxedTuple -> UnboxedTuple _ -> BoxedTuple ppr_mono_ty (HsSumTy _ tys) = tupleParens UnboxedTuple (pprWithBars ppr tys) ppr_mono_ty (HsKindSig _ ty kind) = ppr_mono_lty ty <+> dcolon <+> ppr kind ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty) ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty) ppr_mono_ty (HsSpliceTy _ s) = pprSplice s ppr_mono_ty (HsExplicitListTy _ prom tys) | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys) | otherwise = brackets (interpp'SP tys) ppr_mono_ty (HsExplicitTupleTy _ tys) -- Special-case unary boxed tuples so that they are pretty-printed as -- `'Unit x`, not `'(x)` | [ty] <- tys = quote $ sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty] | otherwise = quote $ parens (maybeAddSpace tys $ interpp'SP tys) ppr_mono_ty (HsTyLit _ t) = ppr_tylit t ppr_mono_ty (HsWildCardTy {}) = char '_' ppr_mono_ty (HsStarTy _ isUni) = char (if isUni then '★' else '*') ppr_mono_ty (HsAppTy _ fun_ty arg_ty) = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] ppr_mono_ty (HsAppKindTy _ ty k) = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2) = sep [ ppr_mono_lty ty1 , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ] ppr_mono_ty (HsParTy _ ty) = parens (ppr_mono_lty ty) -- Put the parens in where the user did -- But we still use the precedence stuff to add parens because -- toHsType doesn't put in any HsParTys, so we may still need them ppr_mono_ty (HsDocTy _ ty doc) -- AZ: Should we add parens? Should we introduce "-- ^"? = ppr_mono_lty ty <+> ppr (unLoc doc) -- we pretty print Haddock comments on types as if they were -- postfix operators ppr_mono_ty (XHsType t) = ppr t -------------------------- ppr_fun_ty :: (OutputableBndrId p) => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc ppr_fun_ty ty1 ty2 = let p1 = ppr_mono_lty ty1 p2 = ppr_mono_lty ty2 in sep [p1, arrow <+> p2] -------------------------- ppr_tylit :: HsTyLit -> SDoc ppr_tylit (HsNumTy _ i) = integer i ppr_tylit (HsStrTy _ s) = text (show s) -- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses -- under precedence @p@. hsTypeNeedsParens :: PprPrec -> HsType pass -> Bool hsTypeNeedsParens p = go where go (HsForAllTy{}) = p >= funPrec go (HsQualTy{}) = p >= funPrec go (HsBangTy{}) = p > topPrec go (HsRecTy{}) = False go (HsTyVar{}) = False go (HsFunTy{}) = p >= funPrec go (HsTupleTy{}) = False go (HsSumTy{}) = False go (HsKindSig{}) = p >= sigPrec go (HsListTy{}) = False go (HsIParamTy{}) = p > topPrec go (HsSpliceTy{}) = False go (HsExplicitListTy{}) = False go (HsExplicitTupleTy{}) = False go (HsTyLit{}) = False go (HsWildCardTy{}) = False go (HsStarTy{}) = False go (HsAppTy{}) = p >= appPrec go (HsAppKindTy{}) = p >= appPrec go (HsOpTy{}) = p >= opPrec go (HsParTy{}) = False go (HsDocTy _ (L _ t) _) = go t go (XHsType{}) = False maybeAddSpace :: [LHsType pass] -> SDoc -> SDoc -- See Note [Printing promoted type constructors] -- in IfaceType. This code implements the same -- logic for printing HsType maybeAddSpace tys doc | (ty : _) <- tys , lhsTypeHasLeadingPromotionQuote ty = space <> doc | otherwise = doc lhsTypeHasLeadingPromotionQuote :: LHsType pass -> Bool lhsTypeHasLeadingPromotionQuote ty = goL ty where goL (L _ ty) = go ty go (HsForAllTy{}) = False go (HsQualTy{ hst_ctxt = ctxt, hst_body = body}) | L _ (c:_) <- ctxt = goL c | otherwise = goL body go (HsBangTy{}) = False go (HsRecTy{}) = False go (HsTyVar _ p _) = isPromoted p go (HsFunTy _ arg _) = goL arg go (HsListTy{}) = False go (HsTupleTy{}) = False go (HsSumTy{}) = False go (HsOpTy _ t1 _ _) = goL t1 go (HsKindSig _ t _) = goL t go (HsIParamTy{}) = False go (HsSpliceTy{}) = False go (HsExplicitListTy _ p _) = isPromoted p go (HsExplicitTupleTy{}) = True go (HsTyLit{}) = False go (HsWildCardTy{}) = False go (HsStarTy{}) = False go (HsAppTy _ t _) = goL t go (HsAppKindTy _ t _) = goL t go (HsParTy{}) = False go (HsDocTy _ t _) = goL t go (XHsType{}) = False -- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is -- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply -- returns @ty@. parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p) parenthesizeHsType p lty@(L loc ty) | hsTypeNeedsParens p ty = L loc (HsParTy noExtField lty) | otherwise = lty -- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint -- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@ -- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply -- returns @ctxt@ unchanged. parenthesizeHsContext :: PprPrec -> LHsContext (GhcPass p) -> LHsContext (GhcPass p) parenthesizeHsContext p lctxt@(L loc ctxt) = case ctxt of [c] -> L loc [parenthesizeHsType p c] _ -> lctxt -- Other contexts are already "parenthesized" by virtue of -- being tuples. ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/Utils.hs0000644000000000000000000016342113713635744017736 0ustar0000000000000000{-| Module : GHC.Hs.Utils Description : Generic helpers for the HsSyn type. Copyright : (c) The University of Glasgow, 1992-2006 Here we collect a variety of helper functions that construct or analyse HsSyn. All these functions deal with generic HsSyn; functions which deal with the instantiated versions are located elsewhere: Parameterised by Module ---------------- ------------- GhcPs/RdrName parser/RdrHsSyn GhcRn/Name rename/RnHsSyn GhcTc/Id typecheck/TcHsSyn The @mk*@ functions attempt to construct a not-completely-useless SrcSpan from their components, compared with the @nl*@ functions which just attach noSrcSpan to everything. -} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module GHC.Hs.Utils( -- * Terms mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypes, mkHsCaseAlt, mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf, mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, mkHsDictLet, mkHsLams, mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, mkHsCmdIf, nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon, nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, typeToLHsType, -- * Constructing general big tuples -- $big_tuples mkChunkified, chunkify, -- * Bindings mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind, mkPatSynBind, isInfixFunBind, -- * Literals mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit, -- * Patterns mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat, nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat, nlWildPatName, nlTuplePat, mkParPat, nlParPat, mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, -- * Types mkHsAppTy, mkHsAppKindTy, mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv, nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp, -- * Stmts mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt, mkLastStmt, emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt, unitRecStmtTc, -- * Template Haskell mkUntypedSplice, mkTypedSplice, mkHsQuasiQuote, unqualQuasiQuote, -- * Collecting binders isUnliftedHsBind, isBangedHsBind, collectLocalBinders, collectHsValBinders, collectHsBindListBinders, collectHsIdBinders, collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectStmtsBinders, collectLStmtBinders, collectStmtBinders, hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynSelectors, getPatSynBinds, hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders, -- * Collecting implicit binders lStmtsImplicits, hsValBindsImplicits, lPatImplicits ) where #include "GhclibHsVersions.h" import GhcPrelude import GHC.Hs.Decls import GHC.Hs.Binds import GHC.Hs.Expr import GHC.Hs.Pat import GHC.Hs.Types import GHC.Hs.Lit import GHC.Hs.PlaceHolder import GHC.Hs.Extension import TcEvidence import RdrName import Var import TyCoRep import Type ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig ) import TysWiredIn ( unitTy ) import TcType import DataCon import ConLike import Id import Name import NameSet hiding ( unitFV ) import NameEnv import BasicTypes import SrcLoc import FastString import Util import Bag import Outputable import Constants import Data.Either import Data.Function import Data.List {- ************************************************************************ * * Some useful helpers for constructing syntax * * ************************************************************************ These functions attempt to construct a not-completely-useless 'SrcSpan' from their components, compared with the @nl*@ functions below which just attach 'noSrcSpan' to everything. -} -- | e => (e) mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkHsPar e = cL (getLoc e) (HsPar noExtField e) mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) -> [LPat (GhcPass p)] -> Located (body (GhcPass p)) -> LMatch (GhcPass p) (Located (body (GhcPass p))) mkSimpleMatch ctxt pats rhs = cL loc $ Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = pats , m_grhss = unguardedGRHSs rhs } where loc = case pats of [] -> getLoc rhs (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) unguardedGRHSs :: Located (body (GhcPass p)) -> GRHSs (GhcPass p) (Located (body (GhcPass p))) unguardedGRHSs rhs@(dL->L loc _) = GRHSs noExtField (unguardedRHS loc rhs) (noLoc emptyLocalBinds) unguardedRHS :: SrcSpan -> Located (body (GhcPass p)) -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))] unguardedRHS loc rhs = [cL loc (GRHS noExtField [] rhs)] mkMatchGroup :: (XMG name (Located (body name)) ~ NoExtField) => Origin -> [LMatch name (Located (body name))] -> MatchGroup name (Located (body name)) mkMatchGroup origin matches = MG { mg_ext = noExtField , mg_alts = mkLocatedList matches , mg_origin = origin } mkLocatedList :: [Located a] -> Located [Located a] mkLocatedList [] = noLoc [] mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExtField e1 e2) mkHsAppType :: (NoGhcTc (GhcPass id) ~ GhcRn) => LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id) mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct) where t_body = hswc_body t paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body } mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl' mkHsAppType mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) => [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExtField matches)) where matches = mkMatchGroup Generated [mkSimpleMatch LambdaExpr pats' body] pats' = map (parenthesizePat appPrec) pats mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr -- |A simple case alternative with a single pattern, no binds, no guards; -- pre-typechecking mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p))) -> LMatch (GhcPass p) (Located (body (GhcPass p))) mkHsCaseAlt pat expr = mkSimpleMatch CaseAlt [pat] expr nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id) nlHsTyApp fun_id tys = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLoc fun_id))) nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs --------- Adding parens --------- -- | Wrap in parens if (hsExprNeedsParens appPrec) says it needs them -- So 'f x' becomes '(f x)', but '3' stays as '3' mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkLHsPar le@(dL->L loc e) | hsExprNeedsParens appPrec e = cL loc (HsPar noExtField le) | otherwise = le mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) mkParPat lp@(dL->L loc p) | patNeedsParens appPrec p = cL loc (ParPat noExtField lp) | otherwise = lp nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) nlParPat p = noLoc (ParPat noExtField p) ------------------------------- -- These are the bits of syntax that contain rebindable names -- See RnEnv.lookupSyntaxName mkHsIntegral :: IntegralLit -> HsOverLit GhcPs mkHsFractional :: FractionalLit -> HsOverLit GhcPs mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs mkHsDo :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs mkHsComp :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> Pat GhcPs mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs mkLastStmt :: Located (bodyR (GhcPass idR)) -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) mkBodyStmt :: Located (bodyR GhcPs) -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs)) mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) ~ NoExtField) => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR)) -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc) -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc)) emptyRecStmt :: StmtLR (GhcPass idL) GhcPs bodyR emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR mkRecStmt :: [LStmtLR (GhcPass idL) GhcPs bodyR] -> StmtLR (GhcPass idL) GhcPs bodyR mkHsIntegral i = OverLit noExtField (HsIntegral i) noExpr mkHsFractional f = OverLit noExtField (HsFractional f) noExpr mkHsIsString src s = OverLit noExtField (HsIsString src s) noExpr mkHsDo ctxt stmts = HsDo noExtField ctxt (mkLocatedList stmts) mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) where last_stmt = cL (getLoc expr) $ mkLastStmt expr mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p) mkHsIf c a b = HsIf noExtField (Just noSyntaxExpr) c a b mkHsCmdIf :: LHsExpr (GhcPass p) -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) -> HsCmd (GhcPass p) mkHsCmdIf c a b = HsCmdIf noExtField (Just noSyntaxExpr) c a b mkNPat lit neg = NPat noExtField lit neg noSyntaxExpr mkNPlusKPat id lit = NPlusKPat noExtField id lit (unLoc lit) noSyntaxExpr noSyntaxExpr mkTransformStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) mkTransformByStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) mkGroupUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) mkGroupByUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) emptyTransStmt = TransStmt { trS_ext = noExtField , trS_form = panic "emptyTransStmt: form" , trS_stmts = [], trS_bndrs = [] , trS_by = Nothing, trS_using = noLoc noExpr , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr , trS_fmap = noExpr } mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u } mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u } mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } mkLastStmt body = LastStmt noExtField body False noSyntaxExpr mkBodyStmt body = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr mkBindStmt pat body = BindStmt noExtField pat body noSyntaxExpr noSyntaxExpr mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr -- don't use placeHolderTypeTc above, because that panics during zonking emptyRecStmt' :: forall idL idR body. XRecStmt (GhcPass idL) (GhcPass idR) body -> StmtLR (GhcPass idL) (GhcPass idR) body emptyRecStmt' tyVal = RecStmt { recS_stmts = [], recS_later_ids = [] , recS_rec_ids = [] , recS_ret_fn = noSyntaxExpr , recS_mfix_fn = noSyntaxExpr , recS_bind_fn = noSyntaxExpr , recS_ext = tyVal } unitRecStmtTc :: RecStmtTc unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy , recS_later_rets = [] , recS_rec_rets = [] , recS_ret_ty = unitTy } emptyRecStmt = emptyRecStmt' noExtField emptyRecStmtName = emptyRecStmt' noExtField emptyRecStmtId = emptyRecStmt' unitRecStmtTc -- a panic might trigger during zonking mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } ------------------------------- -- | A useful function for building @OpApps@. The operator is always a -- variable, and we don't know the fixity yet. mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs mkHsOpApp e1 op e2 = OpApp noExtField e1 (noLoc (HsVar noExtField (noLoc op))) e2 unqualSplice :: RdrName unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs mkUntypedSplice hasParen e = HsUntypedSplice noExtField hasParen unqualSplice e mkTypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs mkTypedSplice hasParen e = HsTypedSplice noExtField hasParen unqualSplice e mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs mkHsQuasiQuote quoter span quote = HsQuasiQuote noExtField unqualSplice quoter span quote unqualQuasiQuote :: RdrName unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) -- A name (uniquified later) to -- identify the quasi-quote mkHsString :: String -> HsLit (GhcPass p) mkHsString s = HsString NoSourceText (mkFastString s) mkHsStringPrimLit :: FastString -> HsLit (GhcPass p) mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs) {- ************************************************************************ * * Constructing syntax with no location info * * ************************************************************************ -} nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id) nlHsVar n = noLoc (HsVar noExtField (noLoc n)) -- | NB: Only for LHsExpr **Id** nlHsDataCon :: DataCon -> LHsExpr GhcTc nlHsDataCon con = noLoc (HsConLikeOut noExtField (RealDataCon con)) nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p) nlHsLit n = noLoc (HsLit noExtField n) nlHsIntLit :: Integer -> LHsExpr (GhcPass p) nlHsIntLit n = noLoc (HsLit noExtField (HsInt noExtField (mkIntegralLit n))) nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id) nlVarPat n = noLoc (VarPat noExtField (noLoc n)) nlLitPat :: HsLit GhcPs -> LPat GhcPs nlLitPat l = noLoc (LitPat noExtField l) nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) nlHsApp f x = noLoc (HsApp noExtField f (mkLHsPar x)) nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) nlHsSyntaxApps (SyntaxExpr { syn_expr = fun , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) args | [] <- arg_wraps -- in the noSyntaxExpr case = ASSERT( isIdHsWrapper res_wrap ) foldl' nlHsApp (noLoc fun) args | otherwise = mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps" mkLHsWrap arg_wraps args)) nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id) nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExtField (noLoc f)) (map ((HsVar noExtField) . noLoc) xs)) where mk f a = HsApp noExtField (noLoc f) (noLoc a) nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs nlConVarPat con vars = nlConPat con (map nlVarPat vars) nlConVarPatName :: Name -> [Name] -> LPat GhcRn nlConVarPatName con vars = nlConPatName con (map nlVarPat vars) nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon (parenthesizePat opPrec l) (parenthesizePat opPrec r))) nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats))) nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats))) nlNullaryConPat :: IdP (GhcPass p) -> LPat (GhcPass p) nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon [])) nlWildConPat :: DataCon -> LPat GhcPs nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) (PrefixCon (replicate (dataConSourceArity con) nlWildPat))) -- | Wildcard pattern - after parsing nlWildPat :: LPat GhcPs nlWildPat = noLoc (WildPat noExtField ) -- | Wildcard pattern - after renaming nlWildPatName :: LPat GhcRn nlWildPatName = noLoc (WildPat noExtField ) nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) nlHsIf :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs nlHsLam match = noLoc (HsLam noExtField (mkMatchGroup Generated [match])) nlHsPar e = noLoc (HsPar noExtField e) -- | Note [Rebindable nlHsIf] -- nlHsIf should generate if-expressions which are NOT subject to -- RebindableSyntax, so the first field of HsIf is Nothing. (#12080) nlHsIf cond true false = noLoc (HsIf noExtField Nothing cond true false) nlHsCase expr matches = noLoc (HsCase noExtField expr (mkMatchGroup Generated matches)) nlList exprs = noLoc (ExplicitList noExtField Nothing exprs) nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p) nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsAppTy f t = noLoc (HsAppTy noExtField f (parenthesizeHsType appPrec t)) nlHsTyVar x = noLoc (HsTyVar noExtField NotPromoted (noLoc x)) nlHsFunTy a b = noLoc (HsFunTy noExtField (parenthesizeHsType funPrec a) b) nlHsParTy t = noLoc (HsParTy noExtField t) nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) nlHsTyConApp tycon tys = foldl' nlHsAppTy (nlHsTyVar tycon) tys nlHsAppKindTy :: LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p) nlHsAppKindTy f k = noLoc (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k)) {- Tuples. All these functions are *pre-typechecker* because they lack types on the tuple. -} mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a) -- Makes a pre-typechecker boxed tuple, deals with 1 case mkLHsTupleExpr [e] = e mkLHsTupleExpr es = noLoc $ ExplicitTuple noExtField (map (noLoc . (Present noExtField)) es) Boxed mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a) mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs nlTuplePat pats box = noLoc (TuplePat noExtField pats box) missingTupArg :: HsTupArg GhcPs missingTupArg = Missing noExtField mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn mkLHsPatTup [] = noLoc $ TuplePat noExtField [] Boxed mkLHsPatTup [lpat] = lpat mkLHsPatTup lpats = cL (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed -- | The Big equivalents for the source tuple expressions mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id) mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids) mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) mkBigLHsTup = mkChunkified mkLHsTupleExpr -- | The Big equivalents for the source tuple patterns mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs) mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn mkBigLHsPatTup = mkChunkified mkLHsPatTup -- $big_tuples -- #big_tuples# -- -- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but -- we might concievably want to build such a massive tuple as part of the -- output of a desugaring stage (notably that for list comprehensions). -- -- We call tuples above this size \"big tuples\", and emulate them by -- creating and pattern matching on >nested< tuples that are expressible -- by GHC. -- -- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects) -- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any -- construction to be big. -- -- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector' -- and 'mkTupleCase' functions to do all your work with tuples you should be -- fine, and not have to worry about the arity limitation at all. -- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE' -> [a] -- ^ Possible \"big\" list of things to construct from -> a -- ^ Constructed thing made possible by recursive decomposition mkChunkified small_tuple as = mk_big_tuple (chunkify as) where -- Each sub-list is short enough to fit in a tuple mk_big_tuple [as] = small_tuple as mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s)) chunkify :: [a] -> [[a]] -- ^ Split a list into lists that are small enough to have a corresponding -- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE' -- But there may be more than 'mAX_TUPLE_SIZE' sub-lists chunkify xs | n_xs <= mAX_TUPLE_SIZE = [xs] | otherwise = split xs where n_xs = length xs split [] = [] split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs) {- ************************************************************************ * * LHsSigType and LHsSigWcType * * ********************************************************************* -} mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs mkLHsSigType ty = mkHsImplicitBndrs ty mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty) mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a)) -> [LSig GhcRn] -> NameEnv a mkHsSigEnv get_info sigs = mkNameEnv (mk_pairs ordinary_sigs) `extendNameEnvList` (mk_pairs gen_dm_sigs) -- The subtlety is this: in a class decl with a -- default-method signature as well as a method signature -- we want the latter to win (#12533) -- class C x where -- op :: forall a . x a -> x a -- default op :: forall b . x b -> x b -- op x = ...(e :: b -> b)... -- The scoped type variables of the 'default op', namely 'b', -- scope over the code for op. The 'forall a' does not! -- This applies both in the renamer and typechecker, both -- of which use this function where (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs is_gen_dm_sig (dL->L _ (ClassOpSig _ True _ _)) = True is_gen_dm_sig _ = False mk_pairs :: [LSig GhcRn] -> [(Name, a)] mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs , (dL->L _ n) <- ns ] mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs] -- ^ Convert TypeSig to ClassOpSig -- The former is what is parsed, but the latter is -- what we need in class/instance declarations mkClassOpSigs sigs = map fiddle sigs where fiddle (dL->L loc (TypeSig _ nms ty)) = cL loc (ClassOpSig noExtField False nms (dropWildCards ty)) fiddle sig = sig typeToLHsType :: Type -> LHsType GhcPs -- ^ Converting a Type to an HsType RdrName -- This is needed to implement GeneralizedNewtypeDeriving. -- -- Note that we use 'getRdrName' extensively, which -- generates Exact RdrNames rather than strings. typeToLHsType ty = go ty where go :: Type -> LHsType GhcPs go ty@(FunTy { ft_af = af, ft_arg = arg, ft_res = res }) = case af of VisArg -> nlHsFunTy (go arg) (go res) InvisArg | (theta, tau) <- tcSplitPhiTy ty -> noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) , hst_xqual = noExtField , hst_body = go tau }) go ty@(ForAllTy (Bndr _ argf) _) | (tvs, tau) <- tcSplitForAllTysSameVis argf ty = noLoc (HsForAllTy { hst_fvf = argToForallVisFlag argf , hst_bndrs = map go_tv tvs , hst_xforall = noExtField , hst_body = go tau }) go (TyVarTy tv) = nlHsTyVar (getRdrName tv) go (LitTy (NumTyLit n)) = noLoc $ HsTyLit noExtField (HsNumTy NoSourceText n) go (LitTy (StrTyLit s)) = noLoc $ HsTyLit noExtField (HsStrTy NoSourceText s) go ty@(TyConApp tc args) | tyConAppNeedsKindSig True tc (length args) -- We must produce an explicit kind signature here to make certain -- programs kind-check. See Note [Kind signatures in typeToLHsType]. = nlHsParTy $ noLoc $ HsKindSig noExtField ty' (go (tcTypeKind ty)) | otherwise = ty' where ty' :: LHsType GhcPs ty' = go_app (nlHsTyVar (getRdrName tc)) args (tyConArgFlags tc args) go ty@(AppTy {}) = go_app (go head) args (appTyArgFlags head args) where head :: Type args :: [Type] (head, args) = splitAppTys ty go (CastTy ty _) = go ty go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co) -- Source-language types have _invisible_ kind arguments, -- so we must remove them here (#8563) go_app :: LHsType GhcPs -- The type being applied -> [Type] -- The argument types -> [ArgFlag] -- The argument types' visibilities -> LHsType GhcPs go_app head args arg_flags = foldl' (\f (arg, flag) -> let arg' = go arg in case flag of Inferred -> f Specified -> f `nlHsAppKindTy` arg' Required -> f `nlHsAppTy` arg') head (zip args arg_flags) go_tv :: TyVar -> LHsTyVarBndr GhcPs go_tv tv = noLoc $ KindedTyVar noExtField (noLoc (getRdrName tv)) (go (tyVarKind tv)) {- Note [Kind signatures in typeToLHsType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are types that typeToLHsType can produce which require explicit kind signatures in order to kind-check. Here is an example from #14579: -- type P :: forall {k} {t :: k}. Proxy t type P = 'Proxy -- type Wat :: forall a. Proxy a -> * newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a) deriving Eq -- type Wat2 :: forall {a}. Proxy a -> * type Wat2 = Wat -- type Glurp :: * -> * newtype Glurp a = MkGlurp (Wat2 (P :: Proxy a)) deriving Eq The derived Eq instance for Glurp (without any kind signatures) would be: instance Eq a => Eq (Glurp a) where (==) = coerce @(Wat2 P -> Wat2 P -> Bool) @(Glurp a -> Glurp a -> Bool) (==) :: Glurp a -> Glurp a -> Bool (Where the visible type applications use types produced by typeToLHsType.) The type P (in Wat2 P) has an underspecified kind, so we must ensure that typeToLHsType ascribes it with its kind: Wat2 (P :: Proxy a). To accomplish this, whenever we see an application of a tycon to some arguments, we use the tyConAppNeedsKindSig function to determine if it requires an explicit kind signature to resolve some ambiguity. (See Note Note [When does a tycon application need an explicit kind signature?] for a more detailed explanation of how this works.) Note that we pass True to tyConAppNeedsKindSig since we are generated code with visible kind applications, so even specified arguments count towards injective positions in the kind of the tycon. -} {- ********************************************************************* * * --------- HsWrappers: type args, dict args, casts --------- * * ********************************************************************* -} mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e) -- | Avoid (HsWrap co (HsWrap co' _)). -- See Note [Detecting forced eta expansion] in DsExpr mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) mkHsWrap co_fn e | isIdHsWrapper co_fn = e mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e mkHsWrap co_fn e = HsWrap noExtField co_fn e mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e) mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p) mkHsCmdWrap w cmd | isIdHsWrapper w = cmd | otherwise = HsCmdWrap noExtField w cmd mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c) mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p | otherwise = CoPat noExtField co_fn p ty mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) mkHsWrapPatCo co pat ty | isTcReflCo co = pat | otherwise = CoPat noExtField (mkWpCastN co) pat ty mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr {- l ************************************************************************ * * Bindings; with a location at the top * * ************************************************************************ -} mkFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs -- ^ Not infix, with place holders for coercion and free vars mkFunBind origin fn ms = FunBind { fun_id = fn , fun_matches = mkMatchGroup origin ms , fun_co_fn = idHsWrapper , fun_ext = noExtField , fun_tick = [] } mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBind GhcRn -- ^ In Name-land, with empty bind_fvs mkTopFunBind origin fn ms = FunBind { fun_id = fn , fun_matches = mkMatchGroup origin ms , fun_co_fn = idHsWrapper , fun_ext = emptyNameSet -- NB: closed -- binding , fun_tick = [] } mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p) mkVarBind var rhs = cL (getLoc rhs) $ VarBind { var_ext = noExtField, var_id = var, var_rhs = rhs, var_inline = False } mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs mkPatSynBind name details lpat dir = PatSynBind noExtField psb where psb = PSB{ psb_ext = noExtField , psb_id = name , psb_args = details , psb_def = lpat , psb_dir = dir } -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is -- considered infix. isInfixFunBind :: HsBindLR id1 id2 -> Bool isInfixFunBind (FunBind _ _ (MG _ matches _) _ _) = any (isInfixMatch . unLoc) (unLoc matches) isInfixFunBind _ = False ------------ -- | Convenience function using 'mkFunBind'. -- This is for generated bindings only, do not use for user-written code. mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs mkSimpleGeneratedFunBind loc fun pats expr = cL loc $ mkFunBind Generated (cL loc fun) [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr (noLoc emptyLocalBinds)] -- | Make a prefix, non-strict function 'HsMatchContext' mkPrefixFunRhs :: Located id -> HsMatchContext id mkPrefixFunRhs n = FunRhs { mc_fun = n , mc_fixity = Prefix , mc_strictness = NoSrcStrict } ------------ mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> Located (HsLocalBinds (GhcPass p)) -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) mkMatch ctxt pats expr lbinds = noLoc (Match { m_ext = noExtField , m_ctxt = ctxt , m_pats = map paren pats , m_grhss = GRHSs noExtField (unguardedRHS noSrcSpan expr) lbinds }) where paren lp@(dL->L l p) | patNeedsParens appPrec p = cL l (ParPat noExtField lp) | otherwise = lp {- ************************************************************************ * * Collecting binders * * ************************************************************************ Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg. ... where (x, y) = ... f i j = ... [a, b] = ... it should return [x, y, f, a, b] (remember, order important). Note [Collect binders only after renaming] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ These functions should only be used on HsSyn *after* the renamer, to return a [Name] or [Id]. Before renaming the record punning and wild-card mechanism makes it hard to know what is bound. So these functions should not be applied to (HsSyn RdrName) Note [Unlifted id check in isUnliftedHsBind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The function isUnliftedHsBind is used to complain if we make a top-level binding for a variable of unlifted type. Such a binding is illegal if the top-level binding would be unlifted; but also if the local letrec generated by desugaring AbsBinds would be. E.g. f :: Num a => (# a, a #) g :: Num a => a -> a f = ...g... g = ...g... The top-level bindings for f,g are not unlifted (because of the Num a =>), but the local, recursive, monomorphic bindings are: t = /\a \(d:Num a). letrec fm :: (# a, a #) = ...g... gm :: a -> a = ...f... in (fm, gm) Here the binding for 'fm' is illegal. So generally we check the abe_mono types. BUT we have a special case when abs_sig is true; see Note [The abs_sig field of AbsBinds] in GHC.Hs.Binds -} ----------------- Bindings -------------------------- -- | Should we treat this as an unlifted bind? This will be true for any -- bind that binds an unlifted variable, but we must be careful around -- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage -- information, see Note [Strict binds check] is DsBinds. isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds isUnliftedHsBind bind | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind = if has_sig then any (is_unlifted_id . abe_poly) exports else any (is_unlifted_id . abe_mono) exports -- If has_sig is True we wil never generate a binding for abe_mono, -- so we don't need to worry about it being unlifted. The abe_poly -- binding might not be: e.g. forall a. Num a => (# a, a #) | otherwise = any is_unlifted_id (collectHsBindBinders bind) where is_unlifted_id id = isUnliftedType (idType id) -- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)? isBangedHsBind :: HsBind GhcTc -> Bool isBangedHsBind (AbsBinds { abs_binds = binds }) = anyBag (isBangedHsBind . unLoc) binds isBangedHsBind (FunBind {fun_matches = matches}) | [dL->L _ match] <- unLoc $ mg_alts matches , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match = True isBangedHsBind (PatBind {pat_lhs = pat}) = isBangedLPat pat isBangedHsBind _ = False collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds -- No pattern synonyms here collectLocalBinders (HsIPBinds {}) = [] collectLocalBinders (EmptyLocalBinds _) = [] collectLocalBinders (XHsLocalBindsLR _) = [] collectHsIdBinders, collectHsValBinders :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] -- ^ Collect Id binders only, or Ids + pattern synonyms, respectively collectHsIdBinders = collect_hs_val_binders True collectHsValBinders = collect_hs_val_binders False collectHsBindBinders :: (SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p))=> HsBindLR p idR -> [IdP p] -- ^ Collect both Ids and pattern-synonym binders collectHsBindBinders b = collect_bind False b [] collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)] collectHsBindsBinders binds = collect_binds False binds [] collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)] -- ^ Same as collectHsBindsBinders, but works over a list of bindings collectHsBindListBinders = foldr (collect_bind False . unLoc) [] collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds [] collect_hs_val_binders ps (XValBindsLR (NValBinds binds _)) = collect_out_binds ps binds collect_out_binds :: Bool -> [(RecFlag, LHsBinds (GhcPass p))] -> [IdP (GhcPass p)] collect_out_binds ps = foldr (collect_binds ps . snd) [] collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)] -> [IdP (GhcPass p)] -- ^ Collect Ids, or Ids + pattern synonyms, depending on boolean flag collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => Bool -> HsBindLR p idR -> [IdP p] -> [IdP p] collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc collect_bind _ (FunBind { fun_id = (dL->L _ f) }) acc = f : acc collect_bind _ (VarBind { var_id = f }) acc = f : acc collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc -- I don't think we want the binders from the abe_binds -- binding (hence see AbsBinds) is in zonking in TcHsSyn collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = (dL->L _ ps) })) acc | omitPatSyn = acc | otherwise = ps : acc collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc collect_bind _ (XHsBindsLR _) acc = acc collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)] -- ^ Used exclusively for the bindings of an instance decl which are all FunBinds collectMethodBinders binds = foldr (get . unLoc) [] binds where get (FunBind { fun_id = f }) fs = f : fs get _ fs = fs -- Someone else complains about non-FunBinds ----------------- Statements -------------------------- collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)] collectLStmtsBinders = concatMap collectLStmtBinders collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)] collectStmtsBinders = concatMap collectStmtBinders collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)] collectLStmtBinders = collectStmtBinders . unLoc collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? collectStmtBinders (BindStmt _ pat _ _ _) = collectPatBinders pat collectStmtBinders (LetStmt _ binds) = collectLocalBinders (unLoc binds) collectStmtBinders (BodyStmt {}) = [] collectStmtBinders (LastStmt {}) = [] collectStmtBinders (ParStmt _ xs _ _) = collectLStmtsBinders $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss] collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args where collectArgBinders (_, ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat collectArgBinders (_, ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat collectArgBinders _ = [] collectStmtBinders (XStmtLR nec) = noExtCon nec ----------------- Patterns -------------------------- collectPatBinders :: LPat (GhcPass p) -> [IdP (GhcPass p)] collectPatBinders pat = collect_lpat pat [] collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)] collectPatsBinders pats = foldr collect_lpat [] pats ------------- collect_lpat :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => LPat p -> [IdP p] -> [IdP p] collect_lpat p bndrs = go (unLoc p) where go (VarPat _ var) = unLoc var : bndrs go (WildPat _) = bndrs go (LazyPat _ pat) = collect_lpat pat bndrs go (BangPat _ pat) = collect_lpat pat bndrs go (AsPat _ a pat) = unLoc a : collect_lpat pat bndrs go (ViewPat _ _ pat) = collect_lpat pat bndrs go (ParPat _ pat) = collect_lpat pat bndrs go (ListPat _ pats) = foldr collect_lpat bndrs pats go (TuplePat _ pats _) = foldr collect_lpat bndrs pats go (SumPat _ pat _ _) = collect_lpat pat bndrs go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps) go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps) -- See Note [Dictionary binders in ConPatOut] go (LitPat _ _) = bndrs go (NPat {}) = bndrs go (NPlusKPat _ n _ _ _ _) = unLoc n : bndrs go (SigPat _ pat _) = collect_lpat pat bndrs go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) = go pat go (SplicePat _ _) = bndrs go (CoPat _ _ pat _) = go pat go (XPat {}) = bndrs {- Note [Dictionary binders in ConPatOut] See also same Note in DsArrows ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Do *not* gather (a) dictionary and (b) dictionary bindings as binders of a ConPatOut pattern. For most calls it doesn't matter, because it's pre-typechecker and there are no ConPatOuts. But it does matter more in the desugarer; for example, DsUtils.mkSelectorBinds uses collectPatBinders. In a lazy pattern, for example f ~(C x y) = ..., we want to generate bindings for x,y but not for dictionaries bound by C. (The type checker ensures they would not be used.) Desugaring of arrow case expressions needs these bindings (see DsArrows and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its own pat-binder-collector: Here's the problem. Consider data T a where C :: Num a => a -> Int -> T a f ~(C (n+1) m) = (n,m) Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a), and *also* uses that dictionary to match the (n+1) pattern. Yet, the variables bound by the lazy pattern are n,m, *not* the dictionary d. So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound. -} hsGroupBinders :: HsGroup GhcRn -> [Name] hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_fords = foreign_decls }) = collectHsValBinders val_decls ++ hsTyClForeignBinders tycl_decls foreign_decls hsGroupBinders (XHsGroup nec) = noExtCon nec hsTyClForeignBinders :: [TyClGroup GhcRn] -> [LForeignDecl GhcRn] -> [Name] -- We need to look at instance declarations too, -- because their associated types may bind data constructors hsTyClForeignBinders tycl_decls foreign_decls = map unLoc (hsForeignDeclsBinders foreign_decls) ++ getSelectorNames (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls `mappend` foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls) where getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name] getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs ------------------- hsLTyClDeclBinders :: Located (TyClDecl (GhcPass p)) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -- ^ Returns all the /binding/ names of the decl. The first one is -- guaranteed to be the name of the decl. The first component -- represents all binding names except record fields; the second -- represents field occurrences. For record fields mentioned in -- multiple constructors, the SrcLoc will be from the first occurrence. -- -- Each returned (Located name) has a SrcSpan for the /whole/ declaration. -- See Note [SrcSpan for binders] hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl { fdLName = (dL->L _ name) } })) = ([cL loc name], []) hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl nec })) = noExtCon nec hsLTyClDeclBinders (dL->L loc (SynDecl { tcdLName = (dL->L _ name) })) = ([cL loc name], []) hsLTyClDeclBinders (dL->L loc (ClassDecl { tcdLName = (dL->L _ cls_name) , tcdSigs = sigs , tcdATs = ats })) = (cL loc cls_name : [ cL fam_loc fam_name | (dL->L fam_loc (FamilyDecl { fdLName = L _ fam_name })) <- ats ] ++ [ cL mem_loc mem_name | (dL->L mem_loc (ClassOpSig _ False ns _)) <- sigs , (dL->L _ mem_name) <- ns ] , []) hsLTyClDeclBinders (dL->L loc (DataDecl { tcdLName = (dL->L _ name) , tcdDataDefn = defn })) = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn hsLTyClDeclBinders (dL->L _ (XTyClDecl nec)) = noExtCon nec hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match" -- due to #15884 ------------------- hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)] -- ^ See Note [SrcSpan for binders] hsForeignDeclsBinders foreign_decls = [ cL decl_loc n | (dL->L decl_loc (ForeignImport { fd_name = (dL->L _ n) })) <- foreign_decls] ------------------- hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)] -- ^ Collects record pattern-synonym selectors only; the pattern synonym -- names are collected by collectHsValBinders. hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (XValBindsLR (NValBinds binds _)) = foldr addPatSynSelector [] . unionManyBags $ map snd binds addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p] addPatSynSelector bind sels | PatSynBind _ (PSB { psb_args = RecCon as }) <- unLoc bind = map (unLoc . recordPatSynSelectorId) as ++ sels | otherwise = sels getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id] getPatSynBinds binds = [ psb | (_, lbinds) <- binds , (dL->L _ (PatSynBind _ psb)) <- bagToList lbinds ] ------------------- hsLInstDeclBinders :: LInstDecl (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsLInstDeclBinders (dL->L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis }})) = foldMap (hsDataFamInstBinders . unLoc) dfis hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi })) = hsDataFamInstBinders fi hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec hsLInstDeclBinders (dL->L _ (XInstDecl nec)) = noExtCon nec hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match" -- due to #15884 ------------------- -- | the SrcLoc returned are for the whole declarations, not just the names hsDataFamInstBinders :: DataFamInstDecl (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = defn }}}) = hsDataDefnBinders defn -- There can't be repeated symbols because only data instances have binders hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = XFamEqn nec}}) = noExtCon nec hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec ------------------- -- | the SrcLoc returned are for the whole declarations, not just the names hsDataDefnBinders :: HsDataDefn (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] hsDataDefnBinders (XHsDataDefn nec) = noExtCon nec ------------------- type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)] -- Filters out ones that have already been seen hsConDeclsBinders :: [LConDecl (GhcPass p)] -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -- See hsLTyClDeclBinders for what this does -- The function is boringly complicated because of the records -- And since we only have equality, we have to be a little careful hsConDeclsBinders cons = go id cons where go :: Seen p -> [LConDecl (GhcPass p)] -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) go _ [] = ([], []) go remSeen (r:rs) -- Don't re-mangle the location of field names, because we don't -- have a record of the full location of the field declaration anyway = let loc = getLoc r in case unLoc r of -- remove only the first occurrence of any seen field in order to -- avoid circumventing detection of duplicate fields (#9156) ConDeclGADT { con_names = names, con_args = args } -> (map (cL loc . unLoc) names ++ ns, flds ++ fs) where (remSeen', flds) = get_flds remSeen args (ns, fs) = go remSeen' rs ConDeclH98 { con_name = name, con_args = args } -> ([cL loc (unLoc name)] ++ ns, flds ++ fs) where (remSeen', flds) = get_flds remSeen args (ns, fs) = go remSeen' rs XConDecl nec -> noExtCon nec get_flds :: Seen p -> HsConDeclDetails (GhcPass p) -> (Seen p, [LFieldOcc (GhcPass p)]) get_flds remSeen (RecCon flds) = (remSeen', fld_names) where fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds)) remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v | v <- fld_names] get_flds remSeen _ = (remSeen, []) {- Note [SrcSpan for binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~ When extracting the (Located RdrNme) for a binder, at least for the main name (the TyCon of a type declaration etc), we want to give it the @SrcSpan@ of the whole /declaration/, not just the name itself (which is how it appears in the syntax tree). This SrcSpan (for the entire declaration) is used as the SrcSpan for the Name that is finally produced, and hence for error messages. (See #8607.) Note [Binders in family instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In a type or data family instance declaration, the type constructor is an *occurrence* not a binding site type instance T Int = Int -> Int -- No binders data instance S Bool = S1 | S2 -- Binders are S1,S2 ************************************************************************ * * Collecting binders the user did not write * * ************************************************************************ The job of this family of functions is to run through binding sites and find the set of all Names that were defined "implicitly", without being explicitly written by the user. The main purpose is to find names introduced by record wildcards so that we can avoid warning the user when they don't use those names (#4404) Since the addition of -Wunused-record-wildcards, this function returns a pair of [(SrcSpan, [Name])]. Each element of the list is one set of implicit binders, the first component of the tuple is the document describes the possible fix to the problem (by removing the ..). This means there is some unfortunate coupling between this function and where it is used but it's only used for one specific purpose in one place so it seemed easier. -} lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] -> [(SrcSpan, [Name])] lStmtsImplicits = hs_lstmts where hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] -> [(SrcSpan, [Name])] hs_lstmts = concatMap (hs_stmt . unLoc) hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR))) -> [(SrcSpan, [Name])] hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts do_arg (_, XApplicativeArg nec) = noExtCon nec hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds) hs_stmt (BodyStmt {}) = [] hs_stmt (LastStmt {}) = [] hs_stmt (ParStmt _ xs _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs , s <- ss] hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss hs_stmt (XStmtLR nec) = noExtCon nec hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds hs_local_binds (HsIPBinds {}) = [] hs_local_binds (EmptyLocalBinds _) = [] hs_local_binds (XHsLocalBindsLR _) = [] hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])] hsValBindsImplicits (XValBindsLR (NValBinds binds _)) = concatMap (lhsBindsImplicits . snd) binds hsValBindsImplicits (ValBinds _ binds _) = lhsBindsImplicits binds lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])] lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) [] where lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat lhs_bind _ = [] lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])] lPatImplicits = hs_lpat where hs_lpat lpat = hs_pat (unLoc lpat) hs_lpats = foldr (\pat rest -> hs_lpat pat ++ rest) [] hs_pat (LazyPat _ pat) = hs_lpat pat hs_pat (BangPat _ pat) = hs_lpat pat hs_pat (AsPat _ _ pat) = hs_lpat pat hs_pat (ViewPat _ _ pat) = hs_lpat pat hs_pat (ParPat _ pat) = hs_lpat pat hs_pat (ListPat _ pats) = hs_lpats pats hs_pat (TuplePat _ pats _) = hs_lpats pats hs_pat (SigPat _ pat _) = hs_lpat pat hs_pat (CoPat _ _ pat _) = hs_pat pat hs_pat (ConPatIn n ps) = details n ps hs_pat (ConPatOut {pat_con=con, pat_args=ps}) = details (fmap conLikeName con) ps hs_pat _ = [] details :: Located Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])] details _ (PrefixCon ps) = hs_lpats ps details n (RecCon fs) = [(err_loc, collectPatsBinders implicit_pats) | Just{} <- [rec_dotdot fs] ] ++ hs_lpats explicit_pats where implicit_pats = map (hsRecFieldArg . unLoc) implicit explicit_pats = map (hsRecFieldArg . unLoc) explicit (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld | (i, fld) <- [0..] `zip` rec_flds fs , let pat_explicit = maybe True ((i<) . unLoc) (rec_dotdot fs)] err_loc = maybe (getLoc n) getLoc (rec_dotdot fs) details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2 ghc-lib-parser-8.10.2.20200808/compiler/GHC/HsToCore/PmCheck/Types.hs0000644000000000000000000004771413713635744022376 0ustar0000000000000000{- Author: George Karachalias Sebastian Graf -} {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} -- | Types used through-out pattern match checking. This module is mostly there -- to be imported from "TcRnTypes". The exposed API is that of -- "GHC.HsToCore.PmCheck.Oracle" and "GHC.HsToCore.PmCheck". module GHC.HsToCore.PmCheck.Types ( -- * Representations for Literals and AltCons PmLit(..), PmLitValue(..), PmAltCon(..), pmLitType, pmAltConType, -- ** Equality on 'PmAltCon's PmEquality(..), eqPmAltCon, -- ** Operations on 'PmLit' literalToPmLit, negatePmLit, overloadPmLit, pmLitAsStringLit, coreExprAsPmLit, -- * Caching partially matched COMPLETE sets ConLikeSet, PossibleMatches(..), -- * A 'DIdEnv' where entries may be shared Shared(..), SharedDIdEnv(..), emptySDIE, lookupSDIE, sameRepresentativeSDIE, setIndirectSDIE, setEntrySDIE, traverseSDIE, -- * The pattern match oracle VarInfo(..), TmState(..), TyState(..), Delta(..), initDelta ) where #include "GhclibHsVersions.h" import GhcPrelude import Util import Bag import FastString import Var (EvVar) import Id import VarEnv import UniqDSet import UniqDFM import Name import DataCon import ConLike import Outputable import Maybes import Type import TyCon import Literal import CoreSyn import CoreMap import CoreUtils (exprType) import PrelNames import TysWiredIn import TysPrim import TcType (evVarPred) import Numeric (fromRat) import Data.Foldable (find) import qualified Data.List.NonEmpty as NonEmpty import Data.Ratio -- | Literals (simple and overloaded ones) for pattern match checking. -- -- See Note [Undecidable Equality for PmAltCons] data PmLit = PmLit { pm_lit_ty :: Type , pm_lit_val :: PmLitValue } data PmLitValue = PmLitInt Integer | PmLitRat Rational | PmLitChar Char -- We won't actually see PmLitString in the oracle since we desugar strings to -- lists | PmLitString FastString | PmLitOverInt Int {- How often Negated? -} Integer | PmLitOverRat Int {- How often Negated? -} Rational | PmLitOverString FastString -- | Undecidable semantic equality result. -- See Note [Undecidable Equality for PmAltCons] data PmEquality = Equal | Disjoint | PossiblyOverlap deriving (Eq, Show) -- | When 'PmEquality' can be decided. @True <=> Equal@, @False <=> Disjoint@. decEquality :: Bool -> PmEquality decEquality True = Equal decEquality False = Disjoint -- | Undecidable equality for values represented by 'PmLit's. -- See Note [Undecidable Equality for PmAltCons] -- -- * @Just True@ ==> Surely equal -- * @Just False@ ==> Surely different (non-overlapping, even!) -- * @Nothing@ ==> Equality relation undecidable eqPmLit :: PmLit -> PmLit -> PmEquality eqPmLit (PmLit t1 v1) (PmLit t2 v2) -- no haddock | pprTrace "eqPmLit" (ppr t1 <+> ppr v1 $$ ppr t2 <+> ppr v2) False = undefined | not (t1 `eqType` t2) = Disjoint | otherwise = go v1 v2 where go (PmLitInt i1) (PmLitInt i2) = decEquality (i1 == i2) go (PmLitRat r1) (PmLitRat r2) = decEquality (r1 == r2) go (PmLitChar c1) (PmLitChar c2) = decEquality (c1 == c2) go (PmLitString s1) (PmLitString s2) = decEquality (s1 == s2) go (PmLitOverInt n1 i1) (PmLitOverInt n2 i2) | n1 == n2 && i1 == i2 = Equal go (PmLitOverRat n1 r1) (PmLitOverRat n2 r2) | n1 == n2 && r1 == r2 = Equal go (PmLitOverString s1) (PmLitOverString s2) | s1 == s2 = Equal go _ _ = PossiblyOverlap -- | Syntactic equality. instance Eq PmLit where a == b = eqPmLit a b == Equal -- | Type of a 'PmLit' pmLitType :: PmLit -> Type pmLitType (PmLit ty _) = ty -- | Undecidable equality for values represented by 'ConLike's. -- See Note [Undecidable Equality for PmAltCons]. -- 'PatSynCon's aren't enforced to be generative, so two syntactically different -- 'PatSynCon's might match the exact same values. Without looking into and -- reasoning about the pattern synonym's definition, we can't decide if their -- sets of matched values is different. -- -- * @Just True@ ==> Surely equal -- * @Just False@ ==> Surely different (non-overlapping, even!) -- * @Nothing@ ==> Equality relation undecidable eqConLike :: ConLike -> ConLike -> PmEquality eqConLike (RealDataCon dc1) (RealDataCon dc2) = decEquality (dc1 == dc2) eqConLike (PatSynCon psc1) (PatSynCon psc2) | psc1 == psc2 = Equal eqConLike _ _ = PossiblyOverlap -- | Represents the head of a match against a 'ConLike' or literal. -- Really similar to 'CoreSyn.AltCon'. data PmAltCon = PmAltConLike ConLike | PmAltLit PmLit -- | We can't in general decide whether two 'PmAltCon's match the same set of -- values. In addition to the reasons in 'eqPmLit' and 'eqConLike', a -- 'PmAltConLike' might or might not represent the same value as a 'PmAltLit'. -- See Note [Undecidable Equality for PmAltCons]. -- -- * @Just True@ ==> Surely equal -- * @Just False@ ==> Surely different (non-overlapping, even!) -- * @Nothing@ ==> Equality relation undecidable -- -- Examples (omitting some constructor wrapping): -- -- * @eqPmAltCon (LitInt 42) (LitInt 1) == Just False@: Lit equality is -- decidable -- * @eqPmAltCon (DataCon A) (DataCon B) == Just False@: DataCon equality is -- decidable -- * @eqPmAltCon (LitOverInt 42) (LitOverInt 1) == Nothing@: OverLit equality -- is undecidable -- * @eqPmAltCon (PatSyn PA) (PatSyn PB) == Nothing@: PatSyn equality is -- undecidable -- * @eqPmAltCon (DataCon I#) (LitInt 1) == Nothing@: DataCon to Lit -- comparisons are undecidable without reasoning about the wrapped @Int#@ -- * @eqPmAltCon (LitOverInt 1) (LitOverInt 1) == Just True@: We assume -- reflexivity for overloaded literals -- * @eqPmAltCon (PatSyn PA) (PatSyn PA) == Just True@: We assume reflexivity -- for Pattern Synonyms eqPmAltCon :: PmAltCon -> PmAltCon -> PmEquality eqPmAltCon (PmAltConLike cl1) (PmAltConLike cl2) = eqConLike cl1 cl2 eqPmAltCon (PmAltLit l1) (PmAltLit l2) = eqPmLit l1 l2 eqPmAltCon _ _ = PossiblyOverlap -- | Syntactic equality. instance Eq PmAltCon where a == b = eqPmAltCon a b == Equal -- | Type of a 'PmAltCon' pmAltConType :: PmAltCon -> [Type] -> Type pmAltConType (PmAltLit lit) _arg_tys = ASSERT( null _arg_tys ) pmLitType lit pmAltConType (PmAltConLike con) arg_tys = conLikeResTy con arg_tys {- Note [Undecidable Equality for PmAltCons] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Equality on overloaded literals is undecidable in the general case. Consider the following example: instance Num Bool where ... fromInteger 0 = False -- C-like representation of booleans fromInteger _ = True f :: Bool -> () f 1 = () -- Clause A f 2 = () -- Clause B Clause B is redundant but to detect this, we must decide the constraint: @fromInteger 2 ~ fromInteger 1@ which means that we have to look through function @fromInteger@, whose implementation could be anything. This poses difficulties for: 1. The expressive power of the check. We cannot expect a reasonable implementation of pattern matching to detect that @fromInteger 2 ~ fromInteger 1@ is True, unless we unfold function fromInteger. This puts termination at risk and is undecidable in the general case. 2. Error messages/Warnings. What should our message for @f@ above be? A reasonable approach would be to issue: Pattern matches are (potentially) redundant: f 2 = ... under the assumption that 1 == 2 but seems to complex and confusing for the user. We choose to equate only obviously equal overloaded literals, in all other cases we signal undecidability by returning Nothing from 'eqPmAltCons'. We do better for non-overloaded literals, because we know their fromInteger/fromString implementation is actually injective, allowing us to simplify the constraint @fromInteger 1 ~ fromInteger 2@ to @1 ~ 2@, which is trivially unsatisfiable. The impact of this treatment of overloaded literals is the following: * Redundancy checking is rather conservative, since it cannot see that clause B above is redundant. * We have instant equality check for overloaded literals (we do not rely on the term oracle which is rather expensive, both in terms of performance and memory). This significantly improves the performance of functions `covered` `uncovered` and `divergent` in deSugar/Check.hs and effectively addresses #11161. * The warnings issued are simpler. Similar reasoning applies to pattern synonyms: In contrast to data constructors, which are generative, constraints like F a ~ G b for two different pattern synonyms F and G aren't immediately unsatisfiable. We assume F a ~ F a, though. -} literalToPmLit :: Type -> Literal -> Maybe PmLit literalToPmLit ty l = PmLit ty <$> go l where go (LitChar c) = Just (PmLitChar c) go (LitFloat r) = Just (PmLitRat r) go (LitDouble r) = Just (PmLitRat r) go (LitString s) = Just (PmLitString (mkFastStringByteString s)) go (LitNumber _ i _) = Just (PmLitInt i) go _ = Nothing negatePmLit :: PmLit -> Maybe PmLit negatePmLit (PmLit ty v) = PmLit ty <$> go v where go (PmLitInt i) = Just (PmLitInt (-i)) go (PmLitRat r) = Just (PmLitRat (-r)) go (PmLitOverInt n i) = Just (PmLitOverInt (n+1) i) go (PmLitOverRat n r) = Just (PmLitOverRat (n+1) r) go _ = Nothing overloadPmLit :: Type -> PmLit -> Maybe PmLit overloadPmLit ty (PmLit _ v) = PmLit ty <$> go v where go (PmLitInt i) = Just (PmLitOverInt 0 i) go (PmLitRat r) = Just (PmLitOverRat 0 r) go (PmLitString s) | ty `eqType` stringTy = Just v | otherwise = Just (PmLitOverString s) go _ = Nothing pmLitAsStringLit :: PmLit -> Maybe FastString pmLitAsStringLit (PmLit _ (PmLitString s)) = Just s pmLitAsStringLit _ = Nothing coreExprAsPmLit :: CoreExpr -> Maybe PmLit -- coreExprAsPmLit e | pprTrace "coreExprAsPmLit" (ppr e) False = undefined coreExprAsPmLit (Tick _t e) = coreExprAsPmLit e coreExprAsPmLit (Lit l) = literalToPmLit (literalType l) l coreExprAsPmLit e = case collectArgs e of (Var x, [Lit l]) | Just dc <- isDataConWorkId_maybe x , dc `elem` [intDataCon, wordDataCon, charDataCon, floatDataCon, doubleDataCon] -> literalToPmLit (exprType e) l (Var x, [_ty, Lit n, Lit d]) | Just dc <- isDataConWorkId_maybe x , dataConName dc == ratioDataConName -- HACK: just assume we have a literal double. This case only occurs for -- overloaded lits anyway, so we immediately override type information -> literalToPmLit (exprType e) (mkLitDouble (litValue n % litValue d)) (Var x, args) -- Take care of -XRebindableSyntax. The last argument should be the (only) -- integer literal, otherwise we can't really do much about it. | [Lit l] <- dropWhile (not . is_lit) args -- getOccFS because of -XRebindableSyntax , getOccFS (idName x) == getOccFS fromIntegerName -> literalToPmLit (literalType l) l >>= overloadPmLit (exprType e) (Var x, args) -- Similar to fromInteger case | [r] <- dropWhile (not . is_ratio) args , getOccFS (idName x) == getOccFS fromRationalName -> coreExprAsPmLit r >>= overloadPmLit (exprType e) (Var x, [Type _ty, _dict, s]) | idName x == fromStringName -- NB: Calls coreExprAsPmLit and then overloadPmLit, so that we return PmLitOverStrings -> coreExprAsPmLit s >>= overloadPmLit (exprType e) -- These last two cases handle String literals (Var x, [Type ty]) | Just dc <- isDataConWorkId_maybe x , dc == nilDataCon , ty `eqType` charTy -> literalToPmLit stringTy (mkLitString "") (Var x, [Lit l]) | idName x `elem` [unpackCStringName, unpackCStringUtf8Name] -> literalToPmLit stringTy l _ -> Nothing where is_lit Lit{} = True is_lit _ = False is_ratio (Type _) = False is_ratio r | Just (tc, _) <- splitTyConApp_maybe (exprType r) = tyConName tc == ratioTyConName | otherwise = False instance Outputable PmLitValue where ppr (PmLitInt i) = ppr i ppr (PmLitRat r) = ppr (double (fromRat r)) -- good enough ppr (PmLitChar c) = pprHsChar c ppr (PmLitString s) = pprHsString s ppr (PmLitOverInt n i) = minuses n (ppr i) ppr (PmLitOverRat n r) = minuses n (ppr (double (fromRat r))) ppr (PmLitOverString s) = pprHsString s -- Take care of negated literals minuses :: Int -> SDoc -> SDoc minuses n sdoc = iterate (\sdoc -> parens (char '-' <> sdoc)) sdoc !! n instance Outputable PmLit where ppr (PmLit ty v) = ppr v <> suffix where -- Some ad-hoc hackery for displaying proper lit suffixes based on type tbl = [ (intPrimTy, primIntSuffix) , (int64PrimTy, primInt64Suffix) , (wordPrimTy, primWordSuffix) , (word64PrimTy, primWord64Suffix) , (charPrimTy, primCharSuffix) , (floatPrimTy, primFloatSuffix) , (doublePrimTy, primDoubleSuffix) ] suffix = fromMaybe empty (snd <$> find (eqType ty . fst) tbl) instance Outputable PmAltCon where ppr (PmAltConLike cl) = ppr cl ppr (PmAltLit l) = ppr l instance Outputable PmEquality where ppr = text . show type ConLikeSet = UniqDSet ConLike -- | A data type caching the results of 'completeMatchConLikes' with support for -- deletion of constructors that were already matched on. data PossibleMatches = PM (NonEmpty.NonEmpty ConLikeSet) -- ^ Each ConLikeSet is a (subset of) the constructors in a COMPLETE set -- 'NonEmpty' because the empty case would mean that the type has no COMPLETE -- set at all, for which we have 'NoPM'. | NoPM -- ^ No COMPLETE set for this type (yet). Think of overloaded literals. instance Outputable PossibleMatches where ppr (PM cs) = ppr (NonEmpty.toList cs) ppr NoPM = text "" -- | Either @Indirect x@, meaning the value is represented by that of @x@, or -- an @Entry@ containing containing the actual value it represents. data Shared a = Indirect Id | Entry a -- | A 'DIdEnv' in which entries can be shared by multiple 'Id's. -- Merge equivalence classes of two Ids by 'setIndirectSDIE' and set the entry -- of an Id with 'setEntrySDIE'. newtype SharedDIdEnv a = SDIE { unSDIE :: DIdEnv (Shared a) } emptySDIE :: SharedDIdEnv a emptySDIE = SDIE emptyDVarEnv lookupReprAndEntrySDIE :: SharedDIdEnv a -> Id -> (Id, Maybe a) lookupReprAndEntrySDIE sdie@(SDIE env) x = case lookupDVarEnv env x of Nothing -> (x, Nothing) Just (Indirect y) -> lookupReprAndEntrySDIE sdie y Just (Entry a) -> (x, Just a) -- | @lookupSDIE env x@ looks up an entry for @x@, looking through all -- 'Indirect's until it finds a shared 'Entry'. lookupSDIE :: SharedDIdEnv a -> Id -> Maybe a lookupSDIE sdie x = snd (lookupReprAndEntrySDIE sdie x) -- | Check if two variables are part of the same equivalence class. sameRepresentativeSDIE :: SharedDIdEnv a -> Id -> Id -> Bool sameRepresentativeSDIE sdie x y = fst (lookupReprAndEntrySDIE sdie x) == fst (lookupReprAndEntrySDIE sdie y) -- | @setIndirectSDIE env x y@ sets @x@'s 'Entry' to @Indirect y@, thereby -- merging @x@'s equivalence class into @y@'s. This will discard all info on -- @x@! setIndirectSDIE :: SharedDIdEnv a -> Id -> Id -> SharedDIdEnv a setIndirectSDIE sdie@(SDIE env) x y = SDIE $ extendDVarEnv env (fst (lookupReprAndEntrySDIE sdie x)) (Indirect y) -- | @setEntrySDIE env x a@ sets the 'Entry' @x@ is associated with to @a@, -- thereby modifying its whole equivalence class. setEntrySDIE :: SharedDIdEnv a -> Id -> a -> SharedDIdEnv a setEntrySDIE sdie@(SDIE env) x a = SDIE $ extendDVarEnv env (fst (lookupReprAndEntrySDIE sdie x)) (Entry a) traverseSDIE :: Applicative f => (a -> f b) -> SharedDIdEnv a -> f (SharedDIdEnv b) traverseSDIE f = fmap (SDIE . listToUDFM) . traverse g . udfmToList . unSDIE where g (u, Indirect y) = pure (u,Indirect y) g (u, Entry a) = (u,) . Entry <$> f a instance Outputable a => Outputable (Shared a) where ppr (Indirect x) = ppr x ppr (Entry a) = ppr a instance Outputable a => Outputable (SharedDIdEnv a) where ppr (SDIE env) = ppr env -- | The term oracle state. Stores 'VarInfo' for encountered 'Id's. These -- entries are possibly shared when we figure out that two variables must be -- equal, thus represent the same set of values. -- -- See Note [TmState invariants] in Oracle. data TmState = TmSt { ts_facts :: !(SharedDIdEnv VarInfo) -- ^ Facts about term variables. Deterministic env, so that we generate -- deterministic error messages. , ts_reps :: !(CoreMap Id) -- ^ An environment for looking up whether we already encountered semantically -- equivalent expressions that we want to represent by the same 'Id' -- representative. } -- | Information about an 'Id'. Stores positive ('vi_pos') facts, like @x ~ Just 42@, -- and negative ('vi_neg') facts, like "x is not (:)". -- Also caches the type ('vi_ty'), the 'PossibleMatches' of a COMPLETE set -- ('vi_cache'). -- -- Subject to Note [The Pos/Neg invariant] in PmOracle. data VarInfo = VI { vi_ty :: !Type -- ^ The type of the variable. Important for rejecting possible GADT -- constructors or incompatible pattern synonyms (@Just42 :: Maybe Int@). , vi_pos :: ![(PmAltCon, [Id])] -- ^ Positive info: 'PmAltCon' apps it is (i.e. @x ~ [Just y, PatSyn z]@), all -- at the same time (i.e. conjunctive). We need a list because of nested -- pattern matches involving pattern synonym -- case x of { Just y -> case x of PatSyn z -> ... } -- However, no more than one RealDataCon in the list, otherwise contradiction -- because of generativity. , vi_neg :: ![PmAltCon] -- ^ Negative info: A list of 'PmAltCon's that it cannot match. -- Example, assuming -- -- @ -- data T = Leaf Int | Branch T T | Node Int T -- @ -- -- then @x /~ [Leaf, Node]@ means that @x@ cannot match a @Leaf@ or @Node@, -- and hence can only match @Branch@. Is orthogonal to anything from 'vi_pos', -- in the sense that 'eqPmAltCon' returns @PossiblyOverlap@ for any pairing -- between 'vi_pos' and 'vi_neg'. -- See Note [Why record both positive and negative info?] , vi_cache :: !PossibleMatches -- ^ A cache of the associated COMPLETE sets. At any time a superset of -- possible constructors of each COMPLETE set. So, if it's not in here, we -- can't possibly match on it. Complementary to 'vi_neg'. We still need it -- to recognise completion of a COMPLETE set efficiently for large enums. } -- | Not user-facing. instance Outputable TmState where ppr (TmSt state reps) = ppr state $$ ppr reps -- | Not user-facing. instance Outputable VarInfo where ppr (VI ty pos neg cache) = braces (hcat (punctuate comma [ppr ty, ppr pos, ppr neg, ppr cache])) -- | Initial state of the term oracle. initTmState :: TmState initTmState = TmSt emptySDIE emptyCoreMap -- | The type oracle state. A poor man's 'TcSMonad.InsertSet': The invariant is -- that all constraints in there are mutually compatible. newtype TyState = TySt (Bag EvVar) -- | Not user-facing. instance Outputable TyState where ppr (TySt evs) = braces $ hcat $ punctuate comma $ map (ppr . evVarPred) $ bagToList evs initTyState :: TyState initTyState = TySt emptyBag -- | Term and type constraints to accompany each value vector abstraction. -- For efficiency, we store the term oracle state instead of the term -- constraints. data Delta = MkDelta { delta_ty_st :: TyState -- Type oracle; things like a~Int , delta_tm_st :: TmState } -- Term oracle; things like x~Nothing -- | An initial delta that is always satisfiable initDelta :: Delta initDelta = MkDelta initTyState initTmState instance Outputable Delta where ppr delta = vcat [ -- intentionally formatted this way enable the dev to comment in only -- the info she needs ppr (delta_tm_st delta), ppr (delta_ty_st delta) ] ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot/GHC/LanguageExtensions.hs0000644000000000000000000000120413713635662023720 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} -- | This module re-exports the 'Extension' type along with an orphan 'Binary' -- instance for it. -- -- Note that the @ghc-boot@ package has a large set of dependencies; for this -- reason the 'Extension' type itself is defined in the -- "GHC.LanguageExtensions.Type" module provided by the @ghc-boot-th@ package, -- which has no dependencies outside of @base@. For this reason -- @template-haskell@ depends upon @ghc-boot-th@, not @ghc-boot@. -- module GHC.LanguageExtensions ( module GHC.LanguageExtensions.Type ) where import Data.Binary import GHC.LanguageExtensions.Type instance Binary Extension ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs0000644000000000000000000000774013713635665025270 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : GHC.LanguageExtensions.Type -- Copyright : (c) The GHC Team -- -- Maintainer : ghc-devs@haskell.org -- Portability : portable -- -- A data type defining the language extensions supported by GHC. -- {-# LANGUAGE DeriveGeneric, Safe #-} module GHC.LanguageExtensions.Type ( Extension(..) ) where import Prelude -- See note [Why do we import Prelude here?] import GHC.Generics -- | The language extensions known to GHC. -- -- Note that there is an orphan 'Binary' instance for this type supplied by -- the "GHC.LanguageExtensions" module provided by @ghc-boot@. We can't provide -- here as this would require adding transitive dependencies to the -- @template-haskell@ package, which must have a minimal dependency set. data Extension -- See Note [Updating flag description in the User's Guide] in DynFlags = Cpp | OverlappingInstances | UndecidableInstances | IncoherentInstances | UndecidableSuperClasses | MonomorphismRestriction | MonoPatBinds | MonoLocalBinds | RelaxedPolyRec -- Deprecated | ExtendedDefaultRules -- Use GHC's extended rules for defaulting | ForeignFunctionInterface | UnliftedFFITypes | InterruptibleFFI | CApiFFI | GHCForeignImportPrim | JavaScriptFFI | ParallelArrays -- Syntactic support for parallel arrays | Arrows -- Arrow-notation syntax | TemplateHaskell | TemplateHaskellQuotes -- subset of TH supported by stage1, no splice | QuasiQuotes | ImplicitParams | ImplicitPrelude | ScopedTypeVariables | AllowAmbiguousTypes | UnboxedTuples | UnboxedSums | UnliftedNewtypes | BangPatterns | TypeFamilies | TypeFamilyDependencies | TypeInType | OverloadedStrings | OverloadedLists | NumDecimals | DisambiguateRecordFields | RecordWildCards | RecordPuns | ViewPatterns | GADTs | GADTSyntax | NPlusKPatterns | DoAndIfThenElse | BlockArguments | RebindableSyntax | ConstraintKinds | PolyKinds -- Kind polymorphism | DataKinds -- Datatype promotion | InstanceSigs | ApplicativeDo | StandaloneDeriving | DeriveDataTypeable | AutoDeriveTypeable -- Automatic derivation of Typeable | DeriveFunctor | DeriveTraversable | DeriveFoldable | DeriveGeneric -- Allow deriving Generic/1 | DefaultSignatures -- Allow extra signatures for defmeths | DeriveAnyClass -- Allow deriving any class | DeriveLift -- Allow deriving Lift | DerivingStrategies | DerivingVia -- Derive through equal representation | TypeSynonymInstances | FlexibleContexts | FlexibleInstances | ConstrainedClassMethods | MultiParamTypeClasses | NullaryTypeClasses | FunctionalDependencies | UnicodeSyntax | ExistentialQuantification | MagicHash | EmptyDataDecls | KindSignatures | RoleAnnotations | ParallelListComp | TransformListComp | MonadComprehensions | GeneralizedNewtypeDeriving | RecursiveDo | PostfixOperators | TupleSections | PatternGuards | LiberalTypeSynonyms | RankNTypes | ImpredicativeTypes | TypeOperators | ExplicitNamespaces | PackageImports | ExplicitForAll | AlternativeLayoutRule | AlternativeLayoutRuleTransitional | DatatypeContexts | NondecreasingIndentation | RelaxedLayout | TraditionalRecordSyntax | LambdaCase | MultiWayIf | BinaryLiterals | NegativeLiterals | HexFloatLiterals | DuplicateRecordFields | OverloadedLabels | EmptyCase | PatternSynonyms | PartialTypeSignatures | NamedWildCards | StaticPointers | TypeApplications | Strict | StrictData | MonadFailDesugaring | EmptyDataDeriving | NumericUnderscores | QuantifiedConstraints | StarIsType | ImportQualifiedPost | CUSKs | StandaloneKindSignatures deriving (Eq, Enum, Show, Generic, Bounded) ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot-th/GHC/Lexeme.hs0000644000000000000000000000323013713635665021751 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : GHC.Lexeme -- Copyright : (c) The GHC Team -- -- Maintainer : ghc-devs@haskell.org -- Portability : portable -- -- Functions to evaluate whether or not a string is a valid identifier. -- module GHC.Lexeme ( -- * Lexical characteristics of Haskell names startsVarSym, startsVarId, startsConSym, startsConId, startsVarSymASCII, isVarSymChar, okSymChar ) where import Prelude -- See note [Why do we import Prelude here?] import Data.Char -- | Is this character acceptable in a symbol (after the first char)? -- See alexGetByte in Lexer.x okSymChar :: Char -> Bool okSymChar c | c `elem` "(),;[]`{}_\"'" = False | otherwise = case generalCategory c of ConnectorPunctuation -> True DashPunctuation -> True OtherPunctuation -> True MathSymbol -> True CurrencySymbol -> True ModifierSymbol -> True OtherSymbol -> True _ -> False startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool startsVarSym c = okSymChar c && c /= ':' -- Infix Ids startsConSym c = c == ':' -- Infix data constructors startsVarId c = c == '_' || case generalCategory c of -- Ordinary Ids LowercaseLetter -> True OtherLetter -> True -- See #1103 _ -> False startsConId c = isUpper c || c == '(' -- Ordinary type constructors and data constructors startsVarSymASCII :: Char -> Bool startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" isVarSymChar :: Char -> Bool isVarSymChar c = c == ':' || startsVarSym c ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot/GHC/PackageDb.hs0000644000000000000000000005415113713635665021732 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.PackageDb -- Copyright : (c) The University of Glasgow 2009, Duncan Coutts 2014 -- -- Maintainer : ghc-devs@haskell.org -- Portability : portable -- -- This module provides the view of GHC's database of registered packages that -- is shared between GHC the compiler\/library, and the ghc-pkg program. It -- defines the database format that is shared between GHC and ghc-pkg. -- -- The database format, and this library are constructed so that GHC does not -- have to depend on the Cabal library. The ghc-pkg program acts as the -- gateway between the external package format (which is defined by Cabal) and -- the internal package format which is specialised just for GHC. -- -- GHC the compiler only needs some of the information which is kept about -- registerd packages, such as module names, various paths etc. On the other -- hand ghc-pkg has to keep all the information from Cabal packages and be able -- to regurgitate it for users and other tools. -- -- The first trick is that we duplicate some of the information in the package -- database. We essentially keep two versions of the datbase in one file, one -- version used only by ghc-pkg which keeps the full information (using the -- serialised form of the 'InstalledPackageInfo' type defined by the Cabal -- library); and a second version written by ghc-pkg and read by GHC which has -- just the subset of information that GHC needs. -- -- The second trick is that this module only defines in detail the format of -- the second version -- the bit GHC uses -- and the part managed by ghc-pkg -- is kept in the file but here we treat it as an opaque blob of data. That way -- this library avoids depending on Cabal. -- module GHC.PackageDb ( InstalledPackageInfo(..), DbModule(..), DbUnitId(..), BinaryStringRep(..), DbUnitIdModuleRep(..), emptyInstalledPackageInfo, PackageDbLock, lockPackageDb, unlockPackageDb, DbMode(..), DbOpenMode(..), isDbOpenReadMode, readPackageDbForGhc, readPackageDbForGhcPkg, writePackageDb ) where import Prelude -- See note [Why do we import Prelude here?] import Data.Version (Version(..)) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS.Char8 import qualified Data.ByteString.Lazy as BS.Lazy import qualified Data.ByteString.Lazy.Internal as BS.Lazy (defaultChunkSize) import qualified Data.Foldable as F import qualified Data.Traversable as F import Data.Binary as Bin import Data.Binary.Put as Bin import Data.Binary.Get as Bin import Control.Exception as Exception import Control.Monad (when) import System.FilePath import System.IO import System.IO.Error import GHC.IO.Exception (IOErrorType(InappropriateType)) import GHC.IO.Handle.Lock import System.Directory -- | This is a subset of Cabal's 'InstalledPackageInfo', with just the bits -- that GHC is interested in. See Cabal's documentation for a more detailed -- description of all of the fields. -- data InstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod = InstalledPackageInfo { unitId :: instunitid, componentId :: compid, instantiatedWith :: [(modulename, mod)], sourcePackageId :: srcpkgid, packageName :: srcpkgname, packageVersion :: Version, sourceLibName :: Maybe srcpkgname, abiHash :: String, depends :: [instunitid], -- | Like 'depends', but each dependency is annotated with the -- ABI hash we expect the dependency to respect. abiDepends :: [(instunitid, String)], importDirs :: [FilePath], hsLibraries :: [String], extraLibraries :: [String], extraGHCiLibraries :: [String], libraryDirs :: [FilePath], libraryDynDirs :: [FilePath], frameworks :: [String], frameworkDirs :: [FilePath], ldOptions :: [String], ccOptions :: [String], includes :: [String], includeDirs :: [FilePath], haddockInterfaces :: [FilePath], haddockHTMLs :: [FilePath], exposedModules :: [(modulename, Maybe mod)], hiddenModules :: [modulename], indefinite :: Bool, exposed :: Bool, trusted :: Bool } deriving (Eq, Show) -- | A convenience constraint synonym for common constraints over parameters -- to 'InstalledPackageInfo'. type RepInstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod = (BinaryStringRep srcpkgid, BinaryStringRep srcpkgname, BinaryStringRep modulename, BinaryStringRep compid, BinaryStringRep instunitid, DbUnitIdModuleRep instunitid compid unitid modulename mod) -- | A type-class for the types which can be converted into 'DbModule'/'DbUnitId'. -- There is only one type class because these types are mutually recursive. -- NB: The functional dependency helps out type inference in cases -- where types would be ambiguous. class DbUnitIdModuleRep instunitid compid unitid modulename mod | mod -> unitid, unitid -> mod, mod -> modulename, unitid -> compid, unitid -> instunitid where fromDbModule :: DbModule instunitid compid unitid modulename mod -> mod toDbModule :: mod -> DbModule instunitid compid unitid modulename mod fromDbUnitId :: DbUnitId instunitid compid unitid modulename mod -> unitid toDbUnitId :: unitid -> DbUnitId instunitid compid unitid modulename mod -- | @ghc-boot@'s copy of 'Module', i.e. what is serialized to the database. -- Use 'DbUnitIdModuleRep' to convert it into an actual 'Module'. -- It has phantom type parameters as this is the most convenient way -- to avoid undecidable instances. data DbModule instunitid compid unitid modulename mod = DbModule { dbModuleUnitId :: unitid, dbModuleName :: modulename } | DbModuleVar { dbModuleVarName :: modulename } deriving (Eq, Show) -- | @ghc-boot@'s copy of 'UnitId', i.e. what is serialized to the database. -- Use 'DbUnitIdModuleRep' to convert it into an actual 'UnitId'. -- It has phantom type parameters as this is the most convenient way -- to avoid undecidable instances. data DbUnitId instunitid compid unitid modulename mod = DbUnitId compid [(modulename, mod)] | DbInstalledUnitId instunitid deriving (Eq, Show) class BinaryStringRep a where fromStringRep :: BS.ByteString -> a toStringRep :: a -> BS.ByteString emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d e f g => InstalledPackageInfo a b c d e f g emptyInstalledPackageInfo = InstalledPackageInfo { unitId = fromStringRep BS.empty, componentId = fromStringRep BS.empty, instantiatedWith = [], sourcePackageId = fromStringRep BS.empty, packageName = fromStringRep BS.empty, packageVersion = Version [] [], sourceLibName = Nothing, abiHash = "", depends = [], abiDepends = [], importDirs = [], hsLibraries = [], extraLibraries = [], extraGHCiLibraries = [], libraryDirs = [], libraryDynDirs = [], frameworks = [], frameworkDirs = [], ldOptions = [], ccOptions = [], includes = [], includeDirs = [], haddockInterfaces = [], haddockHTMLs = [], exposedModules = [], hiddenModules = [], indefinite = False, exposed = False, trusted = False } -- | Represents a lock of a package db. newtype PackageDbLock = PackageDbLock Handle -- | Acquire an exclusive lock related to package DB under given location. lockPackageDb :: FilePath -> IO PackageDbLock -- | Release the lock related to package DB. unlockPackageDb :: PackageDbLock -> IO () -- | Acquire a lock of given type related to package DB under given location. lockPackageDbWith :: LockMode -> FilePath -> IO PackageDbLock lockPackageDbWith mode file = do -- We are trying to open the lock file and then lock it. Thus the lock file -- needs to either exist or we need to be able to create it. Ideally we -- would not assume that the lock file always exists in advance. When we are -- dealing with a package DB where we have write access then if the lock -- file does not exist then we can create it by opening the file in -- read/write mode. On the other hand if we are dealing with a package DB -- where we do not have write access (e.g. a global DB) then we can only -- open in read mode, and the lock file had better exist already or we're in -- trouble. So for global read-only DBs on platforms where we must lock the -- DB for reading then we will require that the installer/packaging has -- included the lock file. -- -- Thus the logic here is to first try opening in read-write mode -- and if that fails we try read-only (to handle global read-only DBs). -- If either succeed then lock the file. IO exceptions (other than the first -- open attempt failing due to the file not existing) simply propagate. -- -- Note that there is a complexity here which was discovered in #13945: some -- filesystems (e.g. NFS) will only allow exclusive locking if the fd was -- opened for write access. We would previously try opening the lockfile for -- read-only access first, however this failed when run on such filesystems. -- Consequently, we now try read-write access first, falling back to read-only -- if we are denied permission (e.g. in the case of a global database). catchJust (\e -> if isPermissionError e then Just () else Nothing) (lockFileOpenIn ReadWriteMode) (const $ lockFileOpenIn ReadMode) where lock = file <.> "lock" lockFileOpenIn io_mode = bracketOnError (openBinaryFile lock io_mode) hClose -- If file locking support is not available, ignore the error and proceed -- normally. Without it the only thing we lose on non-Windows platforms is -- the ability to safely issue concurrent updates to the same package db. $ \hnd -> do hLock hnd mode `catch` \FileLockingNotSupported -> return () return $ PackageDbLock hnd lockPackageDb = lockPackageDbWith ExclusiveLock unlockPackageDb (PackageDbLock hnd) = do hUnlock hnd hClose hnd -- | Mode to open a package db in. data DbMode = DbReadOnly | DbReadWrite -- | 'DbOpenMode' holds a value of type @t@ but only in 'DbReadWrite' mode. So -- it is like 'Maybe' but with a type argument for the mode to enforce that the -- mode is used consistently. data DbOpenMode (mode :: DbMode) t where DbOpenReadOnly :: DbOpenMode 'DbReadOnly t DbOpenReadWrite :: t -> DbOpenMode 'DbReadWrite t deriving instance Functor (DbOpenMode mode) deriving instance F.Foldable (DbOpenMode mode) deriving instance F.Traversable (DbOpenMode mode) isDbOpenReadMode :: DbOpenMode mode t -> Bool isDbOpenReadMode = \case DbOpenReadOnly -> True DbOpenReadWrite{} -> False -- | Read the part of the package DB that GHC is interested in. -- readPackageDbForGhc :: RepInstalledPackageInfo a b c d e f g => FilePath -> IO [InstalledPackageInfo a b c d e f g] readPackageDbForGhc file = decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case (pkgs, DbOpenReadOnly) -> return pkgs where getDbForGhc = do _version <- getHeader _ghcPartLen <- get :: Get Word32 ghcPart <- get -- the next part is for ghc-pkg, but we stop here. return ghcPart -- | Read the part of the package DB that ghc-pkg is interested in -- -- Note that the Binary instance for ghc-pkg's representation of packages -- is not defined in this package. This is because ghc-pkg uses Cabal types -- (and Binary instances for these) which this package does not depend on. -- -- If we open the package db in read only mode, we get its contents. Otherwise -- we additionally receive a PackageDbLock that represents a lock on the -- database, so that we can safely update it later. -- readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t -> IO (pkgs, DbOpenMode mode PackageDbLock) readPackageDbForGhcPkg file mode = decodeFromFile file mode getDbForGhcPkg where getDbForGhcPkg = do _version <- getHeader -- skip over the ghc part ghcPartLen <- get :: Get Word32 _ghcPart <- skip (fromIntegral ghcPartLen) -- the next part is for ghc-pkg ghcPkgPart <- get return ghcPkgPart -- | Write the whole of the package DB, both parts. -- writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d e f g) => FilePath -> [InstalledPackageInfo a b c d e f g] -> pkgs -> IO () writePackageDb file ghcPkgs ghcPkgPart = writeFileAtomic file (runPut putDbForGhcPkg) where putDbForGhcPkg = do putHeader put ghcPartLen putLazyByteString ghcPart put ghcPkgPart where ghcPartLen :: Word32 ghcPartLen = fromIntegral (BS.Lazy.length ghcPart) ghcPart = encode ghcPkgs getHeader :: Get (Word32, Word32) getHeader = do magic <- getByteString (BS.length headerMagic) when (magic /= headerMagic) $ fail "not a ghc-pkg db file, wrong file magic number" majorVersion <- get :: Get Word32 -- The major version is for incompatible changes minorVersion <- get :: Get Word32 -- The minor version is for compatible extensions when (majorVersion /= 1) $ fail "unsupported ghc-pkg db format version" -- If we ever support multiple major versions then we'll have to change -- this code -- The header can be extended without incrementing the major version, -- we ignore fields we don't know about (currently all). headerExtraLen <- get :: Get Word32 skip (fromIntegral headerExtraLen) return (majorVersion, minorVersion) putHeader :: Put putHeader = do putByteString headerMagic put majorVersion put minorVersion put headerExtraLen where majorVersion = 1 :: Word32 minorVersion = 0 :: Word32 headerExtraLen = 0 :: Word32 headerMagic :: BS.ByteString headerMagic = BS.Char8.pack "\0ghcpkg\0" -- TODO: we may be able to replace the following with utils from the binary -- package in future. -- | Feed a 'Get' decoder with data chunks from a file. -- decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs -> IO (pkgs, DbOpenMode mode PackageDbLock) decodeFromFile file mode decoder = case mode of DbOpenReadOnly -> do -- Note [Locking package database on Windows] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- When we open the package db in read only mode, there is no need to acquire -- shared lock on non-Windows platform because we update the database with an -- atomic rename, so readers will always see the database in a consistent -- state. #if defined(mingw32_HOST_OS) bracket (lockPackageDbWith SharedLock file) unlockPackageDb $ \_ -> do #endif (, DbOpenReadOnly) <$> decodeFileContents DbOpenReadWrite{} -> do -- When we open the package db in read/write mode, acquire an exclusive lock -- on the database and return it so we can keep it for the duration of the -- update. bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do (, DbOpenReadWrite lock) <$> decodeFileContents where decodeFileContents = withBinaryFile file ReadMode $ \hnd -> feed hnd (runGetIncremental decoder) feed hnd (Partial k) = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize if BS.null chunk then feed hnd (k Nothing) else feed hnd (k (Just chunk)) feed _ (Done _ _ res) = return res feed _ (Fail _ _ msg) = ioError err where err = mkIOError InappropriateType loc Nothing (Just file) `ioeSetErrorString` msg loc = "GHC.PackageDb.readPackageDb" -- Copied from Cabal's Distribution.Simple.Utils. writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO () writeFileAtomic targetPath content = do let (targetDir, targetFile) = splitFileName targetPath Exception.bracketOnError (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) (\(tmpPath, handle) -> do BS.Lazy.hPut handle content hClose handle renameFile tmpPath targetPath) instance (RepInstalledPackageInfo a b c d e f g) => Binary (InstalledPackageInfo a b c d e f g) where put (InstalledPackageInfo unitId componentId instantiatedWith sourcePackageId packageName packageVersion sourceLibName abiHash depends abiDepends importDirs hsLibraries extraLibraries extraGHCiLibraries libraryDirs libraryDynDirs frameworks frameworkDirs ldOptions ccOptions includes includeDirs haddockInterfaces haddockHTMLs exposedModules hiddenModules indefinite exposed trusted) = do put (toStringRep sourcePackageId) put (toStringRep packageName) put packageVersion put (fmap toStringRep sourceLibName) put (toStringRep unitId) put (toStringRep componentId) put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod)) instantiatedWith) put abiHash put (map toStringRep depends) put (map (\(k,v) -> (toStringRep k, v)) abiDepends) put importDirs put hsLibraries put extraLibraries put extraGHCiLibraries put libraryDirs put libraryDynDirs put frameworks put frameworkDirs put ldOptions put ccOptions put includes put includeDirs put haddockInterfaces put haddockHTMLs put (map (\(mod_name, mb_mod) -> (toStringRep mod_name, fmap toDbModule mb_mod)) exposedModules) put (map toStringRep hiddenModules) put indefinite put exposed put trusted get = do sourcePackageId <- get packageName <- get packageVersion <- get sourceLibName <- get unitId <- get componentId <- get instantiatedWith <- get abiHash <- get depends <- get abiDepends <- get importDirs <- get hsLibraries <- get extraLibraries <- get extraGHCiLibraries <- get libraryDirs <- get libraryDynDirs <- get frameworks <- get frameworkDirs <- get ldOptions <- get ccOptions <- get includes <- get includeDirs <- get haddockInterfaces <- get haddockHTMLs <- get exposedModules <- get hiddenModules <- get indefinite <- get exposed <- get trusted <- get return (InstalledPackageInfo (fromStringRep unitId) (fromStringRep componentId) (map (\(mod_name, mod) -> (fromStringRep mod_name, fromDbModule mod)) instantiatedWith) (fromStringRep sourcePackageId) (fromStringRep packageName) packageVersion (fmap fromStringRep sourceLibName) abiHash (map fromStringRep depends) (map (\(k,v) -> (fromStringRep k, v)) abiDepends) importDirs hsLibraries extraLibraries extraGHCiLibraries libraryDirs libraryDynDirs frameworks frameworkDirs ldOptions ccOptions includes includeDirs haddockInterfaces haddockHTMLs (map (\(mod_name, mb_mod) -> (fromStringRep mod_name, fmap fromDbModule mb_mod)) exposedModules) (map fromStringRep hiddenModules) indefinite exposed trusted) instance (BinaryStringRep modulename, BinaryStringRep compid, BinaryStringRep instunitid, DbUnitIdModuleRep instunitid compid unitid modulename mod) => Binary (DbModule instunitid compid unitid modulename mod) where put (DbModule dbModuleUnitId dbModuleName) = do putWord8 0 put (toDbUnitId dbModuleUnitId) put (toStringRep dbModuleName) put (DbModuleVar dbModuleVarName) = do putWord8 1 put (toStringRep dbModuleVarName) get = do b <- getWord8 case b of 0 -> do dbModuleUnitId <- get dbModuleName <- get return (DbModule (fromDbUnitId dbModuleUnitId) (fromStringRep dbModuleName)) _ -> do dbModuleVarName <- get return (DbModuleVar (fromStringRep dbModuleVarName)) instance (BinaryStringRep modulename, BinaryStringRep compid, BinaryStringRep instunitid, DbUnitIdModuleRep instunitid compid unitid modulename mod) => Binary (DbUnitId instunitid compid unitid modulename mod) where put (DbInstalledUnitId instunitid) = do putWord8 0 put (toStringRep instunitid) put (DbUnitId dbUnitIdComponentId dbUnitIdInsts) = do putWord8 1 put (toStringRep dbUnitIdComponentId) put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod)) dbUnitIdInsts) get = do b <- getWord8 case b of 0 -> do instunitid <- get return (DbInstalledUnitId (fromStringRep instunitid)) _ -> do dbUnitIdComponentId <- get dbUnitIdInsts <- get return (DbUnitId (fromStringRep dbUnitIdComponentId) (map (\(mod_name, mod) -> ( fromStringRep mod_name , fromDbModule mod)) dbUnitIdInsts)) ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot/GHC/Platform.hs0000644000000000000000000002124613713635665021714 0ustar0000000000000000{-# LANGUAGE LambdaCase, ScopedTypeVariables #-} -- | A description of the platform we're compiling for. -- module GHC.Platform ( PlatformMini(..), PlatformWordSize(..), Platform(..), platformArch, platformOS, Arch(..), OS(..), ArmISA(..), ArmISAExt(..), ArmABI(..), PPC_64ABI(..), target32Bit, isARM, osElfTarget, osMachOTarget, osSubsectionsViaSymbols, platformUsesFrameworks, platformWordSizeInBytes, platformWordSizeInBits, PlatformMisc(..), IntegerLibrary(..), stringEncodeArch, stringEncodeOS, ) where import Prelude -- See Note [Why do we import Prelude here?] import GHC.Read -- | Contains the bare-bones arch and os information. This isn't enough for -- code gen, but useful for tasks where we can fall back upon the host -- platform, as this is all we know about the host platform. data PlatformMini = PlatformMini { platformMini_arch :: Arch , platformMini_os :: OS } deriving (Read, Show, Eq) -- | Contains enough information for the native code generator to emit -- code for this platform. data Platform = Platform { platformMini :: PlatformMini, -- Word size in bytes (i.e. normally 4 or 8, -- for 32bit and 64bit platforms respectively) platformWordSize :: PlatformWordSize, platformUnregisterised :: Bool, platformHasGnuNonexecStack :: Bool, platformHasIdentDirective :: Bool, platformHasSubsectionsViaSymbols :: Bool, platformIsCrossCompiling :: Bool } deriving (Read, Show, Eq) data PlatformWordSize = PW4 -- ^ A 32-bit platform | PW8 -- ^ A 64-bit platform deriving (Eq) instance Show PlatformWordSize where show PW4 = "4" show PW8 = "8" instance Read PlatformWordSize where readPrec = do i :: Int <- readPrec case i of 4 -> return PW4 8 -> return PW8 other -> fail ("Invalid PlatformWordSize: " ++ show other) platformWordSizeInBytes :: Platform -> Int platformWordSizeInBytes p = case platformWordSize p of PW4 -> 4 PW8 -> 8 platformWordSizeInBits :: Platform -> Int platformWordSizeInBits p = platformWordSizeInBytes p * 8 -- | Legacy accessor platformArch :: Platform -> Arch platformArch = platformMini_arch . platformMini -- | Legacy accessor platformOS :: Platform -> OS platformOS = platformMini_os . platformMini -- | Architectures that the native code generator knows about. -- TODO: It might be nice to extend these constructors with information -- about what instruction set extensions an architecture might support. -- data Arch = ArchUnknown | ArchX86 | ArchX86_64 | ArchPPC | ArchPPC_64 { ppc_64ABI :: PPC_64ABI } | ArchS390X | ArchSPARC | ArchSPARC64 | ArchARM { armISA :: ArmISA , armISAExt :: [ArmISAExt] , armABI :: ArmABI } | ArchARM64 | ArchAlpha | ArchMipseb | ArchMipsel | ArchJavaScript deriving (Read, Show, Eq) -- Note [Platform Syntax] -- ~~~~~~~~~~~~~~~~~~~~~~ -- There is a very loose encoding of platforms shared by many tools we are -- encoding to here. GNU Config (http://git.savannah.gnu.org/cgit/config.git), -- and LLVM's http://llvm.org/doxygen/classllvm_1_1Triple.html are perhaps the -- most definitional parsers. The basic syntax is a list of of '-'-separated -- components. The Unix 'uname' command syntax is related but briefer. -- -- Those two parsers are quite forgiving, and even the 'config.sub' -- normalization is forgiving too. The "best" way to encode a platform is -- therefore somewhat a matter of taste. -- -- The 'stringEncode*' functions here convert each part of GHC's structured -- notion of a platform into one dash-separated component. -- | See Note [Platform Syntax]. stringEncodeArch :: Arch -> String stringEncodeArch = \case ArchUnknown -> "unknown" ArchX86 -> "i386" ArchX86_64 -> "x86_64" ArchPPC -> "powerpc" ArchPPC_64 { ppc_64ABI = abi } -> case abi of ELF_V1 -> "powerpc64" ELF_V2 -> "powerpc64le" ArchS390X -> "s390x" ArchSPARC -> "sparc" ArchSPARC64 -> "sparc64" ArchARM { armISA = isa, armISAExt = _, armABI = _ } -> "arm" ++ vsuf where vsuf = case isa of ARMv5 -> "v5" ARMv6 -> "v6" ARMv7 -> "v7" ArchARM64 -> "aarch64" ArchAlpha -> "alpha" ArchMipseb -> "mipseb" ArchMipsel -> "mipsel" ArchJavaScript -> "js" isARM :: Arch -> Bool isARM (ArchARM {}) = True isARM ArchARM64 = True isARM _ = False -- | Operating systems that the native code generator knows about. -- Having OSUnknown should produce a sensible default, but no promises. data OS = OSUnknown | OSLinux | OSDarwin | OSSolaris2 | OSMinGW32 | OSFreeBSD | OSDragonFly | OSOpenBSD | OSNetBSD | OSKFreeBSD | OSHaiku | OSQNXNTO | OSAIX | OSHurd deriving (Read, Show, Eq) -- | See Note [Platform Syntax]. stringEncodeOS :: OS -> String stringEncodeOS = \case OSUnknown -> "unknown" OSLinux -> "linux" OSDarwin -> "darwin" OSSolaris2 -> "solaris2" OSMinGW32 -> "mingw32" OSFreeBSD -> "freebsd" OSDragonFly -> "dragonfly" OSOpenBSD -> "openbsd" OSNetBSD -> "netbsd" OSKFreeBSD -> "kfreebsdgnu" OSHaiku -> "haiku" OSQNXNTO -> "nto-qnx" OSAIX -> "aix" OSHurd -> "hurd" -- | ARM Instruction Set Architecture, Extensions and ABI -- data ArmISA = ARMv5 | ARMv6 | ARMv7 deriving (Read, Show, Eq) data ArmISAExt = VFPv2 | VFPv3 | VFPv3D16 | NEON | IWMMX2 deriving (Read, Show, Eq) data ArmABI = SOFT | SOFTFP | HARD deriving (Read, Show, Eq) -- | PowerPC 64-bit ABI -- data PPC_64ABI = ELF_V1 | ELF_V2 deriving (Read, Show, Eq) -- | This predicate tells us whether the platform is 32-bit. target32Bit :: Platform -> Bool target32Bit p = case platformWordSize p of PW4 -> True PW8 -> False -- | This predicate tells us whether the OS supports ELF-like shared libraries. osElfTarget :: OS -> Bool osElfTarget OSLinux = True osElfTarget OSFreeBSD = True osElfTarget OSDragonFly = True osElfTarget OSOpenBSD = True osElfTarget OSNetBSD = True osElfTarget OSSolaris2 = True osElfTarget OSDarwin = False osElfTarget OSMinGW32 = False osElfTarget OSKFreeBSD = True osElfTarget OSHaiku = True osElfTarget OSQNXNTO = False osElfTarget OSAIX = False osElfTarget OSHurd = True osElfTarget OSUnknown = False -- Defaulting to False is safe; it means don't rely on any -- ELF-specific functionality. It is important to have a default for -- portability, otherwise we have to answer this question for every -- new platform we compile on (even unreg). -- | This predicate tells us whether the OS support Mach-O shared libraries. osMachOTarget :: OS -> Bool osMachOTarget OSDarwin = True osMachOTarget _ = False osUsesFrameworks :: OS -> Bool osUsesFrameworks OSDarwin = True osUsesFrameworks _ = False platformUsesFrameworks :: Platform -> Bool platformUsesFrameworks = osUsesFrameworks . platformOS osSubsectionsViaSymbols :: OS -> Bool osSubsectionsViaSymbols OSDarwin = True osSubsectionsViaSymbols _ = False -- | Platform-specific settings formerly hard-coded in Config.hs. -- -- These should probably be all be triaged whether they can be computed from -- other settings or belong in another another place (like 'Platform' above). data PlatformMisc = PlatformMisc { -- TODO Recalculate string from richer info? platformMisc_targetPlatformString :: String , platformMisc_integerLibrary :: String , platformMisc_integerLibraryType :: IntegerLibrary , platformMisc_ghcWithInterpreter :: Bool , platformMisc_ghcWithNativeCodeGen :: Bool , platformMisc_ghcWithSMP :: Bool , platformMisc_ghcRTSWays :: String -- | Determines whether we will be compiling info tables that reside just -- before the entry code, or with an indirection to the entry code. See -- TABLES_NEXT_TO_CODE in includes/rts/storage/InfoTables.h. , platformMisc_tablesNextToCode :: Bool , platformMisc_leadingUnderscore :: Bool , platformMisc_libFFI :: Bool , platformMisc_ghcThreaded :: Bool , platformMisc_ghcDebugged :: Bool , platformMisc_ghcRtsWithLibdw :: Bool , platformMisc_llvmTarget :: String } data IntegerLibrary = IntegerGMP | IntegerSimple deriving (Read, Show, Eq) ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot/GHC/Serialized.hs0000644000000000000000000001477113713635662022225 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- -- (c) The University of Glasgow 2002-2006 -- -- Serialized values module GHC.Serialized ( -- * Main Serialized data type Serialized(..), -- * Going into and out of 'Serialized' toSerialized, fromSerialized, -- * Handy serialization functions serializeWithData, deserializeWithData, ) where import Prelude -- See note [Why do we import Prelude here?] import Data.Bits import Data.Word ( Word8 ) import Data.Data -- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types data Serialized = Serialized TypeRep [Word8] -- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later toSerialized :: forall a. Typeable a => (a -> [Word8]) -> a -> Serialized toSerialized serialize what = Serialized (typeOf what) (serialize what) -- | If the 'Serialized' value contains something of the given type, then use the specified deserializer to return @Just@ that. -- Otherwise return @Nothing@. fromSerialized :: forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a fromSerialized deserialize (Serialized the_type bytes) | the_type == rep = Just (deserialize bytes) | otherwise = Nothing where rep = typeRep (Proxy :: Proxy a) -- | Use a 'Data' instance to implement a serialization scheme dual to that of 'deserializeWithData' serializeWithData :: Data a => a -> [Word8] serializeWithData what = serializeWithData' what [] serializeWithData' :: Data a => a -> [Word8] -> [Word8] serializeWithData' what = fst $ gfoldl (\(before, a_to_b) a -> (before . serializeWithData' a, a_to_b a)) (\x -> (serializeConstr (constrRep (toConstr what)), x)) what -- | Use a 'Data' instance to implement a deserialization scheme dual to that of 'serializeWithData' deserializeWithData :: Data a => [Word8] -> a deserializeWithData = snd . deserializeWithData' deserializeWithData' :: forall a. Data a => [Word8] -> ([Word8], a) deserializeWithData' bytes = deserializeConstr bytes $ \constr_rep bytes -> gunfold (\(bytes, b_to_r) -> let (bytes', b) = deserializeWithData' bytes in (bytes', b_to_r b)) (\x -> (bytes, x)) (repConstr (dataTypeOf (undefined :: a)) constr_rep) serializeConstr :: ConstrRep -> [Word8] -> [Word8] serializeConstr (AlgConstr ix) = serializeWord8 1 . serializeInt ix serializeConstr (IntConstr i) = serializeWord8 2 . serializeInteger i serializeConstr (FloatConstr r) = serializeWord8 3 . serializeRational r serializeConstr (CharConstr c) = serializeWord8 4 . serializeChar c deserializeConstr :: [Word8] -> (ConstrRep -> [Word8] -> a) -> a deserializeConstr bytes k = deserializeWord8 bytes $ \constr_ix bytes -> case constr_ix of 1 -> deserializeInt bytes $ \ix -> k (AlgConstr ix) 2 -> deserializeInteger bytes $ \i -> k (IntConstr i) 3 -> deserializeRational bytes $ \r -> k (FloatConstr r) 4 -> deserializeChar bytes $ \c -> k (CharConstr c) x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes serializeFixedWidthNum :: forall a. (Integral a, FiniteBits a) => a -> [Word8] -> [Word8] serializeFixedWidthNum what = go (finiteBitSize what) what where go :: Int -> a -> [Word8] -> [Word8] go size current rest | size <= 0 = rest | otherwise = fromIntegral (current .&. 255) : go (size - 8) (current `shiftR` 8) rest deserializeFixedWidthNum :: forall a b. (Integral a, FiniteBits a) => [Word8] -> (a -> [Word8] -> b) -> b deserializeFixedWidthNum bytes k = go (finiteBitSize (undefined :: a)) bytes k where go :: Int -> [Word8] -> (a -> [Word8] -> b) -> b go size bytes k | size <= 0 = k 0 bytes | otherwise = case bytes of (byte:bytes) -> go (size - 8) bytes (\x -> k ((x `shiftL` 8) .|. fromIntegral byte)) [] -> error "deserializeFixedWidthNum: unexpected end of stream" serializeEnum :: (Enum a) => a -> [Word8] -> [Word8] serializeEnum = serializeInt . fromEnum deserializeEnum :: Enum a => [Word8] -> (a -> [Word8] -> b) -> b deserializeEnum bytes k = deserializeInt bytes (k . toEnum) serializeWord8 :: Word8 -> [Word8] -> [Word8] serializeWord8 x = (x:) deserializeWord8 :: [Word8] -> (Word8 -> [Word8] -> a) -> a deserializeWord8 (byte:bytes) k = k byte bytes deserializeWord8 [] _ = error "deserializeWord8: unexpected end of stream" serializeInt :: Int -> [Word8] -> [Word8] serializeInt = serializeFixedWidthNum deserializeInt :: [Word8] -> (Int -> [Word8] -> a) -> a deserializeInt = deserializeFixedWidthNum serializeRational :: (Real a) => a -> [Word8] -> [Word8] serializeRational = serializeString . show . toRational deserializeRational :: (Fractional a) => [Word8] -> (a -> [Word8] -> b) -> b deserializeRational bytes k = deserializeString bytes (k . fromRational . read) serializeInteger :: Integer -> [Word8] -> [Word8] serializeInteger = serializeString . show deserializeInteger :: [Word8] -> (Integer -> [Word8] -> a) -> a deserializeInteger bytes k = deserializeString bytes (k . read) serializeChar :: Char -> [Word8] -> [Word8] serializeChar = serializeString . show deserializeChar :: [Word8] -> (Char -> [Word8] -> a) -> a deserializeChar bytes k = deserializeString bytes (k . read) serializeString :: String -> [Word8] -> [Word8] serializeString = serializeList serializeEnum deserializeString :: [Word8] -> (String -> [Word8] -> a) -> a deserializeString = deserializeList deserializeEnum serializeList :: (a -> [Word8] -> [Word8]) -> [a] -> [Word8] -> [Word8] serializeList serialize_element xs = serializeInt (length xs) . foldr (.) id (map serialize_element xs) deserializeList :: forall a b. (forall c. [Word8] -> (a -> [Word8] -> c) -> c) -> [Word8] -> ([a] -> [Word8] -> b) -> b deserializeList deserialize_element bytes k = deserializeInt bytes $ \len bytes -> go len bytes k where go :: Int -> [Word8] -> ([a] -> [Word8] -> b) -> b go len bytes k | len <= 0 = k [] bytes | otherwise = deserialize_element bytes (\elt bytes -> go (len - 1) bytes (k . (elt:))) ghc-lib-parser-8.10.2.20200808/libraries/ghc-boot/GHC/UniqueSubdir.hs0000644000000000000000000000165513713635665022551 0ustar0000000000000000module GHC.UniqueSubdir ( uniqueSubdir ) where import Prelude -- See Note [Why do we import Prelude here?] import Data.List (intercalate) import GHC.Platform import GHC.Version (cProjectVersion) -- | A filepath like @x86_64-linux-7.6.3@ with the platform string to use when -- constructing platform-version-dependent files that need to co-exist. -- -- 'ghc-pkg' falls back on the host platform if the settings file is missing, -- and so needs this since we don't have information about the host platform in -- as much detail as 'Platform', so we use 'PlatformMini' instead. uniqueSubdir :: PlatformMini -> FilePath uniqueSubdir archOs = intercalate "-" [ stringEncodeArch $ platformMini_arch archOs , stringEncodeOS $ platformMini_os archOs , cProjectVersion ] -- NB: This functionality is reimplemented in Cabal, so if you -- change it, be sure to update Cabal. -- TODO make Cabal use this now that it is in ghc-boot. ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs0000644000000000000000000000076113713636006025331 0ustar0000000000000000module GHC.Version where import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String cProjectGitCommitId = "29204b1c4f52ea34d84da33593052ee839293bf2" cProjectVersion :: String cProjectVersion = "8.10.2" cProjectVersionInt :: String cProjectVersionInt = "810" cProjectPatchLevel :: String cProjectPatchLevel = "2" cProjectPatchLevel1 :: String cProjectPatchLevel1 = "2" cProjectPatchLevel2 :: String cProjectPatchLevel2 = "" ghc-lib-parser-8.10.2.20200808/libraries/ghci/GHCi/BreakArray.hs0000644000000000000000000000662713713635665021542 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} ------------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2007 -- -- | Break Arrays -- -- An array of bytes, indexed by a breakpoint number (breakpointId in Tickish) -- There is one of these arrays per module. -- -- Each byte is -- 1 if the corresponding breakpoint is enabled -- 0 otherwise -- ------------------------------------------------------------------------------- module GHCi.BreakArray ( BreakArray (BA) -- constructor is exported only for ByteCodeGen , newBreakArray , getBreak , setBreakOn , setBreakOff , showBreakArray ) where import Prelude -- See note [Why do we import Prelude here?] import Control.Monad import Data.Word import GHC.Word import GHC.Exts import GHC.IO ( IO(..) ) import System.IO.Unsafe ( unsafeDupablePerformIO ) data BreakArray = BA (MutableByteArray# RealWorld) breakOff, breakOn :: Word8 breakOn = 1 breakOff = 0 showBreakArray :: BreakArray -> IO () showBreakArray array = do forM_ [0 .. (size array - 1)] $ \i -> do val <- readBreakArray array i putStr $ ' ' : show val putStr "\n" setBreakOn :: BreakArray -> Int -> IO Bool setBreakOn array index | safeIndex array index = do writeBreakArray array index breakOn return True | otherwise = return False setBreakOff :: BreakArray -> Int -> IO Bool setBreakOff array index | safeIndex array index = do writeBreakArray array index breakOff return True | otherwise = return False getBreak :: BreakArray -> Int -> IO (Maybe Word8) getBreak array index | safeIndex array index = do val <- readBreakArray array index return $ Just val | otherwise = return Nothing safeIndex :: BreakArray -> Int -> Bool safeIndex array index = index < size array && index >= 0 size :: BreakArray -> Int size (BA array) = size where -- We want to keep this operation pure. The mutable byte array -- is never resized so this is safe. size = unsafeDupablePerformIO $ sizeofMutableByteArray array sizeofMutableByteArray :: MutableByteArray# RealWorld -> IO Int sizeofMutableByteArray arr = IO $ \s -> case getSizeofMutableByteArray# arr s of (# s', n# #) -> (# s', I# n# #) allocBA :: Int -> IO BreakArray allocBA (I# sz) = IO $ \s1 -> case newByteArray# sz s1 of { (# s2, array #) -> (# s2, BA array #) } -- create a new break array and initialise elements to zero newBreakArray :: Int -> IO BreakArray newBreakArray entries@(I# sz) = do BA array <- allocBA entries case breakOff of W8# off -> do let loop n | isTrue# (n ==# sz) = return () | otherwise = do writeBA# array n off; loop (n +# 1#) loop 0# return $ BA array writeBA# :: MutableByteArray# RealWorld -> Int# -> Word# -> IO () writeBA# array i word = IO $ \s -> case writeWord8Array# array i word s of { s -> (# s, () #) } writeBreakArray :: BreakArray -> Int -> Word8 -> IO () writeBreakArray (BA array) (I# i) (W8# word) = writeBA# array i word readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word8 readBA# array i = IO $ \s -> case readWord8Array# array i s of { (# s, c #) -> (# s, W8# c #) } readBreakArray :: BreakArray -> Int -> IO Word8 readBreakArray (BA array) (I# i) = readBA# array i ghc-lib-parser-8.10.2.20200808/libraries/ghci/GHCi/FFI.hsc0000644000000000000000000001125013713635665020252 0ustar0000000000000000----------------------------------------------------------------------------- -- -- libffi bindings -- -- (c) The University of Glasgow 2008 -- ----------------------------------------------------------------------------- #include {-# LANGUAGE CPP, DeriveGeneric, DeriveAnyClass #-} module GHCi.FFI ( FFIType(..) , FFIConv(..) , C_ffi_cif , prepForeignCall , freeForeignCallInfo ) where import Prelude -- See note [Why do we import Prelude here?] import Control.Exception import Data.Binary import GHC.Generics import Foreign import Foreign.C data FFIType = FFIVoid | FFIPointer | FFIFloat | FFIDouble | FFISInt8 | FFISInt16 | FFISInt32 | FFISInt64 | FFIUInt8 | FFIUInt16 | FFIUInt32 | FFIUInt64 deriving (Show, Generic, Binary) data FFIConv = FFICCall | FFIStdCall deriving (Show, Generic, Binary) prepForeignCall :: FFIConv -> [FFIType] -- arg types -> FFIType -- result type -> IO (Ptr C_ffi_cif) -- token for making calls (must be freed by caller) prepForeignCall cconv arg_types result_type = do let n_args = length arg_types arg_arr <- mallocArray n_args pokeArray arg_arr (map ffiType arg_types) cif <- mallocBytes (#const sizeof(ffi_cif)) let abi = convToABI cconv r <- ffi_prep_cif cif abi (fromIntegral n_args) (ffiType result_type) arg_arr if (r /= fFI_OK) then throwIO (ErrorCall ("prepForeignCallFailed: " ++ show r)) else return (castPtr cif) freeForeignCallInfo :: Ptr C_ffi_cif -> IO () freeForeignCallInfo p = do free ((#ptr ffi_cif, arg_types) p) free p convToABI :: FFIConv -> C_ffi_abi convToABI FFICCall = fFI_DEFAULT_ABI #if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) convToABI FFIStdCall = fFI_STDCALL #endif -- unknown conventions are mapped to the default, (#3336) convToABI _ = fFI_DEFAULT_ABI ffiType :: FFIType -> Ptr C_ffi_type ffiType FFIVoid = ffi_type_void ffiType FFIPointer = ffi_type_pointer ffiType FFIFloat = ffi_type_float ffiType FFIDouble = ffi_type_double ffiType FFISInt8 = ffi_type_sint8 ffiType FFISInt16 = ffi_type_sint16 ffiType FFISInt32 = ffi_type_sint32 ffiType FFISInt64 = ffi_type_sint64 ffiType FFIUInt8 = ffi_type_uint8 ffiType FFIUInt16 = ffi_type_uint16 ffiType FFIUInt32 = ffi_type_uint32 ffiType FFIUInt64 = ffi_type_uint64 data C_ffi_type data C_ffi_cif type C_ffi_status = (#type ffi_status) type C_ffi_abi = (#type ffi_abi) foreign import ccall "&ffi_type_void" ffi_type_void :: Ptr C_ffi_type foreign import ccall "&ffi_type_uint8" ffi_type_uint8 :: Ptr C_ffi_type foreign import ccall "&ffi_type_sint8" ffi_type_sint8 :: Ptr C_ffi_type foreign import ccall "&ffi_type_uint16" ffi_type_uint16 :: Ptr C_ffi_type foreign import ccall "&ffi_type_sint16" ffi_type_sint16 :: Ptr C_ffi_type foreign import ccall "&ffi_type_uint32" ffi_type_uint32 :: Ptr C_ffi_type foreign import ccall "&ffi_type_sint32" ffi_type_sint32 :: Ptr C_ffi_type foreign import ccall "&ffi_type_uint64" ffi_type_uint64 :: Ptr C_ffi_type foreign import ccall "&ffi_type_sint64" ffi_type_sint64 :: Ptr C_ffi_type foreign import ccall "&ffi_type_float" ffi_type_float :: Ptr C_ffi_type foreign import ccall "&ffi_type_double" ffi_type_double :: Ptr C_ffi_type foreign import ccall "&ffi_type_pointer"ffi_type_pointer :: Ptr C_ffi_type fFI_OK :: C_ffi_status fFI_OK = (#const FFI_OK) --fFI_BAD_ABI :: C_ffi_status --fFI_BAD_ABI = (#const FFI_BAD_ABI) --fFI_BAD_TYPEDEF :: C_ffi_status --fFI_BAD_TYPEDEF = (#const FFI_BAD_TYPEDEF) fFI_DEFAULT_ABI :: C_ffi_abi fFI_DEFAULT_ABI = (#const FFI_DEFAULT_ABI) #if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) fFI_STDCALL :: C_ffi_abi fFI_STDCALL = (#const FFI_STDCALL) #endif -- ffi_status ffi_prep_cif(ffi_cif *cif, -- ffi_abi abi, -- unsigned int nargs, -- ffi_type *rtype, -- ffi_type **atypes); foreign import ccall "ffi_prep_cif" ffi_prep_cif :: Ptr C_ffi_cif -- cif -> C_ffi_abi -- abi -> CUInt -- nargs -> Ptr C_ffi_type -- result type -> Ptr (Ptr C_ffi_type) -- arg types -> IO C_ffi_status -- Currently unused: -- void ffi_call(ffi_cif *cif, -- void (*fn)(), -- void *rvalue, -- void **avalue); -- foreign import ccall "ffi_call" -- ffi_call :: Ptr C_ffi_cif -- cif -- -> FunPtr (IO ()) -- function to call -- -> Ptr () -- put result here -- -> Ptr (Ptr ()) -- arg values -- -> IO () ghc-lib-parser-8.10.2.20200808/libraries/ghci/GHCi/Message.hs0000644000000000000000000005170513713635665021100 0ustar0000000000000000{-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables, GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} -- | -- Remote GHCi message types and serialization. -- -- For details on Remote GHCi, see Note [Remote GHCi] in -- compiler/ghci/GHCi.hs. -- module GHCi.Message ( Message(..), Msg(..) , THMessage(..), THMsg(..) , QResult(..) , EvalStatus_(..), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..) , SerializableException(..) , toSerializableException, fromSerializableException , THResult(..), THResultType(..) , ResumeContext(..) , QState(..) , getMessage, putMessage, getTHMessage, putTHMessage , Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe ) where import Prelude -- See note [Why do we import Prelude here?] import GHCi.RemoteTypes import GHCi.FFI import GHCi.TH.Binary () -- For Binary instances import GHCi.BreakArray import GHC.LanguageExtensions import GHC.Exts.Heap import GHC.ForeignSrcLang import GHC.Fingerprint import Control.Concurrent import Control.Exception import Data.Binary import Data.Binary.Get import Data.Binary.Put import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Dynamic import Data.Typeable (TypeRep) import Data.IORef import Data.Map (Map) import Foreign import GHC.Generics import GHC.Stack.CCS import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH import System.Exit import System.IO import System.IO.Error -- ----------------------------------------------------------------------------- -- The RPC protocol between GHC and the interactive server -- | A @Message a@ is a message that returns a value of type @a@. -- These are requests sent from GHC to the server. data Message a where -- | Exit the iserv process Shutdown :: Message () RtsRevertCAFs :: Message () -- RTS Linker ------------------------------------------- -- These all invoke the corresponding functions in the RTS Linker API. InitLinker :: Message () LookupSymbol :: String -> Message (Maybe (RemotePtr ())) LookupClosure :: String -> Message (Maybe HValueRef) LoadDLL :: String -> Message (Maybe String) LoadArchive :: String -> Message () -- error? LoadObj :: String -> Message () -- error? UnloadObj :: String -> Message () -- error? AddLibrarySearchPath :: String -> Message (RemotePtr ()) RemoveLibrarySearchPath :: RemotePtr () -> Message Bool ResolveObjs :: Message Bool FindSystemLibrary :: String -> Message (Maybe String) -- Interpreter ------------------------------------------- -- | Create a set of BCO objects, and return HValueRefs to them -- Note: Each ByteString contains a Binary-encoded [ResolvedBCO], not -- a ResolvedBCO. The list is to allow us to serialise the ResolvedBCOs -- in parallel. See @createBCOs@ in compiler/ghci/GHCi.hsc. CreateBCOs :: [LB.ByteString] -> Message [HValueRef] -- | Release 'HValueRef's FreeHValueRefs :: [HValueRef] -> Message () -- | Add entries to the Static Pointer Table AddSptEntry :: Fingerprint -> HValueRef -> Message () -- | Malloc some data and return a 'RemotePtr' to it MallocData :: ByteString -> Message (RemotePtr ()) MallocStrings :: [ByteString] -> Message [RemotePtr ()] -- | Calls 'GHCi.FFI.prepareForeignCall' PrepFFI :: FFIConv -> [FFIType] -> FFIType -> Message (RemotePtr C_ffi_cif) -- | Free data previously created by 'PrepFFI' FreeFFI :: RemotePtr C_ffi_cif -> Message () -- | Create an info table for a constructor MkConInfoTable :: Int -- ptr words -> Int -- non-ptr words -> Int -- constr tag -> Int -- pointer tag -> ByteString -- constructor desccription -> Message (RemotePtr StgInfoTable) -- | Evaluate a statement EvalStmt :: EvalOpts -> EvalExpr HValueRef {- IO [a] -} -> Message (EvalStatus [HValueRef]) {- [a] -} -- | Resume evaluation of a statement after a breakpoint ResumeStmt :: EvalOpts -> RemoteRef (ResumeContext [HValueRef]) -> Message (EvalStatus [HValueRef]) -- | Abandon evaluation of a statement after a breakpoint AbandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> Message () -- | Evaluate something of type @IO String@ EvalString :: HValueRef {- IO String -} -> Message (EvalResult String) -- | Evaluate something of type @String -> IO String@ EvalStringToString :: HValueRef {- String -> IO String -} -> String -> Message (EvalResult String) -- | Evaluate something of type @IO ()@ EvalIO :: HValueRef {- IO a -} -> Message (EvalResult ()) -- | Create a set of CostCentres with the same module name MkCostCentres :: String -- module, RemotePtr so it can be shared -> [(String,String)] -- (name, SrcSpan) -> Message [RemotePtr CostCentre] -- | Show a 'CostCentreStack' as a @[String]@ CostCentreStackInfo :: RemotePtr CostCentreStack -> Message [String] -- | Create a new array of breakpoint flags NewBreakArray :: Int -- size -> Message (RemoteRef BreakArray) -- | Enable a breakpoint EnableBreakpoint :: RemoteRef BreakArray -> Int -- index -> Bool -- on or off -> Message () -- | Query the status of a breakpoint (True <=> enabled) BreakpointStatus :: RemoteRef BreakArray -> Int -- index -> Message Bool -- True <=> enabled -- | Get a reference to a free variable at a breakpoint GetBreakpointVar :: HValueRef -- the AP_STACK from EvalBreak -> Int -> Message (Maybe HValueRef) -- Template Haskell ------------------------------------------- -- For more details on how TH works with Remote GHCi, see -- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. -- | Start a new TH module, return a state token that should be StartTH :: Message (RemoteRef (IORef QState)) -- | Evaluate a TH computation. -- -- Returns a ByteString, because we have to force the result -- before returning it to ensure there are no errors lurking -- in it. The TH types don't have NFData instances, and even if -- they did, we have to serialize the value anyway, so we might -- as well serialize it to force it. RunTH :: RemoteRef (IORef QState) -> HValueRef {- e.g. TH.Q TH.Exp -} -> THResultType -> Maybe TH.Loc -> Message (QResult ByteString) -- | Run the given mod finalizers. RunModFinalizers :: RemoteRef (IORef QState) -> [RemoteRef (TH.Q ())] -> Message (QResult ()) -- | Remote interface to GHC.Exts.Heap.getClosureData. This is used by -- the GHCi debugger to inspect values in the heap for :print and -- type reconstruction. GetClosure :: HValueRef -> Message (GenClosure HValueRef) -- | Evaluate something. This is used to support :force in GHCi. Seq :: HValueRef -> Message (EvalResult ()) deriving instance Show (Message a) -- | Template Haskell return values data QResult a = QDone a -- ^ RunTH finished successfully; return value follows | QException String -- ^ RunTH threw an exception | QFail String -- ^ RunTH called 'fail' deriving (Generic, Show) instance Binary a => Binary (QResult a) -- | Messages sent back to GHC from GHCi.TH, to implement the methods -- of 'Quasi'. For an overview of how TH works with Remote GHCi, see -- Note [Remote Template Haskell] in GHCi.TH. data THMessage a where NewName :: String -> THMessage (THResult TH.Name) Report :: Bool -> String -> THMessage (THResult ()) LookupName :: Bool -> String -> THMessage (THResult (Maybe TH.Name)) Reify :: TH.Name -> THMessage (THResult TH.Info) ReifyFixity :: TH.Name -> THMessage (THResult (Maybe TH.Fixity)) ReifyType :: TH.Name -> THMessage (THResult TH.Type) ReifyInstances :: TH.Name -> [TH.Type] -> THMessage (THResult [TH.Dec]) ReifyRoles :: TH.Name -> THMessage (THResult [TH.Role]) ReifyAnnotations :: TH.AnnLookup -> TypeRep -> THMessage (THResult [ByteString]) ReifyModule :: TH.Module -> THMessage (THResult TH.ModuleInfo) ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness]) AddDependentFile :: FilePath -> THMessage (THResult ()) AddTempFile :: String -> THMessage (THResult FilePath) AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ()) AddCorePlugin :: String -> THMessage (THResult ()) AddTopDecls :: [TH.Dec] -> THMessage (THResult ()) AddForeignFilePath :: ForeignSrcLang -> FilePath -> THMessage (THResult ()) IsExtEnabled :: Extension -> THMessage (THResult Bool) ExtsEnabled :: THMessage (THResult [Extension]) StartRecover :: THMessage () EndRecover :: Bool -> THMessage () FailIfErrs :: THMessage (THResult ()) -- | Indicates that this RunTH is finished, and the next message -- will be the result of RunTH (a QResult). RunTHDone :: THMessage () deriving instance Show (THMessage a) data THMsg = forall a . (Binary a, Show a) => THMsg (THMessage a) getTHMessage :: Get THMsg getTHMessage = do b <- getWord8 case b of 0 -> THMsg <$> NewName <$> get 1 -> THMsg <$> (Report <$> get <*> get) 2 -> THMsg <$> (LookupName <$> get <*> get) 3 -> THMsg <$> Reify <$> get 4 -> THMsg <$> ReifyFixity <$> get 5 -> THMsg <$> (ReifyInstances <$> get <*> get) 6 -> THMsg <$> ReifyRoles <$> get 7 -> THMsg <$> (ReifyAnnotations <$> get <*> get) 8 -> THMsg <$> ReifyModule <$> get 9 -> THMsg <$> ReifyConStrictness <$> get 10 -> THMsg <$> AddDependentFile <$> get 11 -> THMsg <$> AddTempFile <$> get 12 -> THMsg <$> AddTopDecls <$> get 13 -> THMsg <$> (IsExtEnabled <$> get) 14 -> THMsg <$> return ExtsEnabled 15 -> THMsg <$> return StartRecover 16 -> THMsg <$> EndRecover <$> get 17 -> THMsg <$> return FailIfErrs 18 -> return (THMsg RunTHDone) 19 -> THMsg <$> AddModFinalizer <$> get 20 -> THMsg <$> (AddForeignFilePath <$> get <*> get) 21 -> THMsg <$> AddCorePlugin <$> get 22 -> THMsg <$> ReifyType <$> get n -> error ("getTHMessage: unknown message " ++ show n) putTHMessage :: THMessage a -> Put putTHMessage m = case m of NewName a -> putWord8 0 >> put a Report a b -> putWord8 1 >> put a >> put b LookupName a b -> putWord8 2 >> put a >> put b Reify a -> putWord8 3 >> put a ReifyFixity a -> putWord8 4 >> put a ReifyInstances a b -> putWord8 5 >> put a >> put b ReifyRoles a -> putWord8 6 >> put a ReifyAnnotations a b -> putWord8 7 >> put a >> put b ReifyModule a -> putWord8 8 >> put a ReifyConStrictness a -> putWord8 9 >> put a AddDependentFile a -> putWord8 10 >> put a AddTempFile a -> putWord8 11 >> put a AddTopDecls a -> putWord8 12 >> put a IsExtEnabled a -> putWord8 13 >> put a ExtsEnabled -> putWord8 14 StartRecover -> putWord8 15 EndRecover a -> putWord8 16 >> put a FailIfErrs -> putWord8 17 RunTHDone -> putWord8 18 AddModFinalizer a -> putWord8 19 >> put a AddForeignFilePath lang a -> putWord8 20 >> put lang >> put a AddCorePlugin a -> putWord8 21 >> put a ReifyType a -> putWord8 22 >> put a data EvalOpts = EvalOpts { useSandboxThread :: Bool , singleStep :: Bool , breakOnException :: Bool , breakOnError :: Bool } deriving (Generic, Show) instance Binary EvalOpts data ResumeContext a = ResumeContext { resumeBreakMVar :: MVar () , resumeStatusMVar :: MVar (EvalStatus a) , resumeThreadId :: ThreadId } -- | We can pass simple expressions to EvalStmt, consisting of values -- and application. This allows us to wrap the statement to be -- executed in another function, which is used by GHCi to implement -- :set args and :set prog. It might be worthwhile to extend this -- little language in the future. data EvalExpr a = EvalThis a | EvalApp (EvalExpr a) (EvalExpr a) deriving (Generic, Show) instance Binary a => Binary (EvalExpr a) type EvalStatus a = EvalStatus_ a a data EvalStatus_ a b = EvalComplete Word64 (EvalResult a) | EvalBreak Bool HValueRef{- AP_STACK -} Int {- break index -} Int {- uniq of ModuleName -} (RemoteRef (ResumeContext b)) (RemotePtr CostCentreStack) -- Cost centre stack deriving (Generic, Show) instance Binary a => Binary (EvalStatus_ a b) data EvalResult a = EvalException SerializableException | EvalSuccess a deriving (Generic, Show) instance Binary a => Binary (EvalResult a) -- SomeException can't be serialized because it contains dynamic -- types. However, we do very limited things with the exceptions that -- are thrown by interpreted computations: -- -- * We print them, e.g. "*** Exception: " -- * UserInterrupt has a special meaning -- * In ghc -e, exitWith should exit with the appropriate exit code -- -- So all we need to do is distinguish UserInterrupt and ExitCode, and -- all other exceptions can be represented by their 'show' string. -- data SerializableException = EUserInterrupt | EExitCode ExitCode | EOtherException String deriving (Generic, Show) toSerializableException :: SomeException -> SerializableException toSerializableException ex | Just UserInterrupt <- fromException ex = EUserInterrupt | Just (ec::ExitCode) <- fromException ex = (EExitCode ec) | otherwise = EOtherException (show (ex :: SomeException)) fromSerializableException :: SerializableException -> SomeException fromSerializableException EUserInterrupt = toException UserInterrupt fromSerializableException (EExitCode c) = toException c fromSerializableException (EOtherException str) = toException (ErrorCall str) instance Binary ExitCode instance Binary SerializableException data THResult a = THException String | THComplete a deriving (Generic, Show) instance Binary a => Binary (THResult a) data THResultType = THExp | THPat | THType | THDec | THAnnWrapper deriving (Enum, Show, Generic) instance Binary THResultType -- | The server-side Template Haskell state. This is created by the -- StartTH message. A new one is created per module that GHC -- typechecks. data QState = QState { qsMap :: Map TypeRep Dynamic -- ^ persistent data between splices in a module , qsLocation :: Maybe TH.Loc -- ^ location for current splice, if any , qsPipe :: Pipe -- ^ pipe to communicate with GHC } instance Show QState where show _ = "" -- Orphan instances of Binary for Ptr / FunPtr by conversion to Word64. -- This is to support Binary StgInfoTable which includes these. instance Binary (Ptr a) where put p = put (fromIntegral (ptrToWordPtr p) :: Word64) get = (wordPtrToPtr . fromIntegral) <$> (get :: Get Word64) instance Binary (FunPtr a) where put = put . castFunPtrToPtr get = castPtrToFunPtr <$> get -- Binary instances to support the GetClosure message instance Binary StgInfoTable instance Binary ClosureType instance Binary PrimType instance Binary a => Binary (GenClosure a) data Msg = forall a . (Binary a, Show a) => Msg (Message a) getMessage :: Get Msg getMessage = do b <- getWord8 case b of 0 -> Msg <$> return Shutdown 1 -> Msg <$> return InitLinker 2 -> Msg <$> LookupSymbol <$> get 3 -> Msg <$> LookupClosure <$> get 4 -> Msg <$> LoadDLL <$> get 5 -> Msg <$> LoadArchive <$> get 6 -> Msg <$> LoadObj <$> get 7 -> Msg <$> UnloadObj <$> get 8 -> Msg <$> AddLibrarySearchPath <$> get 9 -> Msg <$> RemoveLibrarySearchPath <$> get 10 -> Msg <$> return ResolveObjs 11 -> Msg <$> FindSystemLibrary <$> get 12 -> Msg <$> CreateBCOs <$> get 13 -> Msg <$> FreeHValueRefs <$> get 14 -> Msg <$> MallocData <$> get 15 -> Msg <$> MallocStrings <$> get 16 -> Msg <$> (PrepFFI <$> get <*> get <*> get) 17 -> Msg <$> FreeFFI <$> get 18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get) 19 -> Msg <$> (EvalStmt <$> get <*> get) 20 -> Msg <$> (ResumeStmt <$> get <*> get) 21 -> Msg <$> (AbandonStmt <$> get) 22 -> Msg <$> (EvalString <$> get) 23 -> Msg <$> (EvalStringToString <$> get <*> get) 24 -> Msg <$> (EvalIO <$> get) 25 -> Msg <$> (MkCostCentres <$> get <*> get) 26 -> Msg <$> (CostCentreStackInfo <$> get) 27 -> Msg <$> (NewBreakArray <$> get) 28 -> Msg <$> (EnableBreakpoint <$> get <*> get <*> get) 29 -> Msg <$> (BreakpointStatus <$> get <*> get) 30 -> Msg <$> (GetBreakpointVar <$> get <*> get) 31 -> Msg <$> return StartTH 32 -> Msg <$> (RunModFinalizers <$> get <*> get) 33 -> Msg <$> (AddSptEntry <$> get <*> get) 34 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get) 35 -> Msg <$> (GetClosure <$> get) 36 -> Msg <$> (Seq <$> get) 37 -> Msg <$> return RtsRevertCAFs _ -> error $ "Unknown Message code " ++ (show b) putMessage :: Message a -> Put putMessage m = case m of Shutdown -> putWord8 0 InitLinker -> putWord8 1 LookupSymbol str -> putWord8 2 >> put str LookupClosure str -> putWord8 3 >> put str LoadDLL str -> putWord8 4 >> put str LoadArchive str -> putWord8 5 >> put str LoadObj str -> putWord8 6 >> put str UnloadObj str -> putWord8 7 >> put str AddLibrarySearchPath str -> putWord8 8 >> put str RemoveLibrarySearchPath ptr -> putWord8 9 >> put ptr ResolveObjs -> putWord8 10 FindSystemLibrary str -> putWord8 11 >> put str CreateBCOs bco -> putWord8 12 >> put bco FreeHValueRefs val -> putWord8 13 >> put val MallocData bs -> putWord8 14 >> put bs MallocStrings bss -> putWord8 15 >> put bss PrepFFI conv args res -> putWord8 16 >> put conv >> put args >> put res FreeFFI p -> putWord8 17 >> put p MkConInfoTable p n t pt d -> putWord8 18 >> put p >> put n >> put t >> put pt >> put d EvalStmt opts val -> putWord8 19 >> put opts >> put val ResumeStmt opts val -> putWord8 20 >> put opts >> put val AbandonStmt val -> putWord8 21 >> put val EvalString val -> putWord8 22 >> put val EvalStringToString str val -> putWord8 23 >> put str >> put val EvalIO val -> putWord8 24 >> put val MkCostCentres mod ccs -> putWord8 25 >> put mod >> put ccs CostCentreStackInfo ptr -> putWord8 26 >> put ptr NewBreakArray sz -> putWord8 27 >> put sz EnableBreakpoint arr ix b -> putWord8 28 >> put arr >> put ix >> put b BreakpointStatus arr ix -> putWord8 29 >> put arr >> put ix GetBreakpointVar a b -> putWord8 30 >> put a >> put b StartTH -> putWord8 31 RunModFinalizers a b -> putWord8 32 >> put a >> put b AddSptEntry a b -> putWord8 33 >> put a >> put b RunTH st q loc ty -> putWord8 34 >> put st >> put q >> put loc >> put ty GetClosure a -> putWord8 35 >> put a Seq a -> putWord8 36 >> put a RtsRevertCAFs -> putWord8 37 -- ----------------------------------------------------------------------------- -- Reading/writing messages data Pipe = Pipe { pipeRead :: Handle , pipeWrite :: Handle , pipeLeftovers :: IORef (Maybe ByteString) } remoteCall :: Binary a => Pipe -> Message a -> IO a remoteCall pipe msg = do writePipe pipe (putMessage msg) readPipe pipe get remoteTHCall :: Binary a => Pipe -> THMessage a -> IO a remoteTHCall pipe msg = do writePipe pipe (putTHMessage msg) readPipe pipe get writePipe :: Pipe -> Put -> IO () writePipe Pipe{..} put | LB.null bs = return () | otherwise = do LB.hPut pipeWrite bs hFlush pipeWrite where bs = runPut put readPipe :: Pipe -> Get a -> IO a readPipe Pipe{..} get = do leftovers <- readIORef pipeLeftovers m <- getBin pipeRead get leftovers case m of Nothing -> throw $ mkIOError eofErrorType "GHCi.Message.remoteCall" (Just pipeRead) Nothing Just (result, new_leftovers) -> do writeIORef pipeLeftovers new_leftovers return result getBin :: Handle -> Get a -> Maybe ByteString -> IO (Maybe (a, Maybe ByteString)) getBin h get leftover = go leftover (runGetIncremental get) where go Nothing (Done leftover _ msg) = return (Just (msg, if B.null leftover then Nothing else Just leftover)) go _ Done{} = throwIO (ErrorCall "getBin: Done with leftovers") go (Just leftover) (Partial fun) = do go Nothing (fun (Just leftover)) go Nothing (Partial fun) = do -- putStrLn "before hGetSome" b <- B.hGetSome h (32*1024) -- printf "hGetSome: %d\n" (B.length b) if B.null b then return Nothing else go Nothing (fun (Just b)) go _lft (Fail _rest _off str) = throwIO (ErrorCall ("getBin: " ++ str)) ghc-lib-parser-8.10.2.20200808/libraries/ghci/GHCi/RemoteTypes.hs0000644000000000000000000000772213713635665021774 0ustar0000000000000000{-# LANGUAGE CPP, StandaloneDeriving, GeneralizedNewtypeDeriving #-} -- | -- Types for referring to remote objects in Remote GHCi. For more -- details, see Note [External GHCi pointers] in compiler/ghci/GHCi.hs -- -- For details on Remote GHCi, see Note [Remote GHCi] in -- compiler/ghci/GHCi.hs. -- module GHCi.RemoteTypes ( RemotePtr(..), toRemotePtr, fromRemotePtr, castRemotePtr , HValue(..) , RemoteRef, mkRemoteRef, localRef, freeRemoteRef , HValueRef, toHValueRef , ForeignRef, mkForeignRef, withForeignRef , ForeignHValue , unsafeForeignRefToRemoteRef, finalizeForeignRef ) where import Prelude -- See note [Why do we import Prelude here?] import Control.DeepSeq import Data.Word import Foreign hiding (newForeignPtr) import Foreign.Concurrent import Data.Binary import Unsafe.Coerce import GHC.Exts import GHC.ForeignPtr -- ----------------------------------------------------------------------------- -- RemotePtr -- Static pointers only; don't use this for heap-resident pointers. -- Instead use HValueRef. We will fix the remote pointer to be 64 bits. This -- should cover 64 and 32bit systems, and permits the exchange of remote ptrs -- between machines of different word size. For exmaple, when connecting to -- an iserv instance on a different architecture with different word size via -- -fexternal-interpreter. newtype RemotePtr a = RemotePtr Word64 toRemotePtr :: Ptr a -> RemotePtr a toRemotePtr p = RemotePtr (fromIntegral (ptrToWordPtr p)) fromRemotePtr :: RemotePtr a -> Ptr a fromRemotePtr (RemotePtr p) = wordPtrToPtr (fromIntegral p) castRemotePtr :: RemotePtr a -> RemotePtr b castRemotePtr (RemotePtr a) = RemotePtr a deriving instance Show (RemotePtr a) deriving instance Binary (RemotePtr a) deriving instance NFData (RemotePtr a) -- ----------------------------------------------------------------------------- -- HValueRef newtype HValue = HValue Any instance Show HValue where show _ = "" -- | A reference to a remote value. These are allocated and freed explicitly. newtype RemoteRef a = RemoteRef (RemotePtr ()) deriving (Show, Binary) -- We can discard type information if we want toHValueRef :: RemoteRef a -> RemoteRef HValue toHValueRef = unsafeCoerce -- For convenience type HValueRef = RemoteRef HValue -- | Make a reference to a local value that we can send remotely. -- This reference will keep the value that it refers to alive until -- 'freeRemoteRef' is called. mkRemoteRef :: a -> IO (RemoteRef a) mkRemoteRef a = do sp <- newStablePtr a return $! RemoteRef (toRemotePtr (castStablePtrToPtr sp)) -- | Convert an HValueRef to an HValue. Should only be used if the HValue -- originated in this process. localRef :: RemoteRef a -> IO a localRef (RemoteRef w) = deRefStablePtr (castPtrToStablePtr (fromRemotePtr w)) -- | Release an HValueRef that originated in this process freeRemoteRef :: RemoteRef a -> IO () freeRemoteRef (RemoteRef w) = freeStablePtr (castPtrToStablePtr (fromRemotePtr w)) -- | An HValueRef with a finalizer newtype ForeignRef a = ForeignRef (ForeignPtr ()) instance NFData (ForeignRef a) where rnf x = x `seq` () type ForeignHValue = ForeignRef HValue -- | Create a 'ForeignRef' from a 'RemoteRef'. The finalizer -- should arrange to call 'freeHValueRef' on the 'HValueRef'. (since -- this function needs to be called in the process that created the -- 'HValueRef', it cannot be called directly from the finalizer). mkForeignRef :: RemoteRef a -> IO () -> IO (ForeignRef a) mkForeignRef (RemoteRef hvref) finalizer = ForeignRef <$> newForeignPtr (fromRemotePtr hvref) finalizer -- | Use a 'ForeignHValue' withForeignRef :: ForeignRef a -> (RemoteRef a -> IO b) -> IO b withForeignRef (ForeignRef fp) f = withForeignPtr fp (f . RemoteRef . toRemotePtr) unsafeForeignRefToRemoteRef :: ForeignRef a -> RemoteRef a unsafeForeignRefToRemoteRef (ForeignRef fp) = RemoteRef (toRemotePtr (unsafeForeignPtrToPtr fp)) finalizeForeignRef :: ForeignRef a -> IO () finalizeForeignRef (ForeignRef fp) = finalizeForeignPtr fp ghc-lib-parser-8.10.2.20200808/libraries/ghci/GHCi/TH/Binary.hs0000644000000000000000000000462313713635665021250 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} -- This module is full of orphans, unfortunately module GHCi.TH.Binary () where import Prelude -- See note [Why do we import Prelude here?] import Data.Binary import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import GHC.Serialized import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH -- Put these in a separate module because they take ages to compile instance Binary TH.Loc instance Binary TH.Name instance Binary TH.ModName instance Binary TH.NameFlavour instance Binary TH.PkgName instance Binary TH.NameSpace instance Binary TH.Module instance Binary TH.Info instance Binary TH.Type instance Binary TH.TyLit instance Binary TH.TyVarBndr instance Binary TH.Role instance Binary TH.Lit instance Binary TH.Range instance Binary TH.Stmt instance Binary TH.Pat instance Binary TH.Exp instance Binary TH.Dec instance Binary TH.Overlap instance Binary TH.DerivClause instance Binary TH.DerivStrategy instance Binary TH.Guard instance Binary TH.Body instance Binary TH.Match instance Binary TH.Fixity instance Binary TH.TySynEqn instance Binary TH.FunDep instance Binary TH.AnnTarget instance Binary TH.RuleBndr instance Binary TH.Phases instance Binary TH.RuleMatch instance Binary TH.Inline instance Binary TH.Pragma instance Binary TH.Safety instance Binary TH.Callconv instance Binary TH.Foreign instance Binary TH.Bang instance Binary TH.SourceUnpackedness instance Binary TH.SourceStrictness instance Binary TH.DecidedStrictness instance Binary TH.FixityDirection instance Binary TH.OccName instance Binary TH.Con instance Binary TH.AnnLookup instance Binary TH.ModuleInfo instance Binary TH.Clause instance Binary TH.InjectivityAnn instance Binary TH.FamilyResultSig instance Binary TH.TypeFamilyHead instance Binary TH.PatSynDir instance Binary TH.PatSynArgs -- We need Binary TypeRep for serializing annotations instance Binary Serialized where put (Serialized tyrep wds) = put tyrep >> put (B.pack wds) get = Serialized <$> get <*> (B.unpack <$> get) instance Binary TH.Bytes where put (TH.Bytes ptr off sz) = put bs where bs = B.PS ptr (fromIntegral off) (fromIntegral sz) get = do B.PS ptr off sz <- get return (TH.Bytes ptr (fromIntegral off) (fromIntegral sz)) ghc-lib-parser-8.10.2.20200808/compiler/main/GhcMonad.hs0000644000000000000000000001512013713635745020260 0ustar0000000000000000{-# LANGUAGE CPP, DeriveFunctor, RankNTypes #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow, 2010 -- -- The Session type and related functionality -- -- ----------------------------------------------------------------------------- module GhcMonad ( -- * 'Ghc' monad stuff GhcMonad(..), Ghc(..), GhcT(..), liftGhcT, reflectGhc, reifyGhc, getSessionDynFlags, liftIO, Session(..), withSession, modifySession, withTempSession, -- ** Warnings logWarnings, printException, WarnErrLogger, defaultWarnErrLogger ) where import GhcPrelude import MonadUtils import HscTypes import DynFlags import Exception import ErrUtils import Control.Monad import Data.IORef -- ----------------------------------------------------------------------------- -- | A monad that has all the features needed by GHC API calls. -- -- In short, a GHC monad -- -- - allows embedding of IO actions, -- -- - can log warnings, -- -- - allows handling of (extensible) exceptions, and -- -- - maintains a current session. -- -- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' -- before any call to the GHC API functions can occur. -- class (Functor m, MonadIO m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where getSession :: m HscEnv setSession :: HscEnv -> m () -- | Call the argument with the current session. withSession :: GhcMonad m => (HscEnv -> m a) -> m a withSession f = getSession >>= f -- | Grabs the DynFlags from the Session getSessionDynFlags :: GhcMonad m => m DynFlags getSessionDynFlags = withSession (return . hsc_dflags) -- | Set the current session to the result of applying the current session to -- the argument. modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m () modifySession f = do h <- getSession setSession $! f h withSavedSession :: GhcMonad m => m a -> m a withSavedSession m = do saved_session <- getSession m `gfinally` setSession saved_session -- | Call an action with a temporarily modified Session. withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a withTempSession f m = withSavedSession $ modifySession f >> m -- ----------------------------------------------------------------------------- -- | A monad that allows logging of warnings. logWarnings :: GhcMonad m => WarningMessages -> m () logWarnings warns = do dflags <- getSessionDynFlags liftIO $ printOrThrowWarnings dflags warns -- ----------------------------------------------------------------------------- -- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, -- e.g., to maintain additional state consider wrapping this monad or using -- 'GhcT'. newtype Ghc a = Ghc { unGhc :: Session -> IO a } deriving (Functor) -- | The Session is a handle to the complete state of a compilation -- session. A compilation session consists of a set of modules -- constituting the current program or library, the context for -- interactive evaluation, and various caches. data Session = Session !(IORef HscEnv) instance Applicative Ghc where pure a = Ghc $ \_ -> return a g <*> m = do f <- g; a <- m; return (f a) instance Monad Ghc where m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s instance MonadIO Ghc where liftIO ioA = Ghc $ \_ -> ioA instance MonadFix Ghc where mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s) instance ExceptionMonad Ghc where gcatch act handle = Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s gmask f = Ghc $ \s -> gmask $ \io_restore -> let g_restore (Ghc m) = Ghc $ \s -> io_restore (m s) in unGhc (f g_restore) s instance HasDynFlags Ghc where getDynFlags = getSessionDynFlags instance GhcMonad Ghc where getSession = Ghc $ \(Session r) -> readIORef r setSession s' = Ghc $ \(Session r) -> writeIORef r s' -- | Reflect a computation in the 'Ghc' monad into the 'IO' monad. -- -- You can use this to call functions returning an action in the 'Ghc' monad -- inside an 'IO' action. This is needed for some (too restrictive) callback -- arguments of some library functions: -- -- > libFunc :: String -> (Int -> IO a) -> IO a -- > ghcFunc :: Int -> Ghc a -- > -- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a -- > ghcFuncUsingLibFunc str = -- > reifyGhc $ \s -> -- > libFunc $ \i -> do -- > reflectGhc (ghcFunc i) s -- reflectGhc :: Ghc a -> Session -> IO a reflectGhc m = unGhc m -- > Dual to 'reflectGhc'. See its documentation. reifyGhc :: (Session -> IO a) -> Ghc a reifyGhc act = Ghc $ act -- ----------------------------------------------------------------------------- -- | A monad transformer to add GHC specific features to another monad. -- -- Note that the wrapped monad must support IO and handling of exceptions. newtype GhcT m a = GhcT { unGhcT :: Session -> m a } deriving (Functor) liftGhcT :: m a -> GhcT m a liftGhcT m = GhcT $ \_ -> m instance Applicative m => Applicative (GhcT m) where pure x = GhcT $ \_ -> pure x g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s instance Monad m => Monad (GhcT m) where m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s instance MonadIO m => MonadIO (GhcT m) where liftIO ioA = GhcT $ \_ -> liftIO ioA instance ExceptionMonad m => ExceptionMonad (GhcT m) where gcatch act handle = GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s gmask f = GhcT $ \s -> gmask $ \io_restore -> let g_restore (GhcT m) = GhcT $ \s -> io_restore (m s) in unGhcT (f g_restore) s instance MonadIO m => HasDynFlags (GhcT m) where getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) instance ExceptionMonad m => GhcMonad (GhcT m) where getSession = GhcT $ \(Session r) -> liftIO $ readIORef r setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' -- | Print the error message and all warnings. Useful inside exception -- handlers. Clears warnings after printing. printException :: GhcMonad m => SourceError -> m () printException err = do dflags <- getSessionDynFlags liftIO $ printBagOfErrors dflags (srcErrorMessages err) -- | A function called to log warnings and errors. type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m () defaultWarnErrLogger :: WarnErrLogger defaultWarnErrLogger Nothing = return () defaultWarnErrLogger (Just e) = printException e ghc-lib-parser-8.10.2.20200808/compiler/main/GhcNameVersion.hs0000644000000000000000000000036113713635745021451 0ustar0000000000000000module GhcNameVersion ( GhcNameVersion (..) ) where import GhcPrelude -- | Settings for what GHC this is. data GhcNameVersion = GhcNameVersion { ghcNameVersion_programName :: String , ghcNameVersion_projectVersion :: String } ghc-lib-parser-8.10.2.20200808/compiler/utils/GhcPrelude.hs0000644000000000000000000000211513713635745021036 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Custom GHC "Prelude" -- -- This module serves as a replacement for the "Prelude" module -- and abstracts over differences between the bootstrapping -- GHC version, and may also provide a common default vocabulary. -- Every module in GHC -- * Is compiled with -XNoImplicitPrelude -- * Explicitly imports GhcPrelude module GhcPrelude (module X) where -- We export the 'Semigroup' class but w/o the (<>) operator to avoid -- clashing with the (Outputable.<>) operator which is heavily used -- through GHC's code-base. import Prelude as X hiding ((<>)) import Data.Foldable as X (foldl') {- Note [Why do we import Prelude here?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The files ghc-boot-th.cabal, ghc-boot.cabal, ghci.cabal and ghc-heap.cabal contain the directive default-extensions: NoImplicitPrelude. There are two motivations for this: - Consistency with the compiler directory, which enables NoImplicitPrelude; - Allows loading the above dependent packages with ghc-in-ghci, giving a smoother development experience when adding new extensions. -} ghc-lib-parser-8.10.2.20200808/compiler/parser/HaddockUtils.hs0000644000000000000000000000200713713635745021526 0ustar0000000000000000 module HaddockUtils where import GhcPrelude import GHC.Hs import SrcLoc import Control.Monad -- ----------------------------------------------------------------------------- -- Adding documentation to record fields (used in parsing). addFieldDoc :: LConDeclField a -> Maybe LHsDocString -> LConDeclField a addFieldDoc (L l fld) doc = L l (fld { cd_fld_doc = cd_fld_doc fld `mplus` doc }) addFieldDocs :: [LConDeclField a] -> Maybe LHsDocString -> [LConDeclField a] addFieldDocs [] _ = [] addFieldDocs (x:xs) doc = addFieldDoc x doc : xs addConDoc :: LConDecl a -> Maybe LHsDocString -> LConDecl a addConDoc decl Nothing = decl addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } ) addConDocs :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a] addConDocs [] _ = [] addConDocs [x] doc = [addConDoc x doc] addConDocs (x:xs) doc = x : addConDocs xs doc addConDocFirst :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a] addConDocFirst [] _ = [] addConDocFirst (x:xs) doc = addConDoc x doc : xs ghc-lib-parser-8.10.2.20200808/compiler/main/HeaderInfo.hs0000644000000000000000000003551513713635745020616 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- -- | Parsing the top of a Haskell source file to get its module name, -- imports and options. -- -- (c) Simon Marlow 2005 -- (c) Lemmih 2006 -- ----------------------------------------------------------------------------- module HeaderInfo ( getImports , mkPrelImports -- used by the renamer too , getOptionsFromFile, getOptions , optionsErrorMsgs, checkProcessArgsResult ) where #include "GhclibHsVersions.h" import GhcPrelude import GHC.Platform import HscTypes import Parser ( parseHeader ) import Lexer import FastString import GHC.Hs import Module import PrelNames import StringBuffer import SrcLoc import DynFlags import ErrUtils import Util import Outputable import Maybes import Bag ( emptyBag, listToBag, unitBag ) import MonadUtils import Exception import BasicTypes import qualified GHC.LanguageExtensions as LangExt import Control.Monad import System.IO import System.IO.Unsafe import Data.List ------------------------------------------------------------------------------ -- | Parse the imports of a source file. -- -- Throws a 'SourceError' if parsing fails. getImports :: DynFlags -> StringBuffer -- ^ Parse this. -> FilePath -- ^ Filename the buffer came from. Used for -- reporting parse error locations. -> FilePath -- ^ The original source filename (used for locations -- in the function result) -> IO (Either ErrorMessages ([(Maybe FastString, Located ModuleName)], [(Maybe FastString, Located ModuleName)], Located ModuleName)) -- ^ The source imports, normal imports, and the module name. getImports dflags buf filename source_filename = do let loc = mkRealSrcLoc (mkFastString filename) 1 1 case unP parseHeader (mkPState dflags buf loc) of PFailed pst -> -- assuming we're not logging warnings here as per below return $ Left $ getErrorMessages pst dflags POk pst rdr_module -> fmap Right $ do let _ms@(_warns, errs) = getMessages pst dflags -- don't log warnings: they'll be reported when we parse the file -- for real. See #2500. ms = (emptyBag, errs) -- logWarnings warns if errorsFound dflags ms then throwIO $ mkSrcErr errs else let hsmod = unLoc rdr_module mb_mod = hsmodName hsmod imps = hsmodImports hsmod main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 1 1) mod = mb_mod `orElse` cL main_loc mAIN_NAME (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps -- GHC.Prim doesn't exist physically, so don't go looking for it. ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) ord_idecls implicit_prelude = xopt LangExt.ImplicitPrelude dflags implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_prelude imps convImport (dL->L _ i) = (fmap sl_fs (ideclPkgQual i) , ideclName i) in return (map convImport src_idecls, map convImport (implicit_imports ++ ordinary_imps), mod) mkPrelImports :: ModuleName -> SrcSpan -- Attribute the "import Prelude" to this location -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs] -- Construct the implicit declaration "import Prelude" (or not) -- -- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); -- because the former doesn't even look at Prelude.hi for instance -- declarations, whereas the latter does. mkPrelImports this_mod loc implicit_prelude import_decls | this_mod == pRELUDE_NAME || explicit_prelude_import || not implicit_prelude = [] | otherwise = [preludeImportDecl] where explicit_prelude_import = notNull [ () | (dL->L _ (ImportDecl { ideclName = mod , ideclPkgQual = Nothing })) <- import_decls , unLoc mod == pRELUDE_NAME ] preludeImportDecl :: LImportDecl GhcPs preludeImportDecl = cL loc $ ImportDecl { ideclExt = noExtField, ideclSourceSrc = NoSourceText, ideclName = cL loc pRELUDE_NAME, ideclPkgQual = Nothing, ideclSource = False, ideclSafe = False, -- Not a safe import ideclQualified = NotQualified, ideclImplicit = True, -- Implicit! ideclAs = Nothing, ideclHiding = Nothing } -------------------------------------------------------------- -- Get options -------------------------------------------------------------- -- | Parse OPTIONS and LANGUAGE pragmas of the source file. -- -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) getOptionsFromFile :: DynFlags -> FilePath -- ^ Input file -> IO [Located String] -- ^ Parsed options, if any. getOptionsFromFile dflags filename = Exception.bracket (openBinaryFile filename ReadMode) (hClose) (\handle -> do opts <- fmap (getOptions' dflags) (lazyGetToks dflags' filename handle) seqList opts $ return opts) where -- We don't need to get haddock doc tokens when we're just -- getting the options from pragmas, and lazily lexing them -- correctly is a little tricky: If there is "\n" or "\n-" -- left at the end of a buffer then the haddock doc may -- continue past the end of the buffer, despite the fact that -- we already have an apparently-complete token. -- We therefore just turn Opt_Haddock off when doing the lazy -- lex. dflags' = gopt_unset dflags Opt_Haddock blockSize :: Int -- blockSize = 17 -- for testing :-) blockSize = 1024 lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token] lazyGetToks dflags filename handle = do buf <- hGetStringBufferBlock handle blockSize unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize where loc = mkRealSrcLoc (mkFastString filename) 1 1 lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token] lazyLexBuf handle state eof size = do case unP (lexer False return) state of POk state' t -> do -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ()) if atEnd (buffer state') && not eof -- if this token reached the end of the buffer, and we haven't -- necessarily read up to the end of the file, then the token might -- be truncated, so read some more of the file and lex it again. then getMore handle state size else case unLoc t of ITeof -> return [t] _other -> do rest <- lazyLexBuf handle state' eof size return (t : rest) _ | not eof -> getMore handle state size | otherwise -> return [cL (RealSrcSpan (last_loc state)) ITeof] -- parser assumes an ITeof sentinel at the end getMore :: Handle -> PState -> Int -> IO [Located Token] getMore handle state size = do -- pprTrace "getMore" (text (show (buffer state))) (return ()) let new_size = size * 2 -- double the buffer size each time we read a new block. This -- counteracts the quadratic slowdown we otherwise get for very -- large module names (#5981) nextbuf <- hGetStringBufferBlock handle new_size if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do newbuf <- appendStringBuffers (buffer state) nextbuf unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token] getToks dflags filename buf = lexAll (pragState dflags buf loc) where loc = mkRealSrcLoc (mkFastString filename) 1 1 lexAll state = case unP (lexer False return) state of POk _ t@(dL->L _ ITeof) -> [t] POk state' t -> t : lexAll state' _ -> [cL (RealSrcSpan (last_loc state)) ITeof] -- | Parse OPTIONS and LANGUAGE pragmas of the source file. -- -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) getOptions :: DynFlags -> StringBuffer -- ^ Input Buffer -> FilePath -- ^ Source filename. Used for location info. -> [Located String] -- ^ Parsed options. getOptions dflags buf filename = getOptions' dflags (getToks dflags filename buf) -- The token parser is written manually because Happy can't -- return a partial result when it encounters a lexer error. -- We want to extract options before the buffer is passed through -- CPP, so we can't use the same trick as 'getImports'. getOptions' :: DynFlags -> [Located Token] -- Input buffer -> [Located String] -- Options. getOptions' dflags toks = parseToks toks where parseToks (open:close:xs) | IToptions_prag str <- unLoc open , ITclose_prag <- unLoc close = case toArgs str of Left _err -> optionsParseError str dflags $ -- #15053 combineSrcSpans (getLoc open) (getLoc close) Right args -> map (cL (getLoc open)) args ++ parseToks xs parseToks (open:close:xs) | ITinclude_prag str <- unLoc open , ITclose_prag <- unLoc close = map (cL (getLoc open)) ["-#include",removeSpaces str] ++ parseToks xs parseToks (open:close:xs) | ITdocOptions str <- unLoc open , ITclose_prag <- unLoc close = map (cL (getLoc open)) ["-haddock-opts", removeSpaces str] ++ parseToks xs parseToks (open:xs) | ITlanguage_prag <- unLoc open = parseLanguage xs parseToks (comment:xs) -- Skip over comments | isComment (unLoc comment) = parseToks xs parseToks _ = [] parseLanguage ((dL->L loc (ITconid fs)):rest) = checkExtension dflags (cL loc fs) : case rest of (dL->L _loc ITcomma):more -> parseLanguage more (dL->L _loc ITclose_prag):more -> parseToks more (dL->L loc _):_ -> languagePragParseError dflags loc [] -> panic "getOptions'.parseLanguage(1) went past eof token" parseLanguage (tok:_) = languagePragParseError dflags (getLoc tok) parseLanguage [] = panic "getOptions'.parseLanguage(2) went past eof token" isComment :: Token -> Bool isComment c = case c of (ITlineComment {}) -> True (ITblockComment {}) -> True (ITdocCommentNext {}) -> True (ITdocCommentPrev {}) -> True (ITdocCommentNamed {}) -> True (ITdocSection {}) -> True _ -> False ----------------------------------------------------------------------------- -- | Complain about non-dynamic flags in OPTIONS pragmas. -- -- Throws a 'SourceError' if the input list is non-empty claiming that the -- input flags are unknown. checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m () checkProcessArgsResult dflags flags = when (notNull flags) $ liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags where mkMsg (dL->L loc flag) = mkPlainErrMsg dflags loc $ (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag) ----------------------------------------------------------------------------- checkExtension :: DynFlags -> Located FastString -> Located String checkExtension dflags (dL->L l ext) -- Checks if a given extension is valid, and if so returns -- its corresponding flag. Otherwise it throws an exception. = if ext' `elem` supported then cL l ("-X"++ext') else unsupportedExtnError dflags l ext' where ext' = unpackFS ext supported = supportedLanguagesAndExtensions $ platformMini $ targetPlatform dflags languagePragParseError :: DynFlags -> SrcSpan -> a languagePragParseError dflags loc = throwErr dflags loc $ vcat [ text "Cannot parse LANGUAGE pragma" , text "Expecting comma-separated list of language options," , text "each starting with a capital letter" , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ] unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a unsupportedExtnError dflags loc unsup = throwErr dflags loc $ text "Unsupported extension: " <> text unsup $$ if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) where supported = supportedLanguagesAndExtensions $ platformMini $ targetPlatform dflags suggestions = fuzzyMatch unsup supported optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages optionsErrorMsgs dflags unhandled_flags flags_lines _filename = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) where unhandled_flags_lines :: [Located String] unhandled_flags_lines = [ cL l f | f <- unhandled_flags , (dL->L l f') <- flags_lines , f == f' ] mkMsg (dL->L flagSpan flag) = ErrUtils.mkPlainErrMsg dflags flagSpan $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag optionsParseError :: String -> DynFlags -> SrcSpan -> a -- #15053 optionsParseError str dflags loc = throwErr dflags loc $ vcat [ text "Error while parsing OPTIONS_GHC pragma." , text "Expecting whitespace-separated list of GHC options." , text " E.g. {-# OPTIONS_GHC -Wall -O2 #-}" , text ("Input was: " ++ show str) ] throwErr :: DynFlags -> SrcSpan -> SDoc -> a -- #15053 throwErr dflags loc doc = throw $ mkSrcErr $ unitBag $ mkPlainErrMsg dflags loc doc ghc-lib-parser-8.10.2.20200808/compiler/main/Hooks.hs0000644000000000000000000000676513713635745017702 0ustar0000000000000000-- \section[Hooks]{Low level API hooks} -- NB: this module is SOURCE-imported by DynFlags, and should primarily -- refer to *types*, rather than *code* {-# LANGUAGE CPP #-} module Hooks ( Hooks , emptyHooks , lookupHook , getHooked -- the hooks: , dsForeignsHook , tcForeignImportsHook , tcForeignExportsHook , hscFrontendHook , hscCompileCoreExprHook , ghcPrimIfaceHook , runPhaseHook , runMetaHook , linkHook , runRnSpliceHook , getValueSafelyHook , createIservProcessHook ) where import GhcPrelude import DynFlags import PipelineMonad import HscTypes import GHC.Hs.Decls import GHC.Hs.Binds import GHC.Hs.Expr import OrdList import TcRnTypes import Bag import RdrName import Name import Id import CoreSyn import GHCi.RemoteTypes import SrcLoc import Type import System.Process import BasicTypes import GHC.Hs.Extension import Data.Maybe {- ************************************************************************ * * \subsection{Hooks} * * ************************************************************************ -} -- | Hooks can be used by GHC API clients to replace parts of -- the compiler pipeline. If a hook is not installed, GHC -- uses the default built-in behaviour emptyHooks :: Hooks emptyHooks = Hooks { dsForeignsHook = Nothing , tcForeignImportsHook = Nothing , tcForeignExportsHook = Nothing , hscFrontendHook = Nothing , hscCompileCoreExprHook = Nothing , ghcPrimIfaceHook = Nothing , runPhaseHook = Nothing , runMetaHook = Nothing , linkHook = Nothing , runRnSpliceHook = Nothing , getValueSafelyHook = Nothing , createIservProcessHook = Nothing } data Hooks = Hooks { dsForeignsHook :: Maybe ([LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr))) , tcForeignImportsHook :: Maybe ([LForeignDecl GhcRn] -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)) , tcForeignExportsHook :: Maybe ([LForeignDecl GhcRn] -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt)) , hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult) , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue) , ghcPrimIfaceHook :: Maybe ModIface , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)) , runMetaHook :: Maybe (MetaHook TcM) , linkHook :: Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag) , runRnSpliceHook :: Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn)) , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue)) , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle) } getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a getHooked hook def = fmap (lookupHook hook def) getDynFlags lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a lookupHook hook def = fromMaybe def . hook . hooks ghc-lib-parser-8.10.2.20200808/compiler/main/HscTypes.hs0000644000000000000000000040512413713635745020351 0ustar0000000000000000{- (c) The University of Glasgow, 2006 \section[HscTypes]{Types for the per-module compiler} -} {-# LANGUAGE CPP, ScopedTypeVariables #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-} -- | Types for the per-module compiler module HscTypes ( -- * compilation state HscEnv(..), hscEPS, FinderCache, FindResult(..), InstalledFindResult(..), Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId, HscStatus(..), IServ(..), -- * ModuleGraph ModuleGraph, emptyMG, mkModuleGraph, extendMG, mapMG, mgModSummaries, mgElemModule, mgLookupModule, needsTemplateHaskellOrQQ, mgBootModules, -- * Hsc monad Hsc(..), runHsc, mkInteractiveHscEnv, runInteractiveHsc, -- * Information about modules ModDetails(..), emptyModDetails, ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, ImportedMods, ImportedBy(..), importedByUser, ImportedModsVal(..), SptEntry(..), ForeignSrcLang(..), phaseForeignLanguage, ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, ms_home_imps, home_imps, ms_home_allimps, ms_home_srcimps, showModMsg, isBootSummary, msHsFilePath, msHiFilePath, msObjFilePath, SourceModified(..), isTemplateHaskellOrQQNonBoot, -- * Information about the module being compiled -- (re-exported from DriverPhases) HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString, -- * State relating to modules in this package HomePackageTable, HomeModInfo(..), emptyHomePackageTable, lookupHpt, eltsHpt, filterHpt, allHpt, mapHpt, delFromHpt, addToHpt, addListToHpt, lookupHptDirectly, listToHpt, hptCompleteSigs, hptInstances, hptRules, pprHPT, -- * State relating to known packages ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, lookupIfaceByModule, emptyPartialModIface, emptyFullModIface, lookupHptByModule, PackageInstEnv, PackageFamInstEnv, PackageRuleBase, PackageCompleteMatchMap, mkSOName, mkHsSOName, soExt, -- * Metaprogramming MetaRequest(..), MetaResult, -- data constructors not exported to ensure correct response type metaRequestE, metaRequestP, metaRequestT, metaRequestD, metaRequestAW, MetaHook, -- * Annotations prepareAnnotations, -- * Interactive context InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv, extendInteractiveContext, extendInteractiveContextWithIds, substInteractiveContext, setInteractivePrintName, icInteractiveModule, InteractiveImport(..), setInteractivePackage, mkPrintUnqualified, pprModulePrefix, mkQualPackage, mkQualModule, pkgQual, -- * Interfaces ModIface, PartialModIface, ModIface_(..), ModIfaceBackend(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, emptyIfaceWarnCache, mi_boot, mi_fix, mi_semantic_module, mi_free_holes, renameFreeHoles, -- * Fixity FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, -- * TyThings and type environments TyThing(..), tyThingAvailInfo, tyThingTyCon, tyThingDataCon, tyThingConLike, tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyCoVars, implicitTyThings, implicitTyConThings, implicitClassThings, isImplicitTyThing, TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, typeEnvFromEntities, mkTypeEnvWithImplicits, extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, plusTypeEnv, lookupTypeEnv, typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns, typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses, -- * MonadThings MonadThings(..), -- * Information on imports and exports WhetherHasOrphans, IsBootInterface, Usage(..), Dependencies(..), noDependencies, updNameCache, IfaceExport, -- * Warnings Warnings(..), WarningTxt(..), plusWarns, -- * Linker stuff Linkable(..), isObjectLinkable, linkableObjs, Unlinked(..), CompiledByteCode, isObject, nameOfObject, isInterpretable, byteCodeOfObject, -- * Program coverage HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage, -- * Breakpoints ModBreaks (..), emptyModBreaks, -- * Safe Haskell information IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, trustInfoToNum, numToTrustInfo, IsSafeImport, -- * result of the parser HsParsedModule(..), -- * Compilation errors and warnings SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, throwOneError, throwErrors, handleSourceError, handleFlagWarnings, printOrThrowWarnings, -- * COMPLETE signature CompleteMatch(..), CompleteMatchMap, mkCompleteMatchMap, extendCompleteMatchMap ) where #include "GhclibHsVersions.h" import GhcPrelude import ByteCodeTypes import InteractiveEvalTypes ( Resume ) import GHCi.Message ( Pipe ) import GHCi.RemoteTypes import GHC.ForeignSrcLang import UniqFM import GHC.Hs import RdrName import Avail import Module import InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) import FamInstEnv import CoreSyn ( CoreProgram, RuleBase, CoreRule ) import Name import NameEnv import VarSet import Var import Id import IdInfo ( IdDetails(..), RecSelParent(..)) import Type import ApiAnnotation ( ApiAnns ) import Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) import Class import TyCon import CoAxiom import ConLike import DataCon import PatSyn import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule ) import TysWiredIn import Packages hiding ( Version(..) ) import CmdLineParser import DynFlags import LinkerTypes ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) ) import DriverPhases ( Phase, HscSource(..), hscSourceString , isHsBootOrSig, isHsigFile ) import qualified DriverPhases as Phase import BasicTypes import IfaceSyn import Maybes import Outputable import SrcLoc import Unique import UniqDFM import FastString import StringBuffer ( StringBuffer ) import Fingerprint import MonadUtils import Bag import Binary import ErrUtils import NameCache import GHC.Platform import Util import UniqDSet import GHC.Serialized ( Serialized ) import qualified GHC.LanguageExtensions as LangExt import Foreign import Control.Monad ( guard, liftM, ap ) import Data.IORef import Data.Time import Exception import System.FilePath import Control.Concurrent import System.Process ( ProcessHandle ) import Control.DeepSeq -- ----------------------------------------------------------------------------- -- Compilation state -- ----------------------------------------------------------------------------- -- | Status of a compilation to hard-code data HscStatus -- | Nothing to do. = HscNotGeneratingCode ModIface -- | Nothing to do because code already exists. | HscUpToDate ModIface -- | Update boot file result. | HscUpdateBoot ModIface -- | Generate signature file (backpack) | HscUpdateSig ModIface -- | Recompile this module. | HscRecomp { hscs_guts :: CgGuts -- ^ Information for the code generator. , hscs_mod_location :: !ModLocation -- ^ Module info , hscs_partial_iface :: !PartialModIface -- ^ Partial interface , hscs_old_iface_hash :: !(Maybe Fingerprint) -- ^ Old interface hash for this compilation, if an old interface file -- exists. Pass to `hscMaybeWriteIface` when writing the interface to -- avoid updating the existing interface when the interface isn't -- changed. , hscs_iface_dflags :: !DynFlags -- ^ Generate final iface using this DynFlags. -- FIXME (osa): I don't understand why this is necessary, but I spent -- almost two days trying to figure this out and I couldn't .. perhaps -- someone who understands this code better will remove this later. } -- Should HscStatus contain the HomeModInfo? -- All places where we return a status we also return a HomeModInfo. -- ----------------------------------------------------------------------------- -- The Hsc monad: Passing an environment and warning state newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages)) deriving (Functor) instance Applicative Hsc where pure a = Hsc $ \_ w -> return (a, w) (<*>) = ap instance Monad Hsc where Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w case k a of Hsc k' -> k' e w1 instance MonadIO Hsc where liftIO io = Hsc $ \_ w -> do a <- io; return (a, w) instance HasDynFlags Hsc where getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env (Hsc hsc) = do (a, w) <- hsc hsc_env emptyBag printOrThrowWarnings (hsc_dflags hsc_env) w return a mkInteractiveHscEnv :: HscEnv -> HscEnv mkInteractiveHscEnv hsc_env = hsc_env{ hsc_dflags = interactive_dflags } where interactive_dflags = ic_dflags (hsc_IC hsc_env) runInteractiveHsc :: HscEnv -> Hsc a -> IO a -- A variant of runHsc that switches in the DynFlags from the -- InteractiveContext before running the Hsc computation. runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env) -- ----------------------------------------------------------------------------- -- Source Errors -- When the compiler (HscMain) discovers errors, it throws an -- exception in the IO monad. mkSrcErr :: ErrorMessages -> SourceError mkSrcErr = SourceError srcErrorMessages :: SourceError -> ErrorMessages srcErrorMessages (SourceError msgs) = msgs mkApiErr :: DynFlags -> SDoc -> GhcApiError mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) throwErrors :: MonadIO io => ErrorMessages -> io a throwErrors = liftIO . throwIO . mkSrcErr throwOneError :: MonadIO io => ErrMsg -> io a throwOneError = throwErrors . unitBag -- | A source error is an error that is caused by one or more errors in the -- source code. A 'SourceError' is thrown by many functions in the -- compilation pipeline. Inside GHC these errors are merely printed via -- 'log_action', but API clients may treat them differently, for example, -- insert them into a list box. If you want the default behaviour, use the -- idiom: -- -- > handleSourceError printExceptionAndWarnings $ do -- > ... api calls that may fail ... -- -- The 'SourceError's error messages can be accessed via 'srcErrorMessages'. -- This list may be empty if the compiler failed due to @-Werror@ -- ('Opt_WarnIsError'). -- -- See 'printExceptionAndWarnings' for more information on what to take care -- of when writing a custom error handler. newtype SourceError = SourceError ErrorMessages instance Show SourceError where show (SourceError msgs) = unlines . map show . bagToList $ msgs instance Exception SourceError -- | Perform the given action and call the exception handler if the action -- throws a 'SourceError'. See 'SourceError' for more information. handleSourceError :: (ExceptionMonad m) => (SourceError -> m a) -- ^ exception handler -> m a -- ^ action to perform -> m a handleSourceError handler act = gcatch act (\(e :: SourceError) -> handler e) -- | An error thrown if the GHC API is used in an incorrect fashion. newtype GhcApiError = GhcApiError String instance Show GhcApiError where show (GhcApiError msg) = msg instance Exception GhcApiError -- | Given a bag of warnings, turn them into an exception if -- -Werror is enabled, or print them out otherwise. printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () printOrThrowWarnings dflags warns = do let (make_error, warns') = mapAccumBagL (\make_err warn -> case isWarnMsgFatal dflags warn of Nothing -> (make_err, warn) Just err_reason -> (True, warn{ errMsgSeverity = SevError , errMsgReason = ErrReason err_reason })) False warns if make_error then throwIO (mkSrcErr warns') else printBagOfErrors dflags warns handleFlagWarnings :: DynFlags -> [Warn] -> IO () handleFlagWarnings dflags warns = do let warns' = filter (shouldPrintWarning dflags . warnReason) warns -- It would be nicer if warns :: [Located MsgDoc], but that -- has circular import problems. bag = listToBag [ mkPlainWarnMsg dflags loc (text warn) | Warn _ (dL->L loc warn) <- warns' ] printOrThrowWarnings dflags bag -- Given a warn reason, check to see if it's associated -W opt is enabled shouldPrintWarning :: DynFlags -> CmdLineParser.WarnReason -> Bool shouldPrintWarning dflags ReasonDeprecatedFlag = wopt Opt_WarnDeprecatedFlags dflags shouldPrintWarning dflags ReasonUnrecognisedFlag = wopt Opt_WarnUnrecognisedWarningFlags dflags shouldPrintWarning _ _ = True {- ************************************************************************ * * \subsection{HscEnv} * * ************************************************************************ -} -- | HscEnv is like 'Session', except that some of the fields are immutable. -- An HscEnv is used to compile a single module from plain Haskell source -- code (after preprocessing) to either C, assembly or C--. It's also used -- to store the dynamic linker state to allow for multiple linkers in the -- same address space. -- Things like the module graph don't change during a single compilation. -- -- Historical note: \"hsc\" used to be the name of the compiler binary, -- when there was a separate driver and compiler. To compile a single -- module, the driver would invoke hsc on the source code... so nowadays -- we think of hsc as the layer of the compiler that deals with compiling -- a single module. data HscEnv = HscEnv { hsc_dflags :: DynFlags, -- ^ The dynamic flag settings hsc_targets :: [Target], -- ^ The targets (or roots) of the current session hsc_mod_graph :: ModuleGraph, -- ^ The module graph of the current session hsc_IC :: InteractiveContext, -- ^ The context for evaluating interactive statements hsc_HPT :: HomePackageTable, -- ^ The home package table describes already-compiled -- home-package modules, /excluding/ the module we -- are compiling right now. -- (In one-shot mode the current module is the only -- home-package module, so hsc_HPT is empty. All other -- modules count as \"external-package\" modules. -- However, even in GHCi mode, hi-boot interfaces are -- demand-loaded into the external-package table.) -- -- 'hsc_HPT' is not mutable because we only demand-load -- external packages; the home package is eagerly -- loaded, module by module, by the compilation manager. -- -- The HPT may contain modules compiled earlier by @--make@ -- but not actually below the current module in the dependency -- graph. -- -- (This changes a previous invariant: changed Jan 05.) hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState), -- ^ Information about the currently loaded external packages. -- This is mutable because packages will be demand-loaded during -- a compilation run as required. hsc_NC :: {-# UNPACK #-} !(IORef NameCache), -- ^ As with 'hsc_EPS', this is side-effected by compiling to -- reflect sucking in interface files. They cache the state of -- external interface files, in effect. hsc_FC :: {-# UNPACK #-} !(IORef FinderCache), -- ^ The cached result of performing finding in the file system hsc_type_env_var :: Maybe (Module, IORef TypeEnv) -- ^ Used for one-shot compilation only, to initialise -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for -- 'TcRnTypes.TcGblEnv'. See also Note [hsc_type_env_var hack] , hsc_iserv :: MVar (Maybe IServ) -- ^ interactive server process. Created the first -- time it is needed. , hsc_dynLinker :: DynLinker -- ^ dynamic linker. } -- Note [hsc_type_env_var hack] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- hsc_type_env_var is used to initialize tcg_type_env_var, and -- eventually it is the mutable variable that is queried from -- if_rec_types to get a TypeEnv. So, clearly, it's something -- related to knot-tying (see Note [Tying the knot]). -- hsc_type_env_var is used in two places: initTcRn (where -- it initializes tcg_type_env_var) and initIfaceCheck -- (where it initializes if_rec_types). -- -- But why do we need a way to feed a mutable variable in? Why -- can't we just initialize tcg_type_env_var when we start -- typechecking? The problem is we need to knot-tie the -- EPS, and we may start adding things to the EPS before type -- checking starts. -- -- Here is a concrete example. Suppose we are running -- "ghc -c A.hs", and we have this file system state: -- -- A.hs-boot A.hi-boot **up to date** -- B.hs B.hi **up to date** -- A.hs A.hi **stale** -- -- The first thing we do is run checkOldIface on A.hi. -- checkOldIface will call loadInterface on B.hi so it can -- get its hands on the fingerprints, to find out if A.hi -- needs recompilation. But loadInterface also populates -- the EPS! And so if compilation turns out to be necessary, -- as it is in this case, the thunks we put into the EPS for -- B.hi need to have the correct if_rec_types mutable variable -- to query. -- -- If the mutable variable is only allocated WHEN we start -- typechecking, then that's too late: we can't get the -- information to the thunks. So we need to pre-commit -- to a type variable in 'hscIncrementalCompile' BEFORE we -- check the old interface. -- -- This is all a massive hack because arguably checkOldIface -- should not populate the EPS. But that's a refactor for -- another day. data IServ = IServ { iservPipe :: Pipe , iservProcess :: ProcessHandle , iservLookupSymbolCache :: IORef (UniqFM (Ptr ())) , iservPendingFrees :: [HValueRef] } -- | Retrieve the ExternalPackageState cache. hscEPS :: HscEnv -> IO ExternalPackageState hscEPS hsc_env = readIORef (hsc_EPS hsc_env) -- | A compilation target. -- -- A target may be supplied with the actual text of the -- module. If so, use this instead of the file contents (this -- is for use in an IDE where the file hasn't been saved by -- the user yet). data Target = Target { targetId :: TargetId, -- ^ module or filename targetAllowObjCode :: Bool, -- ^ object code allowed? targetContents :: Maybe (InputFileBuffer, UTCTime) -- ^ Optional in-memory buffer containing the source code GHC should -- use for this target instead of reading it from disk. -- -- Since GHC version 8.10 modules which require preprocessors such as -- Literate Haskell or CPP to run are also supported. -- -- If a corresponding source file does not exist on disk this will -- result in a 'SourceError' exception if @targetId = TargetModule _@ -- is used. However together with @targetId = TargetFile _@ GHC will -- not complain about the file missing. } data TargetId = TargetModule ModuleName -- ^ A module name: search for the file | TargetFile FilePath (Maybe Phase) -- ^ A filename: preprocess & parse it to find the module name. -- If specified, the Phase indicates how to compile this file -- (which phase to start from). Nothing indicates the starting phase -- should be determined from the suffix of the filename. deriving Eq type InputFileBuffer = StringBuffer pprTarget :: Target -> SDoc pprTarget (Target id obj _) = (if obj then char '*' else empty) <> pprTargetId id instance Outputable Target where ppr = pprTarget pprTargetId :: TargetId -> SDoc pprTargetId (TargetModule m) = ppr m pprTargetId (TargetFile f _) = text f instance Outputable TargetId where ppr = pprTargetId {- ************************************************************************ * * \subsection{Package and Module Tables} * * ************************************************************************ -} -- | Helps us find information about modules in the home package type HomePackageTable = DModuleNameEnv HomeModInfo -- Domain = modules in the home package that have been fully compiled -- "home" unit id cached here for convenience -- | Helps us find information about modules in the imported packages type PackageIfaceTable = ModuleEnv ModIface -- Domain = modules in the imported packages -- | Constructs an empty HomePackageTable emptyHomePackageTable :: HomePackageTable emptyHomePackageTable = emptyUDFM -- | Constructs an empty PackageIfaceTable emptyPackageIfaceTable :: PackageIfaceTable emptyPackageIfaceTable = emptyModuleEnv pprHPT :: HomePackageTable -> SDoc -- A bit arbitrary for now pprHPT hpt = pprUDFM hpt $ \hms -> vcat [ hang (ppr (mi_module (hm_iface hm))) 2 (ppr (md_types (hm_details hm))) | hm <- hms ] lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo lookupHpt = lookupUDFM lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo lookupHptDirectly = lookupUDFM_Directly eltsHpt :: HomePackageTable -> [HomeModInfo] eltsHpt = eltsUDFM filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable filterHpt = filterUDFM allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool allHpt = allUDFM mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable mapHpt = mapUDFM delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable delFromHpt = delFromUDFM addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable addToHpt = addToUDFM addListToHpt :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable addListToHpt = addListToUDFM listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable listToHpt = listToUDFM lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo -- The HPT is indexed by ModuleName, not Module, -- we must check for a hit on the right Module lookupHptByModule hpt mod = case lookupHpt hpt (moduleName mod) of Just hm | mi_module (hm_iface hm) == mod -> Just hm _otherwise -> Nothing -- | Information about modules in the package being compiled data HomeModInfo = HomeModInfo { hm_iface :: !ModIface, -- ^ The basic loaded interface file: every loaded module has one of -- these, even if it is imported from another package hm_details :: !ModDetails, -- ^ Extra information that has been created from the 'ModIface' for -- the module, typically during typechecking hm_linkable :: !(Maybe Linkable) -- ^ The actual artifact we would like to link to access things in -- this module. -- -- 'hm_linkable' might be Nothing: -- -- 1. If this is an .hs-boot module -- -- 2. Temporarily during compilation if we pruned away -- the old linkable because it was out of date. -- -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields -- in the 'HomePackageTable' will be @Just@. -- -- When re-linking a module ('HscMain.HscNoRecomp'), we construct the -- 'HomeModInfo' by building a new 'ModDetails' from the old -- 'ModIface' (only). } -- | Find the 'ModIface' for a 'Module', searching in both the loaded home -- and external package module information lookupIfaceByModule :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface lookupIfaceByModule hpt pit mod = case lookupHptByModule hpt mod of Just hm -> Just (hm_iface hm) Nothing -> lookupModuleEnv pit mod -- If the module does come from the home package, why do we look in the PIT as well? -- (a) In OneShot mode, even home-package modules accumulate in the PIT -- (b) Even in Batch (--make) mode, there is *one* case where a home-package -- module is in the PIT, namely GHC.Prim when compiling the base package. -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package -- of its own, but it doesn't seem worth the bother. hptCompleteSigs :: HscEnv -> [CompleteMatch] hptCompleteSigs = hptAllThings (md_complete_sigs . hm_details) -- | Find all the instance declarations (of classes and families) from -- the Home Package Table filtered by the provided predicate function. -- Used in @tcRnImports@, to select the instances that are in the -- transitive closure of imports from the currently compiled module. hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst]) hptInstances hsc_env want_this_module = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do guard (want_this_module (moduleName (mi_module (hm_iface mod_info)))) let details = hm_details mod_info return (md_insts details, md_fam_insts details) in (concat insts, concat famInsts) -- | Get rules from modules "below" this one (in the dependency sense) hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule] hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False -- | Get annotations from modules "below" this one (in the dependency sense) hptAnns :: HscEnv -> Maybe [(ModuleName, IsBootInterface)] -> [Annotation] hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env)) -- | Get things from modules "below" this one (in the dependency sense) -- C.f Inst.hptInstances hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [(ModuleName, IsBootInterface)] -> [a] hptSomeThingsBelowUs extract include_hi_boot hsc_env deps | isOneShot (ghcMode (hsc_dflags hsc_env)) = [] | otherwise = let hpt = hsc_HPT hsc_env in [ thing | -- Find each non-hi-boot module below me (mod, is_boot_mod) <- deps , include_hi_boot || not is_boot_mod -- unsavoury: when compiling the base package with --make, we -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't -- be in the HPT, because we never compile it; it's in the EPT -- instead. ToDo: clean up, and remove this slightly bogus filter: , mod /= moduleName gHC_PRIM -- Look it up in the HPT , let things = case lookupHpt hpt mod of Just info -> extract info Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg [] msg = vcat [text "missing module" <+> ppr mod, text "Probable cause: out-of-date interface files"] -- This really shouldn't happen, but see #962 -- And get its dfuns , thing <- things ] {- ************************************************************************ * * \subsection{Metaprogramming} * * ************************************************************************ -} -- | The supported metaprogramming result types data MetaRequest = MetaE (LHsExpr GhcPs -> MetaResult) | MetaP (LPat GhcPs -> MetaResult) | MetaT (LHsType GhcPs -> MetaResult) | MetaD ([LHsDecl GhcPs] -> MetaResult) | MetaAW (Serialized -> MetaResult) -- | data constructors not exported to ensure correct result type data MetaResult = MetaResE { unMetaResE :: LHsExpr GhcPs } | MetaResP { unMetaResP :: LPat GhcPs } | MetaResT { unMetaResT :: LHsType GhcPs } | MetaResD { unMetaResD :: [LHsDecl GhcPs] } | MetaResAW { unMetaResAW :: Serialized } type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs) metaRequestE h = fmap unMetaResE . h (MetaE MetaResE) metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs) metaRequestP h = fmap unMetaResP . h (MetaP MetaResP) metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs) metaRequestT h = fmap unMetaResT . h (MetaT MetaResT) metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs] metaRequestD h = fmap unMetaResD . h (MetaD MetaResD) metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW) {- ************************************************************************ * * \subsection{Dealing with Annotations} * * ************************************************************************ -} -- | Deal with gathering annotations in from all possible places -- and combining them into a single 'AnnEnv' prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv prepareAnnotations hsc_env mb_guts = do eps <- hscEPS hsc_env let -- Extract annotations from the module being compiled if supplied one mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts -- Extract dependencies of the module if we are supplied one, -- otherwise load annotations from all home package table -- entries regardless of dependency ordering. home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts other_pkg_anns = eps_ann_env eps ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns, Just home_pkg_anns, Just other_pkg_anns] return ann_env {- ************************************************************************ * * \subsection{The Finder cache} * * ************************************************************************ -} -- | The 'FinderCache' maps modules to the result of -- searching for that module. It records the results of searching for -- modules along the search path. On @:load@, we flush the entire -- contents of this cache. -- type FinderCache = InstalledModuleEnv InstalledFindResult data InstalledFindResult = InstalledFound ModLocation InstalledModule | InstalledNoPackage InstalledUnitId | InstalledNotFound [FilePath] (Maybe InstalledUnitId) -- | The result of searching for an imported module. -- -- NB: FindResult manages both user source-import lookups -- (which can result in 'Module') as well as direct imports -- for interfaces (which always result in 'InstalledModule'). data FindResult = Found ModLocation Module -- ^ The module was found | NoPackage UnitId -- ^ The requested package was not found | FoundMultiple [(Module, ModuleOrigin)] -- ^ _Error_: both in multiple packages -- | Not found | NotFound { fr_paths :: [FilePath] -- Places where I looked , fr_pkg :: Maybe UnitId -- Just p => module is in this package's -- manifest, but couldn't find -- the .hi file , fr_mods_hidden :: [UnitId] -- Module is in these packages, -- but the *module* is hidden , fr_pkgs_hidden :: [UnitId] -- Module is in these packages, -- but the *package* is hidden -- Modules are in these packages, but it is unusable , fr_unusables :: [(UnitId, UnusablePackageReason)] , fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules } {- ************************************************************************ * * \subsection{Symbol tables and Module details} * * ************************************************************************ -} {- Note [Interface file stages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Interface files have two possible stages. * A partial stage built from the result of the core pipeline. * A fully instantiated form. Which also includes fingerprints and potentially information provided by backends. We can build a full interface file two ways: * Directly from a partial one: Then we omit backend information and mostly compute fingerprints. * From a partial one + information produced by a backend. Then we store the provided information and fingerprint both. -} type PartialModIface = ModIface_ 'ModIfaceCore type ModIface = ModIface_ 'ModIfaceFinal -- | Extends a PartialModIface with information which is either: -- * Computed after codegen -- * Or computed just before writing the iface to disk. (Hashes) -- In order to fully instantiate it. data ModIfaceBackend = ModIfaceBackend { mi_iface_hash :: !Fingerprint -- ^ Hash of the whole interface , mi_mod_hash :: !Fingerprint -- ^ Hash of the ABI only , mi_flag_hash :: !Fingerprint -- ^ Hash of the important flags used when compiling the module, excluding -- optimisation flags , mi_opt_hash :: !Fingerprint -- ^ Hash of optimisation flags , mi_hpc_hash :: !Fingerprint -- ^ Hash of hpc flags , mi_plugin_hash :: !Fingerprint -- ^ Hash of plugins , mi_orphan :: !WhetherHasOrphans -- ^ Whether this module has orphans , mi_finsts :: !WhetherHasFamInst -- ^ Whether this module has family instances. See Note [The type family -- instance consistency story]. , mi_exp_hash :: !Fingerprint -- ^ Hash of export list , mi_orphan_hash :: !Fingerprint -- ^ Hash for orphan rules, class and family instances combined -- Cached environments for easy lookup. These are computed (lazily) from -- other fields and are not put into the interface file. -- Not really produced by the backend but there is no need to create them -- any earlier. , mi_warn_fn :: !(OccName -> Maybe WarningTxt) -- ^ Cached lookup for 'mi_warns' , mi_fix_fn :: !(OccName -> Maybe Fixity) -- ^ Cached lookup for 'mi_fixities' , mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint)) -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that -- the thing isn't in decls. It's useful to know that when seeing if we are -- up to date wrt. the old interface. The 'OccName' is the parent of the -- name, if it has one. } data ModIfacePhase = ModIfaceCore -- ^ Partial interface built based on output of core pipeline. | ModIfaceFinal -- | Selects a IfaceDecl representation. -- For fully instantiated interfaces we also maintain -- a fingerprint, which is used for recompilation checks. type family IfaceDeclExts (phase :: ModIfacePhase) where IfaceDeclExts 'ModIfaceCore = IfaceDecl IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl) type family IfaceBackendExts (phase :: ModIfacePhase) where IfaceBackendExts 'ModIfaceCore = () IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend -- | A 'ModIface' plus a 'ModDetails' summarises everything we know -- about a compiled module. The 'ModIface' is the stuff *before* linking, -- and can be written out to an interface file. The 'ModDetails is after -- linking and can be completely recovered from just the 'ModIface'. -- -- When we read an interface file, we also construct a 'ModIface' from it, -- except that we explicitly make the 'mi_decls' and a few other fields empty; -- as when reading we consolidate the declarations etc. into a number of indexed -- maps and environments in the 'ExternalPackageState'. data ModIface_ (phase :: ModIfacePhase) = ModIface { mi_module :: !Module, -- ^ Name of the module we are for mi_sig_of :: !(Maybe Module), -- ^ Are we a sig of another mod? mi_hsc_src :: !HscSource, -- ^ Boot? Signature? mi_deps :: Dependencies, -- ^ The dependencies of the module. This is -- consulted for directly-imported modules, but not -- for anything else (hence lazy) mi_usages :: [Usage], -- ^ Usages; kept sorted so that it's easy to decide -- whether to write a new iface file (changing usages -- doesn't affect the hash of this module) -- NOT STRICT! we read this field lazily from the interface file -- It is *only* consulted by the recompilation checker mi_exports :: ![IfaceExport], -- ^ Exports -- Kept sorted by (mod,occ), to make version comparisons easier -- Records the modules that are the declaration points for things -- exported by this module, and the 'OccName's of those things mi_used_th :: !Bool, -- ^ Module required TH splices when it was compiled. -- This disables recompilation avoidance (see #481). mi_fixities :: [(OccName,Fixity)], -- ^ Fixities -- NOT STRICT! we read this field lazily from the interface file mi_warns :: Warnings, -- ^ Warnings -- NOT STRICT! we read this field lazily from the interface file mi_anns :: [IfaceAnnotation], -- ^ Annotations -- NOT STRICT! we read this field lazily from the interface file mi_decls :: [IfaceDeclExts phase], -- ^ Type, class and variable declarations -- The hash of an Id changes if its fixity or deprecations change -- (as well as its type of course) -- Ditto data constructors, class operations, except that -- the hash of the parent class/tycon changes mi_globals :: !(Maybe GlobalRdrEnv), -- ^ Binds all the things defined at the top level in -- the /original source/ code for this module. which -- is NOT the same as mi_exports, nor mi_decls (which -- may contains declarations for things not actually -- defined by the user). Used for GHCi and for inspecting -- the contents of modules via the GHC API only. -- -- (We need the source file to figure out the -- top-level environment, if we didn't compile this module -- from source then this field contains @Nothing@). -- -- Strictly speaking this field should live in the -- 'HomeModInfo', but that leads to more plumbing. -- Instance declarations and rules mi_insts :: [IfaceClsInst], -- ^ Sorted class instance mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances mi_rules :: [IfaceRule], -- ^ Sorted rules mi_hpc :: !AnyHpcUsage, -- ^ True if this program uses Hpc at any point in the program. mi_trust :: !IfaceTrustInfo, -- ^ Safe Haskell Trust information for this module. mi_trust_pkg :: !Bool, -- ^ Do we require the package this module resides in be trusted -- to trust this module? This is used for the situation where a -- module is Safe (so doesn't require the package be trusted -- itself) but imports some trustworthy modules from its own -- package (which does require its own package be trusted). -- See Note [RnNames . Trust Own Package] mi_complete_sigs :: [IfaceCompleteMatch], mi_doc_hdr :: Maybe HsDocString, -- ^ Module header. mi_decl_docs :: DeclDocMap, -- ^ Docs on declarations. mi_arg_docs :: ArgDocMap, -- ^ Docs on arguments. mi_final_exts :: !(IfaceBackendExts phase) -- ^ Either `()` or `ModIfaceBackend` for -- a fully instantiated interface. } -- | Old-style accessor for whether or not the ModIface came from an hs-boot -- file. mi_boot :: ModIface -> Bool mi_boot iface = mi_hsc_src iface == HsBootFile -- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be -- found, 'defaultFixity' is returned instead. mi_fix :: ModIface -> OccName -> Fixity mi_fix iface name = mi_fix_fn (mi_final_exts iface) name `orElse` defaultFixity -- | The semantic module for this interface; e.g., if it's a interface -- for a signature, if 'mi_module' is @p[A=]:A@, 'mi_semantic_module' -- will be @@. mi_semantic_module :: ModIface_ a -> Module mi_semantic_module iface = case mi_sig_of iface of Nothing -> mi_module iface Just mod -> mod -- | The "precise" free holes, e.g., the signatures that this -- 'ModIface' depends on. mi_free_holes :: ModIface -> UniqDSet ModuleName mi_free_holes iface = case splitModuleInsts (mi_module iface) of (_, Just indef) -- A mini-hack: we rely on the fact that 'renameFreeHoles' -- drops things that aren't holes. -> renameFreeHoles (mkUniqDSet cands) (indefUnitIdInsts (indefModuleUnitId indef)) _ -> emptyUniqDSet where cands = map fst (dep_mods (mi_deps iface)) -- | Given a set of free holes, and a unit identifier, rename -- the free holes according to the instantiation of the unit -- identifier. For example, if we have A and B free, and -- our unit identity is @p[A=,B=impl:B]@, the renamed free -- holes are just C. renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName renameFreeHoles fhs insts = unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs)) where hmap = listToUFM insts lookup_impl mod_name | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod -- It wasn't actually a hole | otherwise = emptyUniqDSet instance Binary ModIface where put_ bh (ModIface { mi_module = mod, mi_sig_of = sig_of, mi_hsc_src = hsc_src, mi_deps = deps, mi_usages = usages, mi_exports = exports, mi_used_th = used_th, mi_fixities = fixities, mi_warns = warns, mi_anns = anns, mi_decls = decls, mi_insts = insts, mi_fam_insts = fam_insts, mi_rules = rules, mi_hpc = hpc_info, mi_trust = trust, mi_trust_pkg = trust_pkg, mi_complete_sigs = complete_sigs, mi_doc_hdr = doc_hdr, mi_decl_docs = decl_docs, mi_arg_docs = arg_docs, mi_final_exts = ModIfaceBackend { mi_iface_hash = iface_hash, mi_mod_hash = mod_hash, mi_flag_hash = flag_hash, mi_opt_hash = opt_hash, mi_hpc_hash = hpc_hash, mi_plugin_hash = plugin_hash, mi_orphan = orphan, mi_finsts = hasFamInsts, mi_exp_hash = exp_hash, mi_orphan_hash = orphan_hash }}) = do put_ bh mod put_ bh sig_of put_ bh hsc_src put_ bh iface_hash put_ bh mod_hash put_ bh flag_hash put_ bh opt_hash put_ bh hpc_hash put_ bh plugin_hash put_ bh orphan put_ bh hasFamInsts lazyPut bh deps lazyPut bh usages put_ bh exports put_ bh exp_hash put_ bh used_th put_ bh fixities lazyPut bh warns lazyPut bh anns put_ bh decls put_ bh insts put_ bh fam_insts lazyPut bh rules put_ bh orphan_hash put_ bh hpc_info put_ bh trust put_ bh trust_pkg put_ bh complete_sigs lazyPut bh doc_hdr lazyPut bh decl_docs lazyPut bh arg_docs get bh = do mod <- get bh sig_of <- get bh hsc_src <- get bh iface_hash <- get bh mod_hash <- get bh flag_hash <- get bh opt_hash <- get bh hpc_hash <- get bh plugin_hash <- get bh orphan <- get bh hasFamInsts <- get bh deps <- lazyGet bh usages <- {-# SCC "bin_usages" #-} lazyGet bh exports <- {-# SCC "bin_exports" #-} get bh exp_hash <- get bh used_th <- get bh fixities <- {-# SCC "bin_fixities" #-} get bh warns <- {-# SCC "bin_warns" #-} lazyGet bh anns <- {-# SCC "bin_anns" #-} lazyGet bh decls <- {-# SCC "bin_tycldecls" #-} get bh insts <- {-# SCC "bin_insts" #-} get bh fam_insts <- {-# SCC "bin_fam_insts" #-} get bh rules <- {-# SCC "bin_rules" #-} lazyGet bh orphan_hash <- get bh hpc_info <- get bh trust <- get bh trust_pkg <- get bh complete_sigs <- get bh doc_hdr <- lazyGet bh decl_docs <- lazyGet bh arg_docs <- lazyGet bh return (ModIface { mi_module = mod, mi_sig_of = sig_of, mi_hsc_src = hsc_src, mi_deps = deps, mi_usages = usages, mi_exports = exports, mi_used_th = used_th, mi_anns = anns, mi_fixities = fixities, mi_warns = warns, mi_decls = decls, mi_globals = Nothing, mi_insts = insts, mi_fam_insts = fam_insts, mi_rules = rules, mi_hpc = hpc_info, mi_trust = trust, mi_trust_pkg = trust_pkg, -- And build the cached values mi_complete_sigs = complete_sigs, mi_doc_hdr = doc_hdr, mi_decl_docs = decl_docs, mi_arg_docs = arg_docs, mi_final_exts = ModIfaceBackend { mi_iface_hash = iface_hash, mi_mod_hash = mod_hash, mi_flag_hash = flag_hash, mi_opt_hash = opt_hash, mi_hpc_hash = hpc_hash, mi_plugin_hash = plugin_hash, mi_orphan = orphan, mi_finsts = hasFamInsts, mi_exp_hash = exp_hash, mi_orphan_hash = orphan_hash, mi_warn_fn = mkIfaceWarnCache warns, mi_fix_fn = mkIfaceFixCache fixities, mi_hash_fn = mkIfaceHashCache decls }}) -- | The original names declared of a certain module that are exported type IfaceExport = AvailInfo emptyPartialModIface :: Module -> PartialModIface emptyPartialModIface mod = ModIface { mi_module = mod, mi_sig_of = Nothing, mi_hsc_src = HsSrcFile, mi_deps = noDependencies, mi_usages = [], mi_exports = [], mi_used_th = False, mi_fixities = [], mi_warns = NoWarnings, mi_anns = [], mi_insts = [], mi_fam_insts = [], mi_rules = [], mi_decls = [], mi_globals = Nothing, mi_hpc = False, mi_trust = noIfaceTrustInfo, mi_trust_pkg = False, mi_complete_sigs = [], mi_doc_hdr = Nothing, mi_decl_docs = emptyDeclDocMap, mi_arg_docs = emptyArgDocMap, mi_final_exts = () } emptyFullModIface :: Module -> ModIface emptyFullModIface mod = (emptyPartialModIface mod) { mi_decls = [] , mi_final_exts = ModIfaceBackend { mi_iface_hash = fingerprint0, mi_mod_hash = fingerprint0, mi_flag_hash = fingerprint0, mi_opt_hash = fingerprint0, mi_hpc_hash = fingerprint0, mi_plugin_hash = fingerprint0, mi_orphan = False, mi_finsts = False, mi_exp_hash = fingerprint0, mi_orphan_hash = fingerprint0, mi_warn_fn = emptyIfaceWarnCache, mi_fix_fn = emptyIfaceFixCache, mi_hash_fn = emptyIfaceHashCache } } -- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] -> (OccName -> Maybe (OccName, Fingerprint)) mkIfaceHashCache pairs = \occ -> lookupOccEnv env occ where env = foldl' add_decl emptyOccEnv pairs add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d) where add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash) emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) emptyIfaceHashCache _occ = Nothing -- | The 'ModDetails' is essentially a cache for information in the 'ModIface' -- for home modules only. Information relating to packages will be loaded into -- global environments in 'ExternalPackageState'. data ModDetails = ModDetails { -- The next two fields are created by the typechecker md_exports :: [AvailInfo], md_types :: !TypeEnv, -- ^ Local type environment for this particular module -- Includes Ids, TyCons, PatSyns md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module md_fam_insts :: ![FamInst], md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules md_anns :: ![Annotation], -- ^ Annotations present in this module: currently -- they only annotate things also declared in this module md_complete_sigs :: [CompleteMatch] -- ^ Complete match pragmas for this module } -- | Constructs an empty ModDetails emptyModDetails :: ModDetails emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_exports = [], md_insts = [], md_rules = [], md_fam_insts = [], md_anns = [], md_complete_sigs = [] } -- | Records the modules directly imported by a module for extracting e.g. -- usage information, and also to give better error message type ImportedMods = ModuleEnv [ImportedBy] -- | If a module was "imported" by the user, we associate it with -- more detailed usage information 'ImportedModsVal'; a module -- imported by the system only gets used for usage information. data ImportedBy = ImportedByUser ImportedModsVal | ImportedBySystem importedByUser :: [ImportedBy] -> [ImportedModsVal] importedByUser (ImportedByUser imv : bys) = imv : importedByUser bys importedByUser (ImportedBySystem : bys) = importedByUser bys importedByUser [] = [] data ImportedModsVal = ImportedModsVal { imv_name :: ModuleName, -- ^ The name the module is imported with imv_span :: SrcSpan, -- ^ the source span of the whole import imv_is_safe :: IsSafeImport, -- ^ whether this is a safe import imv_is_hiding :: Bool, -- ^ whether this is an "hiding" import imv_all_exports :: !GlobalRdrEnv, -- ^ all the things the module could provide -- NB. BangPattern here: otherwise this leaks. (#15111) imv_qualified :: Bool -- ^ whether this is a qualified import } -- | A ModGuts is carried through the compiler, accumulating stuff as it goes -- There is only one ModGuts at any time, the one for the module -- being compiled right now. Once it is compiled, a 'ModIface' and -- 'ModDetails' are extracted and the ModGuts is discarded. data ModGuts = ModGuts { mg_module :: !Module, -- ^ Module being compiled mg_hsc_src :: HscSource, -- ^ Whether it's an hs-boot module mg_loc :: SrcSpan, -- ^ For error messages from inner passes mg_exports :: ![AvailInfo], -- ^ What it exports mg_deps :: !Dependencies, -- ^ What it depends on, directly or -- otherwise mg_usages :: ![Usage], -- ^ What was used? Used for interfaces. mg_used_th :: !Bool, -- ^ Did we run a TH splice? mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment -- These fields all describe the things **declared in this module** mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module. -- Used for creating interface files. mg_tcs :: ![TyCon], -- ^ TyCons declared in this module -- (includes TyCons for classes) mg_insts :: ![ClsInst], -- ^ Class instances declared in this module mg_fam_insts :: ![FamInst], -- ^ Family instances declared in this module mg_patsyns :: ![PatSyn], -- ^ Pattern synonyms declared in this module mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains -- See Note [Overall plumbing for rules] in Rules.hs mg_binds :: !CoreProgram, -- ^ Bindings for this module mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module mg_foreign_files :: ![(ForeignSrcLang, FilePath)], -- ^ Files to be compiled with the C compiler mg_warns :: !Warnings, -- ^ Warnings declared in the module mg_anns :: [Annotation], -- ^ Annotations declared in this module mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module -- The next two fields are unusual, because they give instance -- environments for *all* modules in the home package, including -- this module, rather than for *just* this module. -- Reason: when looking up an instance we don't want to have to -- look at each module in the home package in turn mg_inst_env :: InstEnv, -- ^ Class instance environment for -- /home-package/ modules (including this -- one); c.f. 'tcg_inst_env' mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance environment for -- /home-package/ modules (including this -- one); c.f. 'tcg_fam_inst_env' mg_safe_haskell :: SafeHaskellMode, -- ^ Safe Haskell mode mg_trust_pkg :: Bool, -- ^ Do we need to trust our -- own package for Safe Haskell? -- See Note [RnNames . Trust Own Package] mg_doc_hdr :: !(Maybe HsDocString), -- ^ Module header. mg_decl_docs :: !DeclDocMap, -- ^ Docs on declarations. mg_arg_docs :: !ArgDocMap -- ^ Docs on arguments. } -- The ModGuts takes on several slightly different forms: -- -- After simplification, the following fields change slightly: -- mg_rules Orphan rules only (local ones now attached to binds) -- mg_binds With rules attached --------------------------------------------------------- -- The Tidy pass forks the information about this module: -- * one lot goes to interface file generation (ModIface) -- and later compilations (ModDetails) -- * the other lot goes to code generation (CgGuts) -- | A restricted form of 'ModGuts' for code generation purposes data CgGuts = CgGuts { cg_module :: !Module, -- ^ Module being compiled cg_tycons :: [TyCon], -- ^ Algebraic data types (including ones that started -- life as classes); generate constructors and info -- tables. Includes newtypes, just for the benefit of -- External Core cg_binds :: CoreProgram, -- ^ The tidied main bindings, including -- previously-implicit bindings for record and class -- selectors, and data constructor wrappers. But *not* -- data constructor workers; reason: we regard them -- as part of the code-gen of tycons cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs cg_foreign_files :: ![(ForeignSrcLang, FilePath)], cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints cg_spt_entries :: [SptEntry] -- ^ Static pointer table entries for static forms defined in -- the module. -- See Note [Grand plan for static forms] in StaticPtrTable } ----------------------------------- -- | Foreign export stubs data ForeignStubs = NoStubs -- ^ We don't have any stubs | ForeignStubs SDoc SDoc -- ^ There are some stubs. Parameters: -- -- 1) Header file prototypes for -- "foreign exported" functions -- -- 2) C stubs to use when calling -- "foreign exported" functions appendStubC :: ForeignStubs -> SDoc -> ForeignStubs appendStubC NoStubs c_code = ForeignStubs empty c_code appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) {- ************************************************************************ * * The interactive context * * ************************************************************************ Note [The interactive package] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Type, class, and value declarations at the command prompt are treated as if they were defined in modules interactive:Ghci1 interactive:Ghci2 ...etc... with each bunch of declarations using a new module, all sharing a common package 'interactive' (see Module.interactiveUnitId, and PrelNames.mkInteractiveModule). This scheme deals well with shadowing. For example: ghci> data T = A ghci> data T = B ghci> :i A data Ghci1.T = A -- Defined at :2:10 Here we must display info about constructor A, but its type T has been shadowed by the second declaration. But it has a respectable qualified name (Ghci1.T), and its source location says where it was defined. So the main invariant continues to hold, that in any session an original name M.T only refers to one unique thing. (In a previous iteration both the T's above were called :Interactive.T, albeit with different uniques, which gave rise to all sorts of trouble.) The details are a bit tricky though: * The field ic_mod_index counts which Ghci module we've got up to. It is incremented when extending ic_tythings * ic_tythings contains only things from the 'interactive' package. * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go in the Home Package Table (HPT). When you say :load, that's when we extend the HPT. * The 'thisPackage' field of DynFlags is *not* set to 'interactive'. It stays as 'main' (or whatever -this-unit-id says), and is the package to which :load'ed modules are added to. * So how do we arrange that declarations at the command prompt get to be in the 'interactive' package? Simply by setting the tcg_mod field of the TcGblEnv to "interactive:Ghci1". This is done by the call to initTc in initTcInteractive, which in turn get the module from it 'icInteractiveModule' field of the interactive context. The 'thisPackage' field stays as 'main' (or whatever -this-unit-id says. * The main trickiness is that the type environment (tcg_type_env) and fixity envt (tcg_fix_env), now contain entities from all the interactive-package modules (Ghci1, Ghci2, ...) together, rather than just a single module as is usually the case. So you can't use "nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs the HPT/PTE. This is a change, but not a problem provided you know. * However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields of the TcGblEnv, which collect "things defined in this module", all refer to stuff define in a single GHCi command, *not* all the commands so far. In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from all GhciN modules, which makes sense -- they are all "home package" modules. Note [Interactively-bound Ids in GHCi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Ids bound by previous Stmts in GHCi are currently a) GlobalIds, with b) An External Name, like Ghci4.foo See Note [The interactive package] above c) A tidied type (a) They must be GlobalIds (not LocalIds) otherwise when we come to compile an expression using these ids later, the byte code generator will consider the occurrences to be free rather than global. (b) Having an External Name is important because of Note [GlobalRdrEnv shadowing] in RdrName (c) Their types are tidied. This is important, because :info may ask to look at them, and :info expects the things it looks up to have tidy types Where do interactively-bound Ids come from? - GHCi REPL Stmts e.g. ghci> let foo x = x+1 These start with an Internal Name because a Stmt is a local construct, so the renamer naturally builds an Internal name for each of its binders. Then in tcRnStmt they are externalised via TcRnDriver.externaliseAndTidyId, so they get Names like Ghic4.foo. - Ids bound by the debugger etc have Names constructed by IfaceEnv.newInteractiveBinder; at the call sites it is followed by mkVanillaGlobal or mkVanillaGlobalWithInfo. So again, they are all Global, External. - TyCons, Classes, and Ids bound by other top-level declarations in GHCi (eg foreign import, record selectors) also get External Names, with Ghci9 (or 8, or 7, etc) as the module name. Note [ic_tythings] ~~~~~~~~~~~~~~~~~~ The ic_tythings field contains * The TyThings declared by the user at the command prompt (eg Ids, TyCons, Classes) * The user-visible Ids that arise from such things, which *don't* come from 'implicitTyThings', notably: - record selectors - class ops The implicitTyThings are readily obtained from the TyThings but record selectors etc are not It does *not* contain * DFunIds (they can be gotten from ic_instances) * CoAxioms (ditto) See also Note [Interactively-bound Ids in GHCi] Note [Override identical instances in GHCi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If you declare a new instance in GHCi that is identical to a previous one, we simply override the previous one; we don't regard it as overlapping. e.g. Prelude> data T = A | B Prelude> instance Eq T where ... Prelude> instance Eq T where ... -- This one overrides It's exactly the same for type-family instances. See #7102 -} -- | Interactive context, recording information about the state of the -- context in which statements are executed in a GHCi session. data InteractiveContext = InteractiveContext { ic_dflags :: DynFlags, -- ^ The 'DynFlags' used to evaluate interative expressions -- and statements. ic_mod_index :: Int, -- ^ Each GHCi stmt or declaration brings some new things into -- scope. We give them names like interactive:Ghci9.T, -- where the ic_index is the '9'. The ic_mod_index is -- incremented whenever we add something to ic_tythings -- See Note [The interactive package] ic_imports :: [InteractiveImport], -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with -- these imports -- -- This field is only stored here so that the client -- can retrieve it with GHC.getContext. GHC itself doesn't -- use it, but does reset it to empty sometimes (such -- as before a GHC.load). The context is set with GHC.setContext. ic_tythings :: [TyThing], -- ^ TyThings defined by the user, in reverse order of -- definition (ie most recent at the front) -- See Note [ic_tythings] ic_rn_gbl_env :: GlobalRdrEnv, -- ^ The cached 'GlobalRdrEnv', built by -- 'InteractiveEval.setContext' and updated regularly -- It contains everything in scope at the command line, -- including everything in ic_tythings ic_instances :: ([ClsInst], [FamInst]), -- ^ All instances and family instances created during -- this session. These are grabbed en masse after each -- update to be sure that proper overlapping is retained. -- That is, rather than re-check the overlapping each -- time we update the context, we just take the results -- from the instance code that already does that. ic_fix_env :: FixityEnv, -- ^ Fixities declared in let statements ic_default :: Maybe [Type], -- ^ The current default types, set by a 'default' declaration ic_resume :: [Resume], -- ^ The stack of breakpoint contexts ic_monad :: Name, -- ^ The monad that GHCi is executing in ic_int_print :: Name, -- ^ The function that is used for printing results -- of expressions in ghci and -e mode. ic_cwd :: Maybe FilePath -- virtual CWD of the program } data InteractiveImport = IIDecl (ImportDecl GhcPs) -- ^ Bring the exports of a particular module -- (filtered by an import decl) into scope | IIModule ModuleName -- ^ Bring into scope the entire top-level envt of -- of this module, including the things imported -- into it. -- | Constructs an empty InteractiveContext. emptyInteractiveContext :: DynFlags -> InteractiveContext emptyInteractiveContext dflags = InteractiveContext { ic_dflags = dflags, ic_imports = [], ic_rn_gbl_env = emptyGlobalRdrEnv, ic_mod_index = 1, ic_tythings = [], ic_instances = ([],[]), ic_fix_env = emptyNameEnv, ic_monad = ioTyConName, -- IO monad by default ic_int_print = printName, -- System.IO.print by default ic_default = Nothing, ic_resume = [], ic_cwd = Nothing } icInteractiveModule :: InteractiveContext -> Module icInteractiveModule (InteractiveContext { ic_mod_index = index }) = mkInteractiveModule index -- | This function returns the list of visible TyThings (useful for -- e.g. showBindings) icInScopeTTs :: InteractiveContext -> [TyThing] icInScopeTTs = ic_tythings -- | Get the PrintUnqualified function based on the flags and this InteractiveContext icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } = mkPrintUnqualified dflags grenv -- | extendInteractiveContext is called with new TyThings recently defined to update the -- InteractiveContext to include them. Ids are easily removed when shadowed, -- but Classes and TyCons are not. Some work could be done to determine -- whether they are entirely shadowed, but as you could still have references -- to them (e.g. instances for classes or values of the type for TyCons), it's -- not clear whether removing them is even the appropriate behavior. extendInteractiveContext :: InteractiveContext -> [TyThing] -> [ClsInst] -> [FamInst] -> Maybe [Type] -> FixityEnv -> InteractiveContext extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env = ictxt { ic_mod_index = ic_mod_index ictxt + 1 -- Always bump this; even instances should create -- a new mod_index (#9426) , ic_tythings = new_tythings ++ old_tythings , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings , ic_instances = ( new_cls_insts ++ old_cls_insts , new_fam_insts ++ fam_insts ) -- we don't shadow old family instances (#7102), -- so don't need to remove them here , ic_default = defaults , ic_fix_env = fix_env -- See Note [Fixity declarations in GHCi] } where new_ids = [id | AnId id <- new_tythings] old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt) -- Discard old instances that have been fully overridden -- See Note [Override identical instances in GHCi] (cls_insts, fam_insts) = ic_instances ictxt old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext -- Just a specialised version extendInteractiveContextWithIds ictxt new_ids | null new_ids = ictxt | otherwise = ictxt { ic_mod_index = ic_mod_index ictxt + 1 , ic_tythings = new_tythings ++ old_tythings , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings } where new_tythings = map AnId new_ids old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt) shadowed_by :: [Id] -> TyThing -> Bool shadowed_by ids = shadowed where shadowed id = getOccName id `elemOccSet` new_occs new_occs = mkOccSet (map getOccName ids) setInteractivePackage :: HscEnv -> HscEnv -- Set the 'thisPackage' DynFlag to 'interactive' setInteractivePackage hsc_env = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisInstalledUnitId = toInstalledUnitId interactiveUnitId } } setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext setInteractivePrintName ic n = ic{ic_int_print = n} -- ToDo: should not add Ids to the gbl env here -- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing -- later ones, and shadowing existing entries in the GlobalRdrEnv. icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv icExtendGblRdrEnv env tythings = foldr add env tythings -- Foldr makes things in the front of -- the list shadow things at the back where -- One at a time, to ensure each shadows the previous ones add thing env | is_sub_bndr thing = env | otherwise = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail) where env1 = shadowNames env (concatMap availNames avail) avail = tyThingAvailInfo thing -- Ugh! The new_tythings may include record selectors, since they -- are not implicit-ids, and must appear in the TypeEnv. But they -- will also be brought into scope by the corresponding (ATyCon -- tc). And we want the latter, because that has the correct -- parent (#10520) is_sub_bndr (AnId f) = case idDetails f of RecSelId {} -> True ClassOpId {} -> True _ -> False is_sub_bndr _ = False substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst | isEmptyTCvSubst subst = ictxt | otherwise = ictxt { ic_tythings = map subst_ty tts } where subst_ty (AnId id) = AnId $ id `setIdType` substTyAddInScope subst (idType id) -- Variables in the interactive context *can* mention free type variables -- because of the runtime debugger. Otherwise you'd expect all -- variables bound in the interactive context to be closed. subst_ty tt = tt instance Outputable InteractiveImport where ppr (IIModule m) = char '*' <> ppr m ppr (IIDecl d) = ppr d {- ************************************************************************ * * Building a PrintUnqualified * * ************************************************************************ Note [Printing original names] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Deciding how to print names is pretty tricky. We are given a name P:M.T, where P is the package name, M is the defining module, and T is the occurrence name, and we have to decide in which form to display the name given a GlobalRdrEnv describing the current scope. Ideally we want to display the name in the form in which it is in scope. However, the name might not be in scope at all, and that's where it gets tricky. Here are the cases: 1. T uniquely maps to P:M.T ---> "T" NameUnqual 2. There is an X for which X.T uniquely maps to P:M.T ---> "X.T" NameQual X 3. There is no binding for "M.T" ---> "M.T" NameNotInScope1 4. Otherwise ---> "P:M.T" NameNotInScope2 (3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at all. In these cases we still want to refer to the name as "M.T", *but* "M.T" might mean something else in the current scope (e.g. if there's an "import X as M"), so to avoid confusion we avoid using "M.T" if there's already a binding for it. Instead we write P:M.T. There's one further subtlety: in case (3), what if there are two things around, P1:M.T and P2:M.T? Then we don't want to print both of them as M.T! However only one of the modules P1:M and P2:M can be exposed (say P2), so we use M.T for that, and P1:M.T for the other one. This is handled by the qual_mod component of PrintUnqualified, inside the (ppr mod) of case (3), in Name.pprModulePrefix Note [Printing unit ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the old days, original names were tied to PackageIds, which directly corresponded to the entities that users wrote in Cabal files, and were perfectly suitable for printing when we need to disambiguate packages. However, with UnitId, the situation can be different: if the key is instantiated with some holes, we should try to give the user some more useful information. -} -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics. mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified mkPrintUnqualified dflags env = QueryQualify qual_name (mkQualModule dflags) (mkQualPackage dflags) where qual_name mod occ | [gre] <- unqual_gres , right_name gre = NameUnqual -- If there's a unique entity that's in scope -- unqualified with 'occ' AND that entity is -- the right one, then we can use the unqualified name | [] <- unqual_gres , any is_name forceUnqualNames , not (isDerivedOccName occ) = NameUnqual -- Don't qualify names that come from modules -- that come with GHC, often appear in error messages, -- but aren't typically in scope. Doing this does not -- cause ambiguity, and it reduces the amount of -- qualification in error messages thus improving -- readability. -- -- A motivating example is 'Constraint'. It's often not -- in scope, but printing GHC.Prim.Constraint seems -- overkill. | [gre] <- qual_gres = NameQual (greQualModName gre) | null qual_gres = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env) then NameNotInScope1 else NameNotInScope2 | otherwise = NameNotInScope1 -- Can happen if 'f' is bound twice in the module -- Eg f = True; g = 0; f = False where is_name :: Name -> Bool is_name name = ASSERT2( isExternalName name, ppr name ) nameModule name == mod && nameOccName name == occ forceUnqualNames :: [Name] forceUnqualNames = map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ] ++ [ eqTyConName ] right_name gre = nameModule_maybe (gre_name gre) == Just mod unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env qual_gres = filter right_name (lookupGlobalRdrEnv env occ) -- we can mention a module P:M without the P: qualifier iff -- "import M" would resolve unambiguously to P:M. (if P is the -- current package we can just assume it is unqualified). -- | Creates a function for formatting modules based on two heuristics: -- (1) if the module is the current module, don't qualify, and (2) if there -- is only one exposed package which exports this module, don't qualify. mkQualModule :: DynFlags -> QueryQualifyModule mkQualModule dflags mod | moduleUnitId mod == thisPackage dflags = False | [(_, pkgconfig)] <- lookup, packageConfigId pkgconfig == moduleUnitId mod -- this says: we are given a module P:M, is there just one exposed package -- that exposes a module M, and is it package P? = False | otherwise = True where lookup = lookupModuleInAllPackages dflags (moduleName mod) -- | Creates a function for formatting packages based on two heuristics: -- (1) don't qualify if the package in question is "main", and (2) only qualify -- with a unit id if the package ID would be ambiguous. mkQualPackage :: DynFlags -> QueryQualifyPackage mkQualPackage dflags pkg_key | pkg_key == mainUnitId || pkg_key == interactiveUnitId -- Skip the lookup if it's main, since it won't be in the package -- database! = False | Just pkgid <- mb_pkgid , searchPackageId dflags pkgid `lengthIs` 1 -- this says: we are given a package pkg-0.1@MMM, are there only one -- exposed packages whose package ID is pkg-0.1? = False | otherwise = True where mb_pkgid = fmap sourcePackageId (lookupPackage dflags pkg_key) -- | A function which only qualifies package names if necessary; but -- qualifies all other identifiers. pkgQual :: DynFlags -> PrintUnqualified pkgQual dflags = alwaysQualify { queryQualifyPackage = mkQualPackage dflags } {- ************************************************************************ * * Implicit TyThings * * ************************************************************************ Note [Implicit TyThings] ~~~~~~~~~~~~~~~~~~~~~~~~ DEFINITION: An "implicit" TyThing is one that does not have its own IfaceDecl in an interface file. Instead, its binding in the type environment is created as part of typechecking the IfaceDecl for some other thing. Examples: * All DataCons are implicit, because they are generated from the IfaceDecl for the data/newtype. Ditto class methods. * Record selectors are *not* implicit, because they get their own free-standing IfaceDecl. * Associated data/type families are implicit because they are included in the IfaceDecl of the parent class. (NB: the IfaceClass decl happens to use IfaceDecl recursively for the associated types, but that's irrelevant here.) * Dictionary function Ids are not implicit. * Axioms for newtypes are implicit (same as above), but axioms for data/type family instances are *not* implicit (like DFunIds). -} -- | Determine the 'TyThing's brought into scope by another 'TyThing' -- /other/ than itself. For example, Id's don't have any implicit TyThings -- as they just bring themselves into scope, but classes bring their -- dictionary datatype, type constructor and some selector functions into -- scope, just for a start! -- N.B. the set of TyThings returned here *must* match the set of -- names returned by LoadIface.ifaceDeclImplicitBndrs, in the sense that -- TyThing.getOccName should define a bijection between the two lists. -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) -- The order of the list does not matter. implicitTyThings :: TyThing -> [TyThing] implicitTyThings (AnId _) = [] implicitTyThings (ACoAxiom _cc) = [] implicitTyThings (ATyCon tc) = implicitTyConThings tc implicitTyThings (AConLike cl) = implicitConLikeThings cl implicitConLikeThings :: ConLike -> [TyThing] implicitConLikeThings (RealDataCon dc) = dataConImplicitTyThings dc implicitConLikeThings (PatSynCon {}) = [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher -- are not "implicit"; they are simply new top-level bindings, -- and they have their own declaration in an interface file -- Unless a record pat syn when there are implicit selectors -- They are still not included here as `implicitConLikeThings` is -- used by `tcTyClsDecls` whilst pattern synonyms are typed checked -- by `tcTopValBinds`. implicitClassThings :: Class -> [TyThing] implicitClassThings cl = -- Does not include default methods, because those Ids may have -- their own pragmas, unfoldings etc, not derived from the Class object -- associated types -- No recursive call for the classATs, because they -- are only the family decls; they have no implicit things map ATyCon (classATs cl) ++ -- superclass and operation selectors map AnId (classAllSelIds cl) implicitTyConThings :: TyCon -> [TyThing] implicitTyConThings tc = class_stuff ++ -- fields (names of selectors) -- (possibly) implicit newtype axioms -- or type family axioms implicitCoTyCon tc ++ -- for each data constructor in order, -- the constructor, worker, and (possibly) wrapper [ thing | dc <- tyConDataCons tc , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ] -- NB. record selectors are *not* implicit, they have fully-fledged -- bindings that pass through the compilation pipeline as normal. where class_stuff = case tyConClass_maybe tc of Nothing -> [] Just cl -> implicitClassThings cl -- For newtypes and closed type families (only) add the implicit coercion tycon implicitCoTyCon :: TyCon -> [TyThing] implicitCoTyCon tc | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co] | Just co <- isClosedSynFamilyTyConWithAxiom_maybe tc = [ACoAxiom co] | otherwise = [] -- | Returns @True@ if there should be no interface-file declaration -- for this thing on its own: either it is built-in, or it is part -- of some other declaration, or it is generated implicitly by some -- other declaration. isImplicitTyThing :: TyThing -> Bool isImplicitTyThing (AConLike cl) = case cl of RealDataCon {} -> True PatSynCon {} -> False isImplicitTyThing (AnId id) = isImplicitId id isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax -- | tyThingParent_maybe x returns (Just p) -- when pprTyThingInContext should print a declaration for p -- (albeit with some "..." in it) when asked to show x -- It returns the *immediate* parent. So a datacon returns its tycon -- but the tycon could be the associated type of a class, so it in turn -- might have a parent. tyThingParent_maybe :: TyThing -> Maybe TyThing tyThingParent_maybe (AConLike cl) = case cl of RealDataCon dc -> Just (ATyCon (dataConTyCon dc)) PatSynCon{} -> Nothing tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of Just tc -> Just (ATyCon tc) Nothing -> Nothing tyThingParent_maybe (AnId id) = case idDetails id of RecSelId { sel_tycon = RecSelData tc } -> Just (ATyCon tc) ClassOpId cls -> Just (ATyCon (classTyCon cls)) _other -> Nothing tyThingParent_maybe _other = Nothing tyThingsTyCoVars :: [TyThing] -> TyCoVarSet tyThingsTyCoVars tts = unionVarSets $ map ttToVarSet tts where ttToVarSet (AnId id) = tyCoVarsOfType $ idType id ttToVarSet (AConLike cl) = case cl of RealDataCon dc -> tyCoVarsOfType $ dataConRepType dc PatSynCon{} -> emptyVarSet ttToVarSet (ATyCon tc) = case tyConClass_maybe tc of Just cls -> (mkVarSet . fst . classTvsFds) cls Nothing -> tyCoVarsOfType $ tyConKind tc ttToVarSet (ACoAxiom _) = emptyVarSet -- | The Names that a TyThing should bring into scope. Used to build -- the GlobalRdrEnv for the InteractiveContext. tyThingAvailInfo :: TyThing -> [AvailInfo] tyThingAvailInfo (ATyCon t) = case tyConClass_maybe t of Just c -> [AvailTC n (n : map getName (classMethods c) ++ map getName (classATs c)) [] ] where n = getName c Nothing -> [AvailTC n (n : map getName dcs) flds] where n = getName t dcs = tyConDataCons t flds = tyConFieldLabels t tyThingAvailInfo (AConLike (PatSynCon p)) = map avail ((getName p) : map flSelector (patSynFieldLabels p)) tyThingAvailInfo t = [avail (getName t)] {- ************************************************************************ * * TypeEnv * * ************************************************************************ -} -- | A map from 'Name's to 'TyThing's, constructed by typechecking -- local declarations or interface files type TypeEnv = NameEnv TyThing emptyTypeEnv :: TypeEnv typeEnvElts :: TypeEnv -> [TyThing] typeEnvTyCons :: TypeEnv -> [TyCon] typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched] typeEnvIds :: TypeEnv -> [Id] typeEnvPatSyns :: TypeEnv -> [PatSyn] typeEnvDataCons :: TypeEnv -> [DataCon] typeEnvClasses :: TypeEnv -> [Class] lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing emptyTypeEnv = emptyNameEnv typeEnvElts env = nameEnvElts env typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] typeEnvIds env = [id | AnId id <- typeEnvElts env] typeEnvPatSyns env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env] typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env] typeEnvClasses env = [cl | tc <- typeEnvTyCons env, Just cl <- [tyConClass_maybe tc]] mkTypeEnv :: [TyThing] -> TypeEnv mkTypeEnv things = extendTypeEnvList emptyTypeEnv things mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv mkTypeEnvWithImplicits things = mkTypeEnv things `plusNameEnv` mkTypeEnv (concatMap implicitTyThings things) typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv typeEnvFromEntities ids tcs famInsts = mkTypeEnv ( map AnId ids ++ map ATyCon all_tcs ++ concatMap implicitTyConThings all_tcs ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts ) where all_tcs = tcs ++ famInstsRepTyCons famInsts lookupTypeEnv = lookupNameEnv -- Extend the type environment extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv extendTypeEnv env thing = extendNameEnv env (getName thing) thing extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv extendTypeEnvList env things = foldl' extendTypeEnv env things extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv extendTypeEnvWithIds env ids = extendNameEnvList env [(getName id, AnId id) | id <- ids] plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv plusTypeEnv env1 env2 = plusNameEnv env1 env2 -- | Find the 'TyThing' for the given 'Name' by using all the resources -- at our disposal: the compiled modules in the 'HomePackageTable' and the -- compiled modules in other packages that live in 'PackageTypeEnv'. Note -- that this does NOT look up the 'TyThing' in the module being compiled: you -- have to do that yourself, if desired lookupType :: DynFlags -> HomePackageTable -> PackageTypeEnv -> Name -> Maybe TyThing lookupType dflags hpt pte name | isOneShot (ghcMode dflags) -- in one-shot, we don't use the HPT = lookupNameEnv pte name | otherwise = case lookupHptByModule hpt mod of Just hm -> lookupNameEnv (md_types (hm_details hm)) name Nothing -> lookupNameEnv pte name where mod = ASSERT2( isExternalName name, ppr name ) if isHoleName name then mkModule (thisPackage dflags) (moduleName (nameModule name)) else nameModule name -- | As 'lookupType', but with a marginally easier-to-use interface -- if you have a 'HscEnv' lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing) lookupTypeHscEnv hsc_env name = do eps <- readIORef (hsc_EPS hsc_env) return $! lookupType dflags hpt (eps_PTE eps) name where dflags = hsc_dflags hsc_env hpt = hsc_HPT hsc_env -- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise tyThingTyCon :: TyThing -> TyCon tyThingTyCon (ATyCon tc) = tc tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) -- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise tyThingCoAxiom :: TyThing -> CoAxiom Branched tyThingCoAxiom (ACoAxiom ax) = ax tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (ppr other) -- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise tyThingDataCon :: TyThing -> DataCon tyThingDataCon (AConLike (RealDataCon dc)) = dc tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other) -- | Get the 'ConLike' from a 'TyThing' if it is a data constructor thing. -- Panics otherwise tyThingConLike :: TyThing -> ConLike tyThingConLike (AConLike dc) = dc tyThingConLike other = pprPanic "tyThingConLike" (ppr other) -- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise tyThingId :: TyThing -> Id tyThingId (AnId id) = id tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc tyThingId other = pprPanic "tyThingId" (ppr other) {- ************************************************************************ * * \subsection{MonadThings and friends} * * ************************************************************************ -} -- | Class that abstracts out the common ability of the monads in GHC -- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides -- a number of related convenience functions for accessing particular -- kinds of 'TyThing' class Monad m => MonadThings m where lookupThing :: Name -> m TyThing lookupId :: Name -> m Id lookupId = liftM tyThingId . lookupThing lookupDataCon :: Name -> m DataCon lookupDataCon = liftM tyThingDataCon . lookupThing lookupTyCon :: Name -> m TyCon lookupTyCon = liftM tyThingTyCon . lookupThing {- ************************************************************************ * * \subsection{Auxiliary types} * * ************************************************************************ These types are defined here because they are mentioned in ModDetails, but they are mostly elaborated elsewhere -} ------------------ Warnings ------------------------- -- | Warning information for a module data Warnings = NoWarnings -- ^ Nothing deprecated | WarnAll WarningTxt -- ^ Whole module deprecated | WarnSome [(OccName,WarningTxt)] -- ^ Some specific things deprecated -- Only an OccName is needed because -- (1) a deprecation always applies to a binding -- defined in the module in which the deprecation appears. -- (2) deprecations are only reported outside the defining module. -- this is important because, otherwise, if we saw something like -- -- {-# DEPRECATED f "" #-} -- f = ... -- h = f -- g = let f = undefined in f -- -- we'd need more information than an OccName to know to say something -- about the use of f in h but not the use of the locally bound f in g -- -- however, because we only report about deprecations from the outside, -- and a module can only export one value called f, -- an OccName suffices. -- -- this is in contrast with fixity declarations, where we need to map -- a Name to its fixity declaration. deriving( Eq ) instance Binary Warnings where put_ bh NoWarnings = putByte bh 0 put_ bh (WarnAll t) = do putByte bh 1 put_ bh t put_ bh (WarnSome ts) = do putByte bh 2 put_ bh ts get bh = do h <- getByte bh case h of 0 -> return NoWarnings 1 -> do aa <- get bh return (WarnAll aa) _ -> do aa <- get bh return (WarnSome aa) -- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface' mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt mkIfaceWarnCache NoWarnings = \_ -> Nothing mkIfaceWarnCache (WarnAll t) = \_ -> Just t mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) emptyIfaceWarnCache :: OccName -> Maybe WarningTxt emptyIfaceWarnCache _ = Nothing plusWarns :: Warnings -> Warnings -> Warnings plusWarns d NoWarnings = d plusWarns NoWarnings d = d plusWarns _ (WarnAll t) = WarnAll t plusWarns (WarnAll t) _ = WarnAll t plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2) -- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface' mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity mkIfaceFixCache pairs = \n -> lookupOccEnv env n where env = mkOccEnv pairs emptyIfaceFixCache :: OccName -> Maybe Fixity emptyIfaceFixCache _ = Nothing -- | Fixity environment mapping names to their fixities type FixityEnv = NameEnv FixItem -- | Fixity information for an 'Name'. We keep the OccName in the range -- so that we can generate an interface from it data FixItem = FixItem OccName Fixity instance Outputable FixItem where ppr (FixItem occ fix) = ppr fix <+> ppr occ emptyFixityEnv :: FixityEnv emptyFixityEnv = emptyNameEnv lookupFixity :: FixityEnv -> Name -> Fixity lookupFixity env n = case lookupNameEnv env n of Just (FixItem _ fix) -> fix Nothing -> defaultFixity {- ************************************************************************ * * \subsection{WhatsImported} * * ************************************************************************ -} -- | Records whether a module has orphans. An \"orphan\" is one of: -- -- * An instance declaration in a module other than the definition -- module for one of the type constructors or classes in the instance head -- -- * A transformation rule in a module other than the one defining -- the function in the head of the rule -- type WhetherHasOrphans = Bool -- | Does this module define family instances? type WhetherHasFamInst = Bool -- | Did this module originate from a *-boot file? type IsBootInterface = Bool -- | Dependency information about ALL modules and packages below this one -- in the import hierarchy. -- -- Invariant: the dependencies of a module @M@ never includes @M@. -- -- Invariant: none of the lists contain duplicates. data Dependencies = Deps { dep_mods :: [(ModuleName, IsBootInterface)] -- ^ All home-package modules transitively below this one -- I.e. modules that this one imports, or that are in the -- dep_mods of those directly-imported modules , dep_pkgs :: [(InstalledUnitId, Bool)] -- ^ All packages transitively below this module -- I.e. packages to which this module's direct imports belong, -- or that are in the dep_pkgs of those modules -- The bool indicates if the package is required to be -- trusted when the module is imported as a safe import -- (Safe Haskell). See Note [RnNames . Tracking Trust Transitively] , dep_orphs :: [Module] -- ^ Transitive closure of orphan modules (whether -- home or external pkg). -- -- (Possible optimization: don't include family -- instance orphans as they are anyway included in -- 'dep_finsts'. But then be careful about code -- which relies on dep_orphs having the complete list!) -- This does NOT include us, unlike 'imp_orphs'. , dep_finsts :: [Module] -- ^ Transitive closure of depended upon modules which -- contain family instances (whether home or external). -- This is used by 'checkFamInstConsistency'. This -- does NOT include us, unlike 'imp_finsts'. See Note -- [The type family instance consistency story]. , dep_plgins :: [ModuleName] -- ^ All the plugins used while compiling this module. } deriving( Eq ) -- Equality used only for old/new comparison in MkIface.addFingerprints -- See 'TcRnTypes.ImportAvails' for details on dependencies. instance Binary Dependencies where put_ bh deps = do put_ bh (dep_mods deps) put_ bh (dep_pkgs deps) put_ bh (dep_orphs deps) put_ bh (dep_finsts deps) put_ bh (dep_plgins deps) get bh = do ms <- get bh ps <- get bh os <- get bh fis <- get bh pl <- get bh return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, dep_finsts = fis, dep_plgins = pl }) noDependencies :: Dependencies noDependencies = Deps [] [] [] [] [] -- | Records modules for which changes may force recompilation of this module -- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance -- -- This differs from Dependencies. A module X may be in the dep_mods of this -- module (via an import chain) but if we don't use anything from X it won't -- appear in our Usage data Usage -- | Module from another package = UsagePackageModule { usg_mod :: Module, -- ^ External package module depended on usg_mod_hash :: Fingerprint, -- ^ Cached module fingerprint usg_safe :: IsSafeImport -- ^ Was this module imported as a safe import } -- | Module from the current package | UsageHomeModule { usg_mod_name :: ModuleName, -- ^ Name of the module usg_mod_hash :: Fingerprint, -- ^ Cached module fingerprint usg_entities :: [(OccName,Fingerprint)], -- ^ Entities we depend on, sorted by occurrence name and fingerprinted. -- NB: usages are for parent names only, e.g. type constructors -- but not the associated data constructors. usg_exports :: Maybe Fingerprint, -- ^ Fingerprint for the export list of this module, -- if we directly imported it (and hence we depend on its export list) usg_safe :: IsSafeImport -- ^ Was this module imported as a safe import } -- ^ Module from the current package -- | A file upon which the module depends, e.g. a CPP #include, or using TH's -- 'addDependentFile' | UsageFile { usg_file_path :: FilePath, -- ^ External file dependency. From a CPP #include or TH -- addDependentFile. Should be absolute. usg_file_hash :: Fingerprint -- ^ 'Fingerprint' of the file contents. -- Note: We don't consider things like modification timestamps -- here, because there's no reason to recompile if the actual -- contents don't change. This previously lead to odd -- recompilation behaviors; see #8114 } -- | A requirement which was merged into this one. | UsageMergedRequirement { usg_mod :: Module, usg_mod_hash :: Fingerprint } deriving( Eq ) -- The export list field is (Just v) if we depend on the export list: -- i.e. we imported the module directly, whether or not we -- enumerated the things we imported, or just imported -- everything -- We need to recompile if M's exports change, because -- if the import was import M, we might now have a name clash -- in the importing module. -- if the import was import M(x) M might no longer export x -- The only way we don't depend on the export list is if we have -- import M() -- And of course, for modules that aren't imported directly we don't -- depend on their export lists instance Binary Usage where put_ bh usg@UsagePackageModule{} = do putByte bh 0 put_ bh (usg_mod usg) put_ bh (usg_mod_hash usg) put_ bh (usg_safe usg) put_ bh usg@UsageHomeModule{} = do putByte bh 1 put_ bh (usg_mod_name usg) put_ bh (usg_mod_hash usg) put_ bh (usg_exports usg) put_ bh (usg_entities usg) put_ bh (usg_safe usg) put_ bh usg@UsageFile{} = do putByte bh 2 put_ bh (usg_file_path usg) put_ bh (usg_file_hash usg) put_ bh usg@UsageMergedRequirement{} = do putByte bh 3 put_ bh (usg_mod usg) put_ bh (usg_mod_hash usg) get bh = do h <- getByte bh case h of 0 -> do nm <- get bh mod <- get bh safe <- get bh return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } 1 -> do nm <- get bh mod <- get bh exps <- get bh ents <- get bh safe <- get bh return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, usg_exports = exps, usg_entities = ents, usg_safe = safe } 2 -> do fp <- get bh hash <- get bh return UsageFile { usg_file_path = fp, usg_file_hash = hash } 3 -> do mod <- get bh hash <- get bh return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash } i -> error ("Binary.get(Usage): " ++ show i) {- ************************************************************************ * * The External Package State * * ************************************************************************ -} type PackageTypeEnv = TypeEnv type PackageRuleBase = RuleBase type PackageInstEnv = InstEnv type PackageFamInstEnv = FamInstEnv type PackageAnnEnv = AnnEnv type PackageCompleteMatchMap = CompleteMatchMap -- | Information about other packages that we have slurped in by reading -- their interface files data ExternalPackageState = EPS { eps_is_boot :: !(ModuleNameEnv (ModuleName, IsBootInterface)), -- ^ In OneShot mode (only), home-package modules -- accumulate in the external package state, and are -- sucked in lazily. For these home-pkg modules -- (only) we need to record which are boot modules. -- We set this field after loading all the -- explicitly-imported interfaces, but before doing -- anything else -- -- The 'ModuleName' part is not necessary, but it's useful for -- debug prints, and it's convenient because this field comes -- direct from 'TcRnTypes.imp_dep_mods' eps_PIT :: !PackageIfaceTable, -- ^ The 'ModIface's for modules in external packages -- whose interfaces we have opened. -- The declarations in these interface files are held in the -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules' -- fields of this record, not in the 'mi_decls' fields of the -- interface we have sucked in. -- -- What /is/ in the PIT is: -- -- * The Module -- -- * Fingerprint info -- -- * Its exports -- -- * Fixities -- -- * Deprecations and warnings eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName), -- ^ Cache for 'mi_free_holes'. Ordinarily, we can rely on -- the 'eps_PIT' for this information, EXCEPT that when -- we do dependency analysis, we need to look at the -- 'Dependencies' of our imports to determine what their -- precise free holes are ('moduleFreeHolesPrecise'). We -- don't want to repeatedly reread in the interface -- for every import, so cache it here. When the PIT -- gets filled in we can drop these entries. eps_PTE :: !PackageTypeEnv, -- ^ Result of typechecking all the external package -- interface files we have sucked in. The domain of -- the mapping is external-package modules eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated -- from all the external-package modules eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated -- from all the external-package modules eps_rule_base :: !PackageRuleBase, -- ^ The total 'RuleEnv' accumulated -- from all the external-package modules eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated -- from all the external-package modules eps_complete_matches :: !PackageCompleteMatchMap, -- ^ The total 'CompleteMatchMap' accumulated -- from all the external-package modules eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external -- packages, keyed off the module that declared them eps_stats :: !EpsStats -- ^ Stastics about what was loaded from external packages } -- | Accumulated statistics about what we are putting into the 'ExternalPackageState'. -- \"In\" means stuff that is just /read/ from interface files, -- \"Out\" means actually sucked in and type-checked data EpsStats = EpsStats { n_ifaces_in , n_decls_in, n_decls_out , n_rules_in, n_rules_out , n_insts_in, n_insts_out :: !Int } addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats -- ^ Add stats for one newly-read interface addEpsInStats stats n_decls n_insts n_rules = stats { n_ifaces_in = n_ifaces_in stats + 1 , n_decls_in = n_decls_in stats + n_decls , n_insts_in = n_insts_in stats + n_insts , n_rules_in = n_rules_in stats + n_rules } {- Names in a NameCache are always stored as a Global, and have the SrcLoc of their binding locations. Actually that's not quite right. When we first encounter the original name, we might not be at its binding site (e.g. we are reading an interface file); so we give it 'noSrcLoc' then. Later, when we find its binding site, we fix it up. -} updNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -- The updating function -> IO c updNameCache ncRef upd_fn = atomicModifyIORef' ncRef upd_fn mkSOName :: Platform -> FilePath -> FilePath mkSOName platform root = case platformOS platform of OSMinGW32 -> root <.> soExt platform _ -> ("lib" ++ root) <.> soExt platform mkHsSOName :: Platform -> FilePath -> FilePath mkHsSOName platform root = ("lib" ++ root) <.> soExt platform soExt :: Platform -> FilePath soExt platform = case platformOS platform of OSDarwin -> "dylib" OSMinGW32 -> "dll" _ -> "so" {- ************************************************************************ * * The module graph and ModSummary type A ModSummary is a node in the compilation manager's dependency graph, and it's also passed to hscMain * * ************************************************************************ -} -- | A ModuleGraph contains all the nodes from the home package (only). -- There will be a node for each source module, plus a node for each hi-boot -- module. -- -- The graph is not necessarily stored in topologically-sorted order. Use -- 'GHC.topSortModuleGraph' and 'Digraph.flattenSCC' to achieve this. data ModuleGraph = ModuleGraph { mg_mss :: [ModSummary] , mg_non_boot :: ModuleEnv ModSummary -- a map of all non-boot ModSummaries keyed by Modules , mg_boot :: ModuleSet -- a set of boot Modules , mg_needs_th_or_qq :: !Bool -- does any of the modules in mg_mss require TemplateHaskell or -- QuasiQuotes? } -- | Determines whether a set of modules requires Template Haskell or -- Quasi Quotes -- -- Note that if the session's 'DynFlags' enabled Template Haskell when -- 'depanal' was called, then each module in the returned module graph will -- have Template Haskell enabled whether it is actually needed or not. needsTemplateHaskellOrQQ :: ModuleGraph -> Bool needsTemplateHaskellOrQQ mg = mg_needs_th_or_qq mg -- | Map a function 'f' over all the 'ModSummaries'. -- To preserve invariants 'f' can't change the isBoot status. mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph mapMG f mg@ModuleGraph{..} = mg { mg_mss = map f mg_mss , mg_non_boot = mapModuleEnv f mg_non_boot } mgBootModules :: ModuleGraph -> ModuleSet mgBootModules ModuleGraph{..} = mg_boot mgModSummaries :: ModuleGraph -> [ModSummary] mgModSummaries = mg_mss mgElemModule :: ModuleGraph -> Module -> Bool mgElemModule ModuleGraph{..} m = elemModuleEnv m mg_non_boot -- | Look up a ModSummary in the ModuleGraph mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary mgLookupModule ModuleGraph{..} m = lookupModuleEnv mg_non_boot m emptyMG :: ModuleGraph emptyMG = ModuleGraph [] emptyModuleEnv emptyModuleSet False isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool isTemplateHaskellOrQQNonBoot ms = (xopt LangExt.TemplateHaskell (ms_hspp_opts ms) || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) && not (isBootSummary ms) -- | Add a ModSummary to ModuleGraph. Assumes that the new ModSummary is -- not an element of the ModuleGraph. extendMG :: ModuleGraph -> ModSummary -> ModuleGraph extendMG ModuleGraph{..} ms = ModuleGraph { mg_mss = ms:mg_mss , mg_non_boot = if isBootSummary ms then mg_non_boot else extendModuleEnv mg_non_boot (ms_mod ms) ms , mg_boot = if isBootSummary ms then extendModuleSet mg_boot (ms_mod ms) else mg_boot , mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms } mkModuleGraph :: [ModSummary] -> ModuleGraph mkModuleGraph = foldr (flip extendMG) emptyMG -- | A single node in a 'ModuleGraph'. The nodes of the module graph -- are one of: -- -- * A regular Haskell source module -- * A hi-boot source module -- data ModSummary = ModSummary { ms_mod :: Module, -- ^ Identity of the module ms_hsc_src :: HscSource, -- ^ The module source either plain Haskell or hs-boot ms_location :: ModLocation, -- ^ Location of the various files belonging to the module ms_hs_date :: UTCTime, -- ^ Timestamp of source file ms_obj_date :: Maybe UTCTime, -- ^ Timestamp of object, if we have one ms_iface_date :: Maybe UTCTime, -- ^ Timestamp of hi file, if we *only* are typechecking (it is -- 'Nothing' otherwise. -- See Note [Recompilation checking in -fno-code mode] and #9243 ms_hie_date :: Maybe UTCTime, -- ^ Timestamp of hie file, if we have one ms_srcimps :: [(Maybe FastString, Located ModuleName)], -- ^ Source imports of the module ms_textual_imps :: [(Maybe FastString, Located ModuleName)], -- ^ Non-source imports of the module from the module *text* ms_parsed_mod :: Maybe HsParsedModule, -- ^ The parsed, nonrenamed source, if we have it. This is also -- used to support "inline module syntax" in Backpack files. ms_hspp_file :: FilePath, -- ^ Filename of preprocessed source file ms_hspp_opts :: DynFlags, -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@ -- pragmas in the modules source code ms_hspp_buf :: Maybe StringBuffer -- ^ The actual preprocessed source, if we have it } ms_installed_mod :: ModSummary -> InstalledModule ms_installed_mod = fst . splitModuleInsts . ms_mod ms_mod_name :: ModSummary -> ModuleName ms_mod_name = moduleName . ms_mod ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)] ms_imps ms = ms_textual_imps ms ++ map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms)) where mk_additional_import mod_nm = (Nothing, noLoc mod_nm) home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName] home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps, isLocal mb_pkg ] where isLocal Nothing = True isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special isLocal _ = False ms_home_allimps :: ModSummary -> [ModuleName] ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) -- | Like 'ms_home_imps', but for SOURCE imports. ms_home_srcimps :: ModSummary -> [Located ModuleName] ms_home_srcimps = home_imps . ms_srcimps -- | All of the (possibly) home module imports from a -- 'ModSummary'; that is to say, each of these module names -- could be a home import if an appropriately named file -- existed. (This is in contrast to package qualified -- imports, which are guaranteed not to be home imports.) ms_home_imps :: ModSummary -> [Located ModuleName] ms_home_imps = home_imps . ms_imps -- The ModLocation contains both the original source filename and the -- filename of the cleaned-up source file after all preprocessing has been -- done. The point is that the summariser will have to cpp/unlit/whatever -- all files anyway, and there's no point in doing this twice -- just -- park the result in a temp file, put the name of it in the location, -- and let @compile@ read from that file on the way back up. -- The ModLocation is stable over successive up-sweeps in GHCi, wheres -- the ms_hs_date and imports can, of course, change msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms)) msHiFilePath ms = ml_hi_file (ms_location ms) msObjFilePath ms = ml_obj_file (ms_location ms) msDynObjFilePath :: ModSummary -> DynFlags -> FilePath msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms) -- | Did this 'ModSummary' originate from a hs-boot file? isBootSummary :: ModSummary -> Bool isBootSummary ms = ms_hsc_src ms == HsBootFile instance Outputable ModSummary where ppr ms = sep [text "ModSummary {", nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), text "ms_mod =" <+> ppr (ms_mod ms) <> text (hscSourceString (ms_hsc_src ms)) <> comma, text "ms_textual_imps =" <+> ppr (ms_textual_imps ms), text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), char '}' ] showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String showModMsg dflags target recomp mod_summary = showSDoc dflags $ if gopt Opt_HideSourcePaths dflags then text mod_str else hsep $ [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ') , char '(' , text (op $ msHsFilePath mod_summary) <> char ',' ] ++ if gopt Opt_BuildDynamicToo dflags then [ text obj_file <> char ',' , text dyn_file , char ')' ] else [ text obj_file, char ')' ] where op = normalise mod = moduleName (ms_mod mod_summary) mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) dyn_file = op $ msDynObjFilePath mod_summary dflags obj_file = case target of HscInterpreted | recomp -> "interpreted" HscNothing -> "nothing" _ -> (op $ msObjFilePath mod_summary) {- ************************************************************************ * * \subsection{Recompilation} * * ************************************************************************ -} -- | Indicates whether a given module's source has been modified since it -- was last compiled. data SourceModified = SourceModified -- ^ the source has been modified | SourceUnmodified -- ^ the source has not been modified. Compilation may or may -- not be necessary, depending on whether any dependencies have -- changed since we last compiled. | SourceUnmodifiedAndStable -- ^ the source has not been modified, and furthermore all of -- its (transitive) dependencies are up to date; it definitely -- does not need to be recompiled. This is important for two -- reasons: (a) we can omit the version check in checkOldIface, -- and (b) if the module used TH splices we don't need to force -- recompilation. {- ************************************************************************ * * \subsection{Hpc Support} * * ************************************************************************ -} -- | Information about a modules use of Haskell Program Coverage data HpcInfo = HpcInfo { hpcInfoTickCount :: Int , hpcInfoHash :: Int } | NoHpcInfo { hpcUsed :: AnyHpcUsage -- ^ Is hpc used anywhere on the module \*tree\*? } -- | This is used to signal if one of my imports used HPC instrumentation -- even if there is no module-local HPC usage type AnyHpcUsage = Bool emptyHpcInfo :: AnyHpcUsage -> HpcInfo emptyHpcInfo = NoHpcInfo -- | Find out if HPC is used by this module or any of the modules -- it depends upon isHpcUsed :: HpcInfo -> AnyHpcUsage isHpcUsed (HpcInfo {}) = True isHpcUsed (NoHpcInfo { hpcUsed = used }) = used {- ************************************************************************ * * \subsection{Safe Haskell Support} * * ************************************************************************ This stuff here is related to supporting the Safe Haskell extension, primarily about storing under what trust type a module has been compiled. -} -- | Is an import a safe import? type IsSafeImport = Bool -- | Safe Haskell information for 'ModIface' -- Simply a wrapper around SafeHaskellMode to sepperate iface and flags newtype IfaceTrustInfo = TrustInfo SafeHaskellMode getSafeMode :: IfaceTrustInfo -> SafeHaskellMode getSafeMode (TrustInfo x) = x setSafeMode :: SafeHaskellMode -> IfaceTrustInfo setSafeMode = TrustInfo noIfaceTrustInfo :: IfaceTrustInfo noIfaceTrustInfo = setSafeMode Sf_None trustInfoToNum :: IfaceTrustInfo -> Word8 trustInfoToNum it = case getSafeMode it of Sf_None -> 0 Sf_Unsafe -> 1 Sf_Trustworthy -> 2 Sf_Safe -> 3 Sf_SafeInferred -> 4 Sf_Ignore -> 0 numToTrustInfo :: Word8 -> IfaceTrustInfo numToTrustInfo 0 = setSafeMode Sf_None numToTrustInfo 1 = setSafeMode Sf_Unsafe numToTrustInfo 2 = setSafeMode Sf_Trustworthy numToTrustInfo 3 = setSafeMode Sf_Safe numToTrustInfo 4 = setSafeMode Sf_SafeInferred numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" instance Outputable IfaceTrustInfo where ppr (TrustInfo Sf_None) = text "none" ppr (TrustInfo Sf_Ignore) = text "none" ppr (TrustInfo Sf_Unsafe) = text "unsafe" ppr (TrustInfo Sf_Trustworthy) = text "trustworthy" ppr (TrustInfo Sf_Safe) = text "safe" ppr (TrustInfo Sf_SafeInferred) = text "safe-inferred" instance Binary IfaceTrustInfo where put_ bh iftrust = putByte bh $ trustInfoToNum iftrust get bh = getByte bh >>= (return . numToTrustInfo) {- ************************************************************************ * * \subsection{Parser result} * * ************************************************************************ -} data HsParsedModule = HsParsedModule { hpm_module :: Located (HsModule GhcPs), hpm_src_files :: [FilePath], -- ^ extra source files (e.g. from #includes). The lexer collects -- these from '# ' pragmas, which the C preprocessor -- leaves behind. These files and their timestamps are stored in -- the .hi file, so that we can force recompilation if any of -- them change (#3589) hpm_annotations :: ApiAnns -- See note [Api annotations] in ApiAnnotation.hs } {- ************************************************************************ * * \subsection{Linkable stuff} * * ************************************************************************ This stuff is in here, rather than (say) in Linker.hs, because the Linker.hs stuff is the *dynamic* linker, and isn't present in a stage-1 compiler -} isObjectLinkable :: Linkable -> Bool isObjectLinkable l = not (null unlinked) && all isObject unlinked where unlinked = linkableUnlinked l -- A linkable with no Unlinked's is treated as a BCO. We can -- generate a linkable with no Unlinked's as a result of -- compiling a module in HscNothing mode, and this choice -- happens to work well with checkStability in module GHC. linkableObjs :: Linkable -> [FilePath] linkableObjs l = [ f | DotO f <- linkableUnlinked l ] ------------------------------------------- -- | Is this an actual file on disk we can link in somehow? isObject :: Unlinked -> Bool isObject (DotO _) = True isObject (DotA _) = True isObject (DotDLL _) = True isObject _ = False -- | Is this a bytecode linkable with no file on disk? isInterpretable :: Unlinked -> Bool isInterpretable = not . isObject -- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object nameOfObject :: Unlinked -> FilePath nameOfObject (DotO fn) = fn nameOfObject (DotA fn) = fn nameOfObject (DotDLL fn) = fn nameOfObject other = pprPanic "nameOfObject" (ppr other) -- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable byteCodeOfObject :: Unlinked -> CompiledByteCode byteCodeOfObject (BCOs bc _) = bc byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) ------------------------------------------- -- | A list of conlikes which represents a complete pattern match. -- These arise from @COMPLETE@ signatures. -- See Note [Implementation of COMPLETE signatures] data CompleteMatch = CompleteMatch { completeMatchConLikes :: [Name] -- ^ The ConLikes that form a covering family -- (e.g. Nothing, Just) , completeMatchTyCon :: Name -- ^ The TyCon that they cover (e.g. Maybe) } instance Outputable CompleteMatch where ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl <+> dcolon <+> ppr ty -- | A map keyed by the 'completeMatchTyCon'. -- See Note [Implementation of COMPLETE signatures] type CompleteMatchMap = UniqFM [CompleteMatch] mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap mkCompleteMatchMap = extendCompleteMatchMap emptyUFM extendCompleteMatchMap :: CompleteMatchMap -> [CompleteMatch] -> CompleteMatchMap extendCompleteMatchMap = foldl' insertMatch where insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c] {- Note [Implementation of COMPLETE signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A COMPLETE signature represents a set of conlikes (i.e., constructors or pattern synonyms) such that if they are all pattern-matched against in a function, it gives rise to a total function. An example is: newtype Boolean = Boolean Int pattern F, T :: Boolean pattern F = Boolean 0 pattern T = Boolean 1 {-# COMPLETE F, T #-} -- This is a total function booleanToInt :: Boolean -> Int booleanToInt F = 0 booleanToInt T = 1 COMPLETE sets are represented internally in GHC with the CompleteMatch data type. For example, {-# COMPLETE F, T #-} would be represented as: CompleteMatch { complateMatchConLikes = [F, T] , completeMatchTyCon = Boolean } Note that GHC was able to infer the completeMatchTyCon (Boolean), but for the cases in which it's ambiguous, you can also explicitly specify it in the source language by writing this: {-# COMPLETE F, T :: Boolean #-} For efficiency purposes, GHC collects all of the CompleteMatches that it knows about into a CompleteMatchMap, which is a map that is keyed by the completeMatchTyCon. In other words, you could have a multiple COMPLETE sets for the same TyCon: {-# COMPLETE F, T1 :: Boolean #-} {-# COMPLETE F, T2 :: Boolean #-} And looking up the values in the CompleteMatchMap associated with Boolean would give you [CompleteMatch [F, T1] Boolean, CompleteMatch [F, T2] Boolean]. dsGetCompleteMatches in DsMeta accomplishes this lookup. Also see Note [Typechecking Complete Matches] in TcBinds for a more detailed explanation for how GHC ensures that all the conlikes in a COMPLETE set are consistent. -} -- | Foreign language of the phase if the phase deals with a foreign code phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang phaseForeignLanguage phase = case phase of Phase.Cc -> Just LangC Phase.Ccxx -> Just LangCxx Phase.Cobjc -> Just LangObjc Phase.Cobjcxx -> Just LangObjcxx Phase.HCc -> Just LangC Phase.As _ -> Just LangAsm Phase.MergeForeign -> Just RawObject _ -> Nothing ------------------------------------------- -- Take care, this instance only forces to the degree necessary to -- avoid major space leaks. instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23) = rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq` f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq` rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23 ghc-lib-parser-8.10.2.20200808/compiler/utils/IOEnv.hs0000644000000000000000000001611613713635745020002 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} -- -- (c) The University of Glasgow 2002-2006 -- -- The IO Monad with an environment -- -- The environment is passed around as a Reader monad but -- as its in the IO monad, mutable references can be used -- for updating state. -- module IOEnv ( IOEnv, -- Instance of Monad -- Monad utilities module MonadUtils, -- Errors failM, failWithM, IOEnvFailure(..), -- Getting at the environment getEnv, setEnv, updEnv, runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_, tryM, tryAllM, tryMostM, fixM, -- I/O operations IORef, newMutVar, readMutVar, writeMutVar, updMutVar, atomicUpdMutVar, atomicUpdMutVar' ) where import GhcPrelude import DynFlags import Exception import Module import Panic import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef, atomicModifyIORef, atomicModifyIORef' ) import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO ( fixIO ) import Control.Monad import qualified Control.Monad.Fail as MonadFail import MonadUtils import Control.Applicative (Alternative(..)) ---------------------------------------------------------------------- -- Defining the monad type ---------------------------------------------------------------------- newtype IOEnv env a = IOEnv (env -> IO a) deriving (Functor) unIOEnv :: IOEnv env a -> (env -> IO a) unIOEnv (IOEnv m) = m instance Monad (IOEnv m) where (>>=) = thenM (>>) = (*>) #if !MIN_VERSION_base(4,13,0) fail = MonadFail.fail #endif instance MonadFail.MonadFail (IOEnv m) where fail _ = failM -- Ignore the string instance Applicative (IOEnv m) where pure = returnM IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env ) (*>) = thenM_ returnM :: a -> IOEnv env a returnM a = IOEnv (\ _ -> return a) thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ; unIOEnv (f r) env }) thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env }) failM :: IOEnv env a failM = IOEnv (\ _ -> throwIO IOEnvFailure) failWithM :: String -> IOEnv env a failWithM s = IOEnv (\ _ -> ioError (userError s)) data IOEnvFailure = IOEnvFailure instance Show IOEnvFailure where show IOEnvFailure = "IOEnv failure" instance Exception IOEnvFailure instance ExceptionMonad (IOEnv a) where gcatch act handle = IOEnv $ \s -> unIOEnv act s `gcatch` \e -> unIOEnv (handle e) s gmask f = IOEnv $ \s -> gmask $ \io_restore -> let g_restore (IOEnv m) = IOEnv $ \s -> io_restore (m s) in unIOEnv (f g_restore) s instance ContainsDynFlags env => HasDynFlags (IOEnv env) where getDynFlags = do env <- getEnv return $! extractDynFlags env instance ContainsModule env => HasModule (IOEnv env) where getModule = do env <- getEnv return $ extractModule env ---------------------------------------------------------------------- -- Fundamental combinators specific to the monad ---------------------------------------------------------------------- --------------------------- runIOEnv :: env -> IOEnv env a -> IO a runIOEnv env (IOEnv m) = m env --------------------------- {-# NOINLINE fixM #-} -- Aargh! Not inlining fixM alleviates a space leak problem. -- Normally fixM is used with a lazy tuple match: if the optimiser is -- shown the definition of fixM, it occasionally transforms the code -- in such a way that the code generator doesn't spot the selector -- thunks. Sigh. fixM :: (a -> IOEnv env a) -> IOEnv env a fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env)) --------------------------- tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r) -- Reflect UserError exceptions (only) into IOEnv monad -- Other exceptions are not caught; they are simply propagated as exns -- -- The idea is that errors in the program being compiled will give rise -- to UserErrors. But, say, pattern-match failures in GHC itself should -- not be caught here, else they'll be reported as errors in the program -- begin compiled! tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env)) tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a) tryIOEnvFailure = try -- XXX We shouldn't be catching everything, e.g. timeouts tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r) -- Catch *all* exceptions -- This is used when running a Template-Haskell splice, when -- even a pattern-match failure is a programmer error tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env)) tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r) tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env)) --------------------------- unsafeInterleaveM :: IOEnv env a -> IOEnv env a unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env)) uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env)) ---------------------------------------------------------------------- -- Alternative/MonadPlus ---------------------------------------------------------------------- instance Alternative (IOEnv env) where empty = IOEnv (const empty) m <|> n = IOEnv (\env -> unIOEnv m env <|> unIOEnv n env) instance MonadPlus (IOEnv env) ---------------------------------------------------------------------- -- Accessing input/output ---------------------------------------------------------------------- instance MonadIO (IOEnv env) where liftIO io = IOEnv (\ _ -> io) newMutVar :: a -> IOEnv env (IORef a) newMutVar val = liftIO (newIORef val) writeMutVar :: IORef a -> a -> IOEnv env () writeMutVar var val = liftIO (writeIORef var val) readMutVar :: IORef a -> IOEnv env a readMutVar var = liftIO (readIORef var) updMutVar :: IORef a -> (a -> a) -> IOEnv env () updMutVar var upd = liftIO (modifyIORef var upd) -- | Atomically update the reference. Does not force the evaluation of the -- new variable contents. For strict update, use 'atomicUpdMutVar''. atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd) -- | Strict variant of 'atomicUpdMutVar'. atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b atomicUpdMutVar' var upd = liftIO (atomicModifyIORef' var upd) ---------------------------------------------------------------------- -- Accessing the environment ---------------------------------------------------------------------- getEnv :: IOEnv env env {-# INLINE getEnv #-} getEnv = IOEnv (\ env -> return env) -- | Perform a computation with a different environment setEnv :: env' -> IOEnv env' a -> IOEnv env a {-# INLINE setEnv #-} setEnv new_env (IOEnv m) = IOEnv (\ _ -> m new_env) -- | Perform a computation with an altered environment updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a {-# INLINE updEnv #-} updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env)) ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/Id.hs0000644000000000000000000010352013713635744020317 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[Id]{@Ids@: Value and constructor identifiers} -} {-# LANGUAGE CPP #-} -- | -- #name_types# -- GHC uses several kinds of name internally: -- -- * 'OccName.OccName': see "OccName#name_types" -- -- * 'RdrName.RdrName': see "RdrName#name_types" -- -- * 'Name.Name': see "Name#name_types" -- -- * 'Id.Id' represents names that not only have a 'Name.Name' but also a 'TyCoRep.Type' and some additional -- details (a 'IdInfo.IdInfo' and one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that -- are added, modified and inspected by various compiler passes. These 'Var.Var' names may either -- be global or local, see "Var#globalvslocal" -- -- * 'Var.Var': see "Var#name_types" module Id ( -- * The main types Var, Id, isId, -- * In and Out variants InVar, InId, OutVar, OutId, -- ** Simple construction mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar, mkLocalIdOrCoVarWithInfo, mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId, mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM, mkUserLocal, mkUserLocalOrCoVar, mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, mkWorkerId, -- ** Taking an Id apart idName, idType, idUnique, idInfo, idDetails, recordSelectorTyCon, -- ** Modifying an Id setIdName, setIdUnique, Id.setIdType, setIdExported, setIdNotExported, globaliseId, localiseId, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, zapIdUsedOnceInfo, zapIdTailCallInfo, zapFragileIdInfo, zapIdStrictness, zapStableUnfolding, transferPolyIdInfo, -- ** Predicates on Ids isImplicitId, isDeadBinder, isStrictId, isExportedId, isLocalId, isGlobalId, isRecordSelector, isNaughtyRecordSelector, isPatSynRecordSelector, isDataConRecordSelector, isClassOpId_maybe, isDFunId, isPrimOpId, isPrimOpId_maybe, isFCallId, isFCallId_maybe, isDataConWorkId, isDataConWorkId_maybe, isDataConWrapId, isDataConWrapId_maybe, isDataConId_maybe, idDataCon, isConLikeId, isBottomingId, idIsFrom, hasNoBinding, -- ** Join variables JoinId, isJoinId, isJoinId_maybe, idJoinArity, asJoinId, asJoinId_maybe, zapJoinId, -- ** Inline pragma stuff idInlinePragma, setInlinePragma, modifyInlinePragma, idInlineActivation, setInlineActivation, idRuleMatchInfo, -- ** One-shot lambdas isOneShotBndr, isProbablyOneShotLambda, setOneShotLambda, clearOneShotLambda, updOneShotInfo, setIdOneShotInfo, isStateHackType, stateHackOneShot, typeOneShot, -- ** Reading 'IdInfo' fields idArity, idCallArity, idFunRepArity, idUnfolding, realIdUnfolding, idSpecialisation, idCoreRules, idHasRules, idCafInfo, idOneShotInfo, idStateHackOneShotInfo, idOccInfo, isNeverLevPolyId, -- ** Writing 'IdInfo' fields setIdUnfolding, setCaseBndrEvald, setIdArity, setIdCallArity, setIdSpecialisation, setIdCafInfo, setIdOccInfo, zapIdOccInfo, setIdDemandInfo, setIdStrictness, idDemandInfo, idStrictness, ) where #include "GhclibHsVersions.h" import GhcPrelude import DynFlags import CoreSyn ( CoreRule, isStableUnfolding, evaldUnfolding, isCompulsoryUnfolding, Unfolding( NoUnfolding ) ) import IdInfo import BasicTypes -- Imported and re-exported import Var( Id, CoVar, JoinId, InId, InVar, OutId, OutVar, idInfo, idDetails, setIdDetails, globaliseId, varType, isId, isLocalId, isGlobalId, isExportedId ) import qualified Var import Type import RepType import TysPrim import DataCon import Demand import Name import Module import Class import {-# SOURCE #-} PrimOp (PrimOp) import ForeignCall import Maybes import SrcLoc import Outputable import Unique import UniqSupply import FastString import Util -- infixl so you can say (id `set` a `set` b) infixl 1 `setIdUnfolding`, `setIdArity`, `setIdCallArity`, `setIdOccInfo`, `setIdOneShotInfo`, `setIdSpecialisation`, `setInlinePragma`, `setInlineActivation`, `idCafInfo`, `setIdDemandInfo`, `setIdStrictness`, `asJoinId`, `asJoinId_maybe` {- ************************************************************************ * * \subsection{Basic Id manipulation} * * ************************************************************************ -} idName :: Id -> Name idName = Var.varName idUnique :: Id -> Unique idUnique = Var.varUnique idType :: Id -> Kind idType = Var.varType setIdName :: Id -> Name -> Id setIdName = Var.setVarName setIdUnique :: Id -> Unique -> Id setIdUnique = Var.setVarUnique -- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and -- reduce space usage setIdType :: Id -> Type -> Id setIdType id ty = seqType ty `seq` Var.setVarType id ty setIdExported :: Id -> Id setIdExported = Var.setIdExported setIdNotExported :: Id -> Id setIdNotExported = Var.setIdNotExported localiseId :: Id -> Id -- Make an Id with the same unique and type as the -- incoming Id, but with an *Internal* Name and *LocalId* flavour localiseId id | ASSERT( isId id ) isLocalId id && isInternalName name = id | otherwise = Var.mkLocalVar (idDetails id) (localiseName name) (idType id) (idInfo id) where name = idName id lazySetIdInfo :: Id -> IdInfo -> Id lazySetIdInfo = Var.lazySetIdInfo setIdInfo :: Id -> IdInfo -> Id setIdInfo id info = info `seq` (lazySetIdInfo id info) -- Try to avoid space leaks by seq'ing modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id modifyIdInfo fn id = setIdInfo id (fn (idInfo id)) -- maybeModifyIdInfo tries to avoid unnecessary thrashing maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info maybeModifyIdInfo Nothing id = id {- ************************************************************************ * * \subsection{Simple Id construction} * * ************************************************************************ Absolutely all Ids are made by mkId. It is just like Var.mkId, but in addition it pins free-tyvar-info onto the Id's type, where it can easily be found. Note [Free type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~ At one time we cached the free type variables of the type of an Id at the root of the type in a TyNote. The idea was to avoid repeating the free-type-variable calculation. But it turned out to slow down the compiler overall. I don't quite know why; perhaps finding free type variables of an Id isn't all that common whereas applying a substitution (which changes the free type variables) is more common. Anyway, we removed it in March 2008. -} -- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id mkGlobalId = Var.mkGlobalVar -- | Make a global 'Id' without any extra information at all mkVanillaGlobal :: Name -> Type -> Id mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo -- | Make a global 'Id' with no global information but some generic 'IdInfo' mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id mkVanillaGlobalWithInfo = mkGlobalId VanillaId -- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" mkLocalId :: Name -> Type -> Id mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo -- It's tempting to ASSERT( not (isCoVarType ty) ), but don't. Sometimes, -- the type is a panic. (Search invented_id) -- | Make a local CoVar mkLocalCoVar :: Name -> Type -> CoVar mkLocalCoVar name ty = ASSERT( isCoVarType ty ) Var.mkLocalVar CoVarId name ty vanillaIdInfo -- | Like 'mkLocalId', but checks the type to see if it should make a covar mkLocalIdOrCoVar :: Name -> Type -> Id mkLocalIdOrCoVar name ty | isCoVarType ty = mkLocalCoVar name ty | otherwise = mkLocalId name ty -- | Make a local id, with the IdDetails set to CoVarId if the type indicates -- so. mkLocalIdOrCoVarWithInfo :: Name -> Type -> IdInfo -> Id mkLocalIdOrCoVarWithInfo name ty info = Var.mkLocalVar details name ty info where details | isCoVarType ty = CoVarId | otherwise = VanillaId -- proper ids only; no covars! mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info -- Note [Free type variables] -- | Create a local 'Id' that is marked as exported. -- This prevents things attached to it from being removed as dead code. -- See Note [Exported LocalIds] mkExportedLocalId :: IdDetails -> Name -> Type -> Id mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo -- Note [Free type variables] mkExportedVanillaId :: Name -> Type -> Id mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo -- Note [Free type variables] -- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") -- that are created by the compiler out of thin air mkSysLocal :: FastString -> Unique -> Type -> Id mkSysLocal fs uniq ty = ASSERT( not (isCoVarType ty) ) mkLocalId (mkSystemVarName uniq fs) ty -- | Like 'mkSysLocal', but checks to see if we have a covar type mkSysLocalOrCoVar :: FastString -> Unique -> Type -> Id mkSysLocalOrCoVar fs uniq ty = mkLocalIdOrCoVar (mkSystemVarName uniq fs) ty mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty)) mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Type -> m Id mkSysLocalOrCoVarM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq ty)) -- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id mkUserLocal occ uniq ty loc = ASSERT( not (isCoVarType ty) ) mkLocalId (mkInternalName uniq occ loc) ty -- | Like 'mkUserLocal', but checks if we have a coercion type mkUserLocalOrCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id mkUserLocalOrCoVar occ uniq ty loc = mkLocalIdOrCoVar (mkInternalName uniq occ loc) ty {- Make some local @Ids@ for a template @CoreExpr@. These have bogus @Uniques@, but that's OK because the templates are supposed to be instantiated before use. -} -- | Workers get local names. "CoreTidy" will externalise these if necessary mkWorkerId :: Unique -> Id -> Type -> Id mkWorkerId uniq unwrkr ty = mkLocalIdOrCoVar (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty -- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings mkTemplateLocal :: Int -> Type -> Id mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) ty -- | Create a template local for a series of types mkTemplateLocals :: [Type] -> [Id] mkTemplateLocals = mkTemplateLocalsNum 1 -- | Create a template local for a series of type, but start from a specified template local mkTemplateLocalsNum :: Int -> [Type] -> [Id] mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys {- Note [Exported LocalIds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use mkExportedLocalId for things like - Dictionary functions (DFunId) - Wrapper and matcher Ids for pattern synonyms - Default methods for classes - Pattern-synonym matcher and builder Ids - etc They marked as "exported" in the sense that they should be kept alive even if apparently unused in other bindings, and not dropped as dead code by the occurrence analyser. (But "exported" here does not mean "brought into lexical scope by an import declaration". Indeed these things are always internal Ids that the user never sees.) It's very important that they are *LocalIds*, not GlobalIds, for lots of reasons: * We want to treat them as free variables for the purpose of dependency analysis (e.g. CoreFVs.exprFreeVars). * Look them up in the current substitution when we come across occurrences of them (in Subst.lookupIdSubst). Lacking this we can get an out-of-date unfolding, which can in turn make the simplifier go into an infinite loop (#9857) * Ensure that for dfuns that the specialiser does not float dict uses above their defns, which would prevent good simplifications happening. * The strictness analyser treats a occurrence of a GlobalId as imported and assumes it contains strictness in its IdInfo, which isn't true if the thing is bound in the same module as the occurrence. In CoreTidy we must make all these LocalIds into GlobalIds, so that in importing modules (in --make mode) we treat them as properly global. That is what is happening in, say tidy_insts in TidyPgm. ************************************************************************ * * \subsection{Special Ids} * * ************************************************************************ -} -- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise. recordSelectorTyCon :: Id -> RecSelParent recordSelectorTyCon id = case Var.idDetails id of RecSelId { sel_tycon = parent } -> parent _ -> panic "recordSelectorTyCon" isRecordSelector :: Id -> Bool isNaughtyRecordSelector :: Id -> Bool isPatSynRecordSelector :: Id -> Bool isDataConRecordSelector :: Id -> Bool isPrimOpId :: Id -> Bool isFCallId :: Id -> Bool isDataConWorkId :: Id -> Bool isDataConWrapId :: Id -> Bool isDFunId :: Id -> Bool isClassOpId_maybe :: Id -> Maybe Class isPrimOpId_maybe :: Id -> Maybe PrimOp isFCallId_maybe :: Id -> Maybe ForeignCall isDataConWorkId_maybe :: Id -> Maybe DataCon isDataConWrapId_maybe :: Id -> Maybe DataCon isRecordSelector id = case Var.idDetails id of RecSelId {} -> True _ -> False isDataConRecordSelector id = case Var.idDetails id of RecSelId {sel_tycon = RecSelData _} -> True _ -> False isPatSynRecordSelector id = case Var.idDetails id of RecSelId {sel_tycon = RecSelPatSyn _} -> True _ -> False isNaughtyRecordSelector id = case Var.idDetails id of RecSelId { sel_naughty = n } -> n _ -> False isClassOpId_maybe id = case Var.idDetails id of ClassOpId cls -> Just cls _other -> Nothing isPrimOpId id = case Var.idDetails id of PrimOpId _ -> True _ -> False isDFunId id = case Var.idDetails id of DFunId {} -> True _ -> False isPrimOpId_maybe id = case Var.idDetails id of PrimOpId op -> Just op _ -> Nothing isFCallId id = case Var.idDetails id of FCallId _ -> True _ -> False isFCallId_maybe id = case Var.idDetails id of FCallId call -> Just call _ -> Nothing isDataConWorkId id = case Var.idDetails id of DataConWorkId _ -> True _ -> False isDataConWorkId_maybe id = case Var.idDetails id of DataConWorkId con -> Just con _ -> Nothing isDataConWrapId id = case Var.idDetails id of DataConWrapId _ -> True _ -> False isDataConWrapId_maybe id = case Var.idDetails id of DataConWrapId con -> Just con _ -> Nothing isDataConId_maybe :: Id -> Maybe DataCon isDataConId_maybe id = case Var.idDetails id of DataConWorkId con -> Just con DataConWrapId con -> Just con _ -> Nothing isJoinId :: Var -> Bool -- It is convenient in SetLevels.lvlMFE to apply isJoinId -- to the free vars of an expression, so it's convenient -- if it returns False for type variables isJoinId id | isId id = case Var.idDetails id of JoinId {} -> True _ -> False | otherwise = False isJoinId_maybe :: Var -> Maybe JoinArity isJoinId_maybe id | isId id = ASSERT2( isId id, ppr id ) case Var.idDetails id of JoinId arity -> Just arity _ -> Nothing | otherwise = Nothing idDataCon :: Id -> DataCon -- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer. -- -- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id) hasNoBinding :: Id -> Bool -- ^ Returns @True@ of an 'Id' which may not have a -- binding, even though it is defined in this module. -- Data constructor workers used to be things of this kind, but -- they aren't any more. Instead, we inject a binding for -- them at the CorePrep stage. -- -- 'PrimOpId's also used to be of this kind. See Note [Primop wrappers] in PrimOp.hs. -- for the history of this. -- -- Note that CorePrep currently eta expands things no-binding things and this -- can cause quite subtle bugs. See Note [Eta expansion of hasNoBinding things -- in CorePrep] in CorePrep for details. -- -- EXCEPT: unboxed tuples, which definitely have no binding hasNoBinding id = case Var.idDetails id of PrimOpId _ -> False -- See Note [Primop wrappers] in PrimOp.hs FCallId _ -> True DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc _ -> isCompulsoryUnfolding (idUnfolding id) -- See Note [Levity-polymorphic Ids] isImplicitId :: Id -> Bool -- ^ 'isImplicitId' tells whether an 'Id's info is implied by other -- declarations, so we don't need to put its signature in an interface -- file, even if it's mentioned in some other interface unfolding. isImplicitId id = case Var.idDetails id of FCallId {} -> True ClassOpId {} -> True PrimOpId {} -> True DataConWorkId {} -> True DataConWrapId {} -> True -- These are implied by their type or class decl; -- remember that all type and class decls appear in the interface file. -- The dfun id is not an implicit Id; it must *not* be omitted, because -- it carries version info for the instance decl _ -> False idIsFrom :: Module -> Id -> Bool idIsFrom mod id = nameIsLocalOrFrom mod (idName id) {- Note [Levity-polymorphic Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some levity-polymorphic Ids must be applied and and inlined, not left un-saturated. Example: unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b This has a compulsory unfolding because we can't lambda-bind those arguments. But the compulsory unfolding may leave levity-polymorphic lambdas if it is not applied to enough arguments; e.g. (#14561) bad :: forall (a :: TYPE r). a -> a bad = unsafeCoerce# The desugar has special magic to detect such cases: DsExpr.badUseOfLevPolyPrimop. And we want that magic to apply to levity-polymorphic compulsory-inline things. The easiest way to do this is for hasNoBinding to return True of all things that have compulsory unfolding. Some Ids with a compulsory unfolding also have a binding, but it does not harm to say they don't here, and its a very simple way to fix #14561. -} isDeadBinder :: Id -> Bool isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) | otherwise = False -- TyVars count as not dead {- ************************************************************************ * * Join variables * * ************************************************************************ -} idJoinArity :: JoinId -> JoinArity idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id) asJoinId :: Id -> JoinArity -> JoinId asJoinId id arity = WARN(not (isLocalId id), text "global id being marked as join var:" <+> ppr id) WARN(not (is_vanilla_or_join id), ppr id <+> pprIdDetails (idDetails id)) id `setIdDetails` JoinId arity where is_vanilla_or_join id = case Var.idDetails id of VanillaId -> True JoinId {} -> True _ -> False zapJoinId :: Id -> Id -- May be a regular id already zapJoinId jid | isJoinId jid = zapIdTailCallInfo (jid `setIdDetails` VanillaId) -- Core Lint may complain if still marked -- as AlwaysTailCalled | otherwise = jid asJoinId_maybe :: Id -> Maybe JoinArity -> Id asJoinId_maybe id (Just arity) = asJoinId id arity asJoinId_maybe id Nothing = zapJoinId id {- ************************************************************************ * * \subsection{IdInfo stuff} * * ************************************************************************ -} --------------------------------- -- ARITY idArity :: Id -> Arity idArity id = arityInfo (idInfo id) setIdArity :: Id -> Arity -> Id setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id idCallArity :: Id -> Arity idCallArity id = callArityInfo (idInfo id) setIdCallArity :: Id -> Arity -> Id setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id idFunRepArity :: Id -> RepArity idFunRepArity x = countFunRepArgs (idArity x) (idType x) -- | Returns true if an application to n args would diverge isBottomingId :: Var -> Bool isBottomingId v | isId v = isBottomingSig (idStrictness v) | otherwise = False -- | Accesses the 'Id''s 'strictnessInfo'. idStrictness :: Id -> StrictSig idStrictness id = strictnessInfo (idInfo id) setIdStrictness :: Id -> StrictSig -> Id setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id zapIdStrictness :: Id -> Id zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id -- | This predicate says whether the 'Id' has a strict demand placed on it or -- has a type such that it can always be evaluated strictly (i.e an -- unlifted type, as of GHC 7.6). We need to -- check separately whether the 'Id' has a so-called \"strict type\" because if -- the demand for the given @id@ hasn't been computed yet but @id@ has a strict -- type, we still want @isStrictId id@ to be @True@. isStrictId :: Id -> Bool isStrictId id = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) not (isJoinId id) && ( (isStrictType (idType id)) || -- Take the best of both strictnesses - old and new (isStrictDmd (idDemandInfo id)) ) --------------------------------- -- UNFOLDING idUnfolding :: Id -> Unfolding -- Do not expose the unfolding of a loop breaker! idUnfolding id | isStrongLoopBreaker (occInfo info) = NoUnfolding | otherwise = unfoldingInfo info where info = idInfo id realIdUnfolding :: Id -> Unfolding -- Expose the unfolding if there is one, including for loop breakers realIdUnfolding id = unfoldingInfo (idInfo id) setIdUnfolding :: Id -> Unfolding -> Id setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id idDemandInfo :: Id -> Demand idDemandInfo id = demandInfo (idInfo id) setIdDemandInfo :: Id -> Demand -> Id setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id setCaseBndrEvald :: StrictnessMark -> Id -> Id -- Used for variables bound by a case expressions, both the case-binder -- itself, and any pattern-bound variables that are argument of a -- strict constructor. It just marks the variable as already-evaluated, -- so that (for example) a subsequent 'seq' can be dropped setCaseBndrEvald str id | isMarkedStrict str = id `setIdUnfolding` evaldUnfolding | otherwise = id --------------------------------- -- SPECIALISATION -- See Note [Specialisations and RULES in IdInfo] in IdInfo.hs idSpecialisation :: Id -> RuleInfo idSpecialisation id = ruleInfo (idInfo id) idCoreRules :: Id -> [CoreRule] idCoreRules id = ruleInfoRules (idSpecialisation id) idHasRules :: Id -> Bool idHasRules id = not (isEmptyRuleInfo (idSpecialisation id)) setIdSpecialisation :: Id -> RuleInfo -> Id setIdSpecialisation id spec_info = modifyIdInfo (`setRuleInfo` spec_info) id --------------------------------- -- CAF INFO idCafInfo :: Id -> CafInfo idCafInfo id = cafInfo (idInfo id) setIdCafInfo :: Id -> CafInfo -> Id setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id --------------------------------- -- Occurrence INFO idOccInfo :: Id -> OccInfo idOccInfo id = occInfo (idInfo id) setIdOccInfo :: Id -> OccInfo -> Id setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id zapIdOccInfo :: Id -> Id zapIdOccInfo b = b `setIdOccInfo` noOccInfo {- --------------------------------- -- INLINING The inline pragma tells us to be very keen to inline this Id, but it's still OK not to if optimisation is switched off. -} idInlinePragma :: Id -> InlinePragma idInlinePragma id = inlinePragInfo (idInfo id) setInlinePragma :: Id -> InlinePragma -> Id setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id idInlineActivation :: Id -> Activation idInlineActivation id = inlinePragmaActivation (idInlinePragma id) setInlineActivation :: Id -> Activation -> Id setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act) idRuleMatchInfo :: Id -> RuleMatchInfo idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id) isConLikeId :: Id -> Bool isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id) {- --------------------------------- -- ONE-SHOT LAMBDAS -} idOneShotInfo :: Id -> OneShotInfo idOneShotInfo id = oneShotInfo (idInfo id) -- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account -- See Note [The state-transformer hack] in CoreArity idStateHackOneShotInfo :: Id -> OneShotInfo idStateHackOneShotInfo id | isStateHackType (idType id) = stateHackOneShot | otherwise = idOneShotInfo id -- | Returns whether the lambda associated with the 'Id' is certainly applied at most once -- This one is the "business end", called externally. -- It works on type variables as well as Ids, returning True -- Its main purpose is to encapsulate the Horrible State Hack -- See Note [The state-transformer hack] in CoreArity isOneShotBndr :: Var -> Bool isOneShotBndr var | isTyVar var = True | OneShotLam <- idStateHackOneShotInfo var = True | otherwise = False -- | Should we apply the state hack to values of this 'Type'? stateHackOneShot :: OneShotInfo stateHackOneShot = OneShotLam typeOneShot :: Type -> OneShotInfo typeOneShot ty | isStateHackType ty = stateHackOneShot | otherwise = NoOneShotInfo isStateHackType :: Type -> Bool isStateHackType ty | hasNoStateHack unsafeGlobalDynFlags = False | otherwise = case tyConAppTyCon_maybe ty of Just tycon -> tycon == statePrimTyCon _ -> False -- This is a gross hack. It claims that -- every function over realWorldStatePrimTy is a one-shot -- function. This is pretty true in practice, and makes a big -- difference. For example, consider -- a `thenST` \ r -> ...E... -- The early full laziness pass, if it doesn't know that r is one-shot -- will pull out E (let's say it doesn't mention r) to give -- let lvl = E in a `thenST` \ r -> ...lvl... -- When `thenST` gets inlined, we end up with -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... -- and we don't re-inline E. -- -- It would be better to spot that r was one-shot to start with, but -- I don't want to rely on that. -- -- Another good example is in fill_in in PrelPack.hs. We should be able to -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. isProbablyOneShotLambda :: Id -> Bool isProbablyOneShotLambda id = case idStateHackOneShotInfo id of OneShotLam -> True NoOneShotInfo -> False setOneShotLambda :: Id -> Id setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id clearOneShotLambda :: Id -> Id clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id setIdOneShotInfo :: Id -> OneShotInfo -> Id setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id updOneShotInfo :: Id -> OneShotInfo -> Id -- Combine the info in the Id with new info updOneShotInfo id one_shot | do_upd = setIdOneShotInfo id one_shot | otherwise = id where do_upd = case (idOneShotInfo id, one_shot) of (NoOneShotInfo, _) -> True (OneShotLam, _) -> False -- The OneShotLambda functions simply fiddle with the IdInfo flag -- But watch out: this may change the type of something else -- f = \x -> e -- If we change the one-shot-ness of x, f's type changes zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id zapLamIdInfo :: Id -> Id zapLamIdInfo = zapInfo zapLamInfo zapFragileIdInfo :: Id -> Id zapFragileIdInfo = zapInfo zapFragileInfo zapIdDemandInfo :: Id -> Id zapIdDemandInfo = zapInfo zapDemandInfo zapIdUsageInfo :: Id -> Id zapIdUsageInfo = zapInfo zapUsageInfo zapIdUsageEnvInfo :: Id -> Id zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo zapIdUsedOnceInfo :: Id -> Id zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo zapIdTailCallInfo :: Id -> Id zapIdTailCallInfo = zapInfo zapTailCallInfo zapStableUnfolding :: Id -> Id zapStableUnfolding id | isStableUnfolding (realIdUnfolding id) = setIdUnfolding id NoUnfolding | otherwise = id {- Note [transferPolyIdInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~ This transfer is used in three places: FloatOut (long-distance let-floating) SimplUtils.abstractFloats (short-distance let-floating) StgLiftLams (selectively lambda-lift local functions to top-level) Consider the short-distance let-floating: f = /\a. let g = rhs in ... Then if we float thus g' = /\a. rhs f = /\a. ...[g' a/g].... we *do not* want to lose g's * strictness information * arity * inline pragma (though that is bit more debatable) * occurrence info Mostly this is just an optimisation, but it's *vital* to transfer the occurrence info. Consider NonRec { f = /\a. let Rec { g* = ..g.. } in ... } where the '*' means 'LoopBreaker'. Then if we float we must get Rec { g'* = /\a. ...(g' a)... } NonRec { f = /\a. ...[g' a/g]....} where g' is also marked as LoopBreaker. If not, terrible things can happen if we re-simplify the binding (and the Simplifier does sometimes simplify a term twice); see #4345. It's not so simple to retain * worker info * rules so we simply discard those. Sooner or later this may bite us. If we abstract wrt one or more *value* binders, we must modify the arity and strictness info before transferring it. E.g. f = \x. e --> g' = \y. \x. e + substitute (g' y) for g Notice that g' has an arity one more than the original g -} transferPolyIdInfo :: Id -- Original Id -> [Var] -- Abstract wrt these variables -> Id -- New Id -> Id transferPolyIdInfo old_id abstract_wrt new_id = modifyIdInfo transfer new_id where arity_increase = count isId abstract_wrt -- Arity increases by the -- number of value binders old_info = idInfo old_id old_arity = arityInfo old_info old_inline_prag = inlinePragInfo old_info old_occ_info = occInfo old_info new_arity = old_arity + arity_increase new_occ_info = zapOccTailCallInfo old_occ_info old_strictness = strictnessInfo old_info new_strictness = increaseStrictSigArity arity_increase old_strictness transfer new_info = new_info `setArityInfo` new_arity `setInlinePragInfo` old_inline_prag `setOccInfo` new_occ_info `setStrictnessInfo` new_strictness isNeverLevPolyId :: Id -> Bool isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/IdInfo.hs0000644000000000000000000005614713713635744021147 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 \section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} (And a pretty good illustration of quite a few things wrong with Haskell. [WDP 94/11]) -} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} module IdInfo ( -- * The IdDetails type IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, JoinArity, isJoinIdDetails_maybe, RecSelParent(..), -- * The IdInfo type IdInfo, -- Abstract vanillaIdInfo, noCafIdInfo, -- ** The OneShotInfo type OneShotInfo(..), oneShotInfo, noOneShotInfo, hasNoOneShotInfo, setOneShotInfo, -- ** Zapping various forms of Info zapLamInfo, zapFragileInfo, zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, zapTailCallInfo, zapCallArityInfo, zapUnfolding, -- ** The ArityInfo type ArityInfo, unknownArity, arityInfo, setArityInfo, ppArityInfo, callArityInfo, setCallArityInfo, -- ** Demand and strictness Info strictnessInfo, setStrictnessInfo, demandInfo, setDemandInfo, pprStrictness, -- ** Unfolding Info unfoldingInfo, setUnfoldingInfo, -- ** The InlinePragInfo type InlinePragInfo, inlinePragInfo, setInlinePragInfo, -- ** The OccInfo type OccInfo(..), isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, occInfo, setOccInfo, InsideLam, OneBranch, insideLam, notInsideLam, oneBranch, notOneBranch, TailCallInfo(..), tailCallInfo, isAlwaysTailCalled, -- ** The RuleInfo type RuleInfo(..), emptyRuleInfo, isEmptyRuleInfo, ruleInfoFreeVars, ruleInfoRules, setRuleInfoHead, ruleInfo, setRuleInfo, -- ** The CAFInfo type CafInfo(..), ppCafInfo, mayHaveCafRefs, cafInfo, setCafInfo, -- ** Tick-box Info TickBoxOp(..), TickBoxId, -- ** Levity info LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType, isNeverLevPolyIdInfo ) where #include "GhclibHsVersions.h" import GhcPrelude import CoreSyn import Class import {-# SOURCE #-} PrimOp (PrimOp) import Name import VarSet import BasicTypes import DataCon import TyCon import PatSyn import Type import ForeignCall import Outputable import Module import Demand import Util -- infixl so you can say (id `set` a `set` b) infixl 1 `setRuleInfo`, `setArityInfo`, `setInlinePragInfo`, `setUnfoldingInfo`, `setOneShotInfo`, `setOccInfo`, `setCafInfo`, `setStrictnessInfo`, `setDemandInfo`, `setNeverLevPoly`, `setLevityInfoWithType` {- ************************************************************************ * * IdDetails * * ************************************************************************ -} -- | Identifier Details -- -- The 'IdDetails' of an 'Id' give stable, and necessary, -- information about the Id. data IdDetails = VanillaId -- | The 'Id' for a record selector | RecSelId { sel_tycon :: RecSelParent , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: -- data T = forall a. MkT { x :: a } } -- See Note [Naughty record selectors] in TcTyClsDecls | DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/ | DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/ -- [the only reasons we need to know is so that -- a) to support isImplicitId -- b) when desugaring a RecordCon we can get -- from the Id back to the data con] | ClassOpId Class -- ^ The 'Id' is a superclass selector, -- or class operation of a class | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. -- Type will be simple: no type families, newtypes, etc | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) | DFunId Bool -- ^ A dictionary function. -- Bool = True <=> the class has only one method, so may be -- implemented with a newtype, so it might be bad -- to be strict on this dictionary | CoVarId -- ^ A coercion variable -- This only covers /un-lifted/ coercions, of type -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants | JoinId JoinArity -- ^ An 'Id' for a join point taking n arguments -- Note [Join points] in CoreSyn -- | Recursive Selector Parent data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq -- Either `TyCon` or `PatSyn` depending -- on the origin of the record selector. -- For a data type family, this is the -- /instance/ 'TyCon' not the family 'TyCon' instance Outputable RecSelParent where ppr p = case p of RecSelData ty_con -> ppr ty_con RecSelPatSyn ps -> ppr ps -- | Just a synonym for 'CoVarId'. Written separately so it can be -- exported in the hs-boot file. coVarDetails :: IdDetails coVarDetails = CoVarId -- | Check if an 'IdDetails' says 'CoVarId'. isCoVarDetails :: IdDetails -> Bool isCoVarDetails CoVarId = True isCoVarDetails _ = False isJoinIdDetails_maybe :: IdDetails -> Maybe JoinArity isJoinIdDetails_maybe (JoinId join_arity) = Just join_arity isJoinIdDetails_maybe _ = Nothing instance Outputable IdDetails where ppr = pprIdDetails pprIdDetails :: IdDetails -> SDoc pprIdDetails VanillaId = empty pprIdDetails other = brackets (pp other) where pp VanillaId = panic "pprIdDetails" pp (DataConWorkId _) = text "DataCon" pp (DataConWrapId _) = text "DataConWrapper" pp (ClassOpId {}) = text "ClassOp" pp (PrimOpId _) = text "PrimOp" pp (FCallId _) = text "ForeignCall" pp (TickBoxOpId _) = text "TickBoxOp" pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") pp (RecSelId { sel_naughty = is_naughty }) = brackets $ text "RecSel" <> ppWhen is_naughty (text "(naughty)") pp CoVarId = text "CoVarId" pp (JoinId arity) = text "JoinId" <> parens (int arity) {- ************************************************************************ * * \subsection{The main IdInfo type} * * ************************************************************************ -} -- | Identifier Information -- -- An 'IdInfo' gives /optional/ information about an 'Id'. If -- present it never lies, but it may not be present, in which case there -- is always a conservative assumption which can be made. -- -- Two 'Id's may have different info even though they have the same -- 'Unique' (and are hence the same 'Id'); for example, one might lack -- the properties attached to the other. -- -- Most of the 'IdInfo' gives information about the value, or definition, of -- the 'Id', independent of its usage. Exceptions to this -- are 'demandInfo', 'occInfo', 'oneShotInfo' and 'callArityInfo'. -- -- Performance note: when we update 'IdInfo', we have to reallocate this -- entire record, so it is a good idea not to let this data structure get -- too big. data IdInfo = IdInfo { arityInfo :: !ArityInfo, -- ^ 'Id' arity, as computed by 'CoreArity'. Specifies how many -- arguments this 'Id' has to be applied to before it doesn any -- meaningful work. ruleInfo :: RuleInfo, -- ^ Specialisations of the 'Id's function which exist. -- See Note [Specialisations and RULES in IdInfo] unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding cafInfo :: CafInfo, -- ^ 'Id' CAF info oneShotInfo :: OneShotInfo, -- ^ Info about a lambda-bound variable, if the 'Id' is one inlinePragInfo :: InlinePragma, -- ^ Any inline pragma atached to the 'Id' occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program strictnessInfo :: StrictSig, -- ^ A strictness signature. Digests how a function uses its arguments -- if applied to at least 'arityInfo' arguments. demandInfo :: Demand, -- ^ ID demand information callArityInfo :: !ArityInfo, -- ^ How this is called. This is the number of arguments to which a -- binding can be eta-expanded without losing any sharing. -- n <=> all calls have at least n arguments levityInfo :: LevityInfo -- ^ when applied, will this Id ever have a levity-polymorphic type? } -- Setters setRuleInfo :: IdInfo -> RuleInfo -> IdInfo setRuleInfo info sp = sp `seq` info { ruleInfo = sp } setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } setOccInfo :: IdInfo -> OccInfo -> IdInfo setOccInfo info oc = oc `seq` info { occInfo = oc } -- Try to avoid space leaks by seq'ing setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo setUnfoldingInfo info uf = -- We don't seq the unfolding, as we generate intermediate -- unfoldings which are just thrown away, so evaluating them is a -- waste of time. -- seqUnfolding uf `seq` info { unfoldingInfo = uf } setArityInfo :: IdInfo -> ArityInfo -> IdInfo setArityInfo info ar = info { arityInfo = ar } setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo setCallArityInfo info ar = info { callArityInfo = ar } setCafInfo :: IdInfo -> CafInfo -> IdInfo setCafInfo info caf = info { cafInfo = caf } setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo setOneShotInfo info lb = {-lb `seq`-} info { oneShotInfo = lb } setDemandInfo :: IdInfo -> Demand -> IdInfo setDemandInfo info dd = dd `seq` info { demandInfo = dd } setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } -- | Basic 'IdInfo' that carries no useful information whatsoever vanillaIdInfo :: IdInfo vanillaIdInfo = IdInfo { cafInfo = vanillaCafInfo, arityInfo = unknownArity, ruleInfo = emptyRuleInfo, unfoldingInfo = noUnfolding, oneShotInfo = NoOneShotInfo, inlinePragInfo = defaultInlinePragma, occInfo = noOccInfo, demandInfo = topDmd, strictnessInfo = nopSig, callArityInfo = unknownArity, levityInfo = NoLevityInfo } -- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references noCafIdInfo :: IdInfo noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs -- Used for built-in type Ids in MkId. {- ************************************************************************ * * \subsection[arity-IdInfo]{Arity info about an @Id@} * * ************************************************************************ For locally-defined Ids, the code generator maintains its own notion of their arities; so it should not be asking... (but other things besides the code-generator need arity info!) -} -- | Arity Information -- -- An 'ArityInfo' of @n@ tells us that partial application of this -- 'Id' to up to @n-1@ value arguments does essentially no work. -- -- That is not necessarily the same as saying that it has @n@ leading -- lambdas, because coerces may get in the way. -- -- The arity might increase later in the compilation process, if -- an extra lambda floats up to the binding site. type ArityInfo = Arity -- | It is always safe to assume that an 'Id' has an arity of 0 unknownArity :: Arity unknownArity = 0 ppArityInfo :: Int -> SDoc ppArityInfo 0 = empty ppArityInfo n = hsep [text "Arity", int n] {- ************************************************************************ * * \subsection{Inline-pragma information} * * ************************************************************************ -} -- | Inline Pragma Information -- -- Tells when the inlining is active. -- When it is active the thing may be inlined, depending on how -- big it is. -- -- If there was an @INLINE@ pragma, then as a separate matter, the -- RHS will have been made to look small with a Core inline 'Note' -- -- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves -- entirely as a way to inhibit inlining until we want it type InlinePragInfo = InlinePragma {- ************************************************************************ * * Strictness * * ************************************************************************ -} pprStrictness :: StrictSig -> SDoc pprStrictness sig = ppr sig {- ************************************************************************ * * RuleInfo * * ************************************************************************ Note [Specialisations and RULES in IdInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Generally speaking, a GlobalId has an *empty* RuleInfo. All their RULES are contained in the globally-built rule-base. In principle, one could attach the to M.f the RULES for M.f that are defined in M. But we don't do that for instance declarations and so we just treat them all uniformly. The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is jsut for convenience really. However, LocalIds may have non-empty RuleInfo. We treat them differently because: a) they might be nested, in which case a global table won't work b) the RULE might mention free variables, which we use to keep things alive In TidyPgm, when the LocalId becomes a GlobalId, its RULES are stripped off and put in the global list. -} -- | Rule Information -- -- Records the specializations of this 'Id' that we know about -- in the form of rewrite 'CoreRule's that target them data RuleInfo = RuleInfo [CoreRule] DVarSet -- Locally-defined free vars of *both* LHS and RHS -- of rules. I don't think it needs to include the -- ru_fn though. -- Note [Rule dependency info] in OccurAnal -- | Assume that no specilizations exist: always safe emptyRuleInfo :: RuleInfo emptyRuleInfo = RuleInfo [] emptyDVarSet isEmptyRuleInfo :: RuleInfo -> Bool isEmptyRuleInfo (RuleInfo rs _) = null rs -- | Retrieve the locally-defined free variables of both the left and -- right hand sides of the specialization rules ruleInfoFreeVars :: RuleInfo -> DVarSet ruleInfoFreeVars (RuleInfo _ fvs) = fvs ruleInfoRules :: RuleInfo -> [CoreRule] ruleInfoRules (RuleInfo rules _) = rules -- | Change the name of the function the rule is keyed on on all of the 'CoreRule's setRuleInfoHead :: Name -> RuleInfo -> RuleInfo setRuleInfoHead fn (RuleInfo rules fvs) = RuleInfo (map (setRuleIdName fn) rules) fvs {- ************************************************************************ * * \subsection[CG-IdInfo]{Code generator-related information} * * ************************************************************************ -} -- CafInfo is used to build Static Reference Tables (see simplStg/SRT.hs). -- | Constant applicative form Information -- -- Records whether an 'Id' makes Constant Applicative Form references data CafInfo = MayHaveCafRefs -- ^ Indicates that the 'Id' is for either: -- -- 1. A function or static constructor -- that refers to one or more CAFs, or -- -- 2. A real live CAF | NoCafRefs -- ^ A function or static constructor -- that refers to no CAFs. deriving (Eq, Ord) -- | Assumes that the 'Id' has CAF references: definitely safe vanillaCafInfo :: CafInfo vanillaCafInfo = MayHaveCafRefs mayHaveCafRefs :: CafInfo -> Bool mayHaveCafRefs MayHaveCafRefs = True mayHaveCafRefs _ = False instance Outputable CafInfo where ppr = ppCafInfo ppCafInfo :: CafInfo -> SDoc ppCafInfo NoCafRefs = text "NoCafRefs" ppCafInfo MayHaveCafRefs = empty {- ************************************************************************ * * \subsection{Bulk operations on IdInfo} * * ************************************************************************ -} -- | This is used to remove information on lambda binders that we have -- setup as part of a lambda group, assuming they will be applied all at once, -- but turn out to be part of an unsaturated lambda as in e.g: -- -- > (\x1. \x2. e) arg1 zapLamInfo :: IdInfo -> Maybe IdInfo zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) | is_safe_occ occ && is_safe_dmd demand = Nothing | otherwise = Just (info {occInfo = safe_occ, demandInfo = topDmd}) where -- The "unsafe" occ info is the ones that say I'm not in a lambda -- because that might not be true for an unsaturated lambda is_safe_occ occ | isAlwaysTailCalled occ = False is_safe_occ (OneOcc { occ_in_lam = in_lam }) = in_lam is_safe_occ _other = True safe_occ = case occ of OneOcc{} -> occ { occ_in_lam = True , occ_tail = NoTailCallInfo } IAmALoopBreaker{} -> occ { occ_tail = NoTailCallInfo } _other -> occ is_safe_dmd dmd = not (isStrictDmd dmd) -- | Remove all demand info on the 'IdInfo' zapDemandInfo :: IdInfo -> Maybe IdInfo zapDemandInfo info = Just (info {demandInfo = topDmd}) -- | Remove usage (but not strictness) info on the 'IdInfo' zapUsageInfo :: IdInfo -> Maybe IdInfo zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) -- | Remove usage environment info from the strictness signature on the 'IdInfo' zapUsageEnvInfo :: IdInfo -> Maybe IdInfo zapUsageEnvInfo info | hasDemandEnvSig (strictnessInfo info) = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)}) | otherwise = Nothing zapUsedOnceInfo :: IdInfo -> Maybe IdInfo zapUsedOnceInfo info = Just $ info { strictnessInfo = zapUsedOnceSig (strictnessInfo info) , demandInfo = zapUsedOnceDemand (demandInfo info) } zapFragileInfo :: IdInfo -> Maybe IdInfo -- ^ Zap info that depends on free variables zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf }) = new_unf `seq` -- The unfolding field is not (currently) strict, so we -- force it here to avoid a (zapFragileUnfolding unf) thunk -- which might leak space Just (info `setRuleInfo` emptyRuleInfo `setUnfoldingInfo` new_unf `setOccInfo` zapFragileOcc occ) where new_unf = zapFragileUnfolding unf zapFragileUnfolding :: Unfolding -> Unfolding zapFragileUnfolding unf | isFragileUnfolding unf = noUnfolding | otherwise = unf zapUnfolding :: Unfolding -> Unfolding -- Squash all unfolding info, preserving only evaluated-ness zapUnfolding unf | isEvaldUnfolding unf = evaldUnfolding | otherwise = noUnfolding zapTailCallInfo :: IdInfo -> Maybe IdInfo zapTailCallInfo info = case occInfo info of occ | isAlwaysTailCalled occ -> Just (info `setOccInfo` safe_occ) | otherwise -> Nothing where safe_occ = occ { occ_tail = NoTailCallInfo } zapCallArityInfo :: IdInfo -> IdInfo zapCallArityInfo info = setCallArityInfo info 0 {- ************************************************************************ * * \subsection{TickBoxOp} * * ************************************************************************ -} type TickBoxId = Int -- | Tick box for Hpc-style coverage data TickBoxOp = TickBox Module {-# UNPACK #-} !TickBoxId instance Outputable TickBoxOp where ppr (TickBox mod n) = text "tick" <+> ppr (mod,n) {- ************************************************************************ * * Levity * * ************************************************************************ Note [Levity info] ~~~~~~~~~~~~~~~~~~ Ids store whether or not they can be levity-polymorphic at any amount of saturation. This is helpful in optimizing the levity-polymorphism check done in the desugarer, where we can usually learn that something is not levity-polymorphic without actually figuring out its type. See isExprLevPoly in CoreUtils for where this info is used. Storing this is required to prevent perf/compiler/T5631 from blowing up. -} -- See Note [Levity info] data LevityInfo = NoLevityInfo -- always safe | NeverLevityPolymorphic deriving Eq instance Outputable LevityInfo where ppr NoLevityInfo = text "NoLevityInfo" ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic" -- | Marks an IdInfo describing an Id that is never levity polymorphic (even when -- applied). The Type is only there for checking that it's really never levity -- polymorphic setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo setNeverLevPoly info ty = ASSERT2( not (resultIsLevPoly ty), ppr ty ) info { levityInfo = NeverLevityPolymorphic } setLevityInfoWithType :: IdInfo -> Type -> IdInfo setLevityInfoWithType info ty | not (resultIsLevPoly ty) = info { levityInfo = NeverLevityPolymorphic } | otherwise = info isNeverLevPolyIdInfo :: IdInfo -> Bool isNeverLevPolyIdInfo info | NeverLevityPolymorphic <- levityInfo info = True | otherwise = False ghc-lib-parser-8.10.2.20200808/compiler/iface/IfaceSyn.hs0000644000000000000000000030044513713635745020433 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} module IfaceSyn ( module IfaceType, IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..), IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceJoinInfo(..), IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), IfaceClassBody(..), IfaceBang(..), IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..), IfaceAxBranch(..), IfaceTyConParent(..), IfaceCompleteMatch(..), -- * Binding names IfaceTopBndr, putIfaceTopBndr, getIfaceTopBndr, -- Misc ifaceDeclImplicitBndrs, visibleIfConDecls, ifaceDeclFingerprints, -- Free Names freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, -- Pretty printing pprIfaceExpr, pprIfaceDecl, AltPpr(..), ShowSub(..), ShowHowMuch(..), showToIface, showToHeader ) where #include "GhclibHsVersions.h" import GhcPrelude import IfaceType import BinFingerprint import CoreSyn( IsOrphan, isOrphan ) import DynFlags( gopt, GeneralFlag (Opt_PrintAxiomIncomps) ) import Demand import Class import FieldLabel import NameSet import CoAxiom ( BranchIndex ) import Name import CostCentre import Literal import ForeignCall import Annotations( AnnPayload, AnnTarget ) import BasicTypes import Outputable import Module import SrcLoc import Fingerprint import Binary import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) import Var( VarBndr(..), binderVar ) import TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) import Util( dropList, filterByList, notNull, unzipWith ) import DataCon (SrcStrictness(..), SrcUnpackedness(..)) import Lexeme (isLexSym) import TysWiredIn ( constraintKindTyConName ) import Util (seqList) import Control.Monad import System.IO.Unsafe import Control.DeepSeq infixl 3 &&& {- ************************************************************************ * * Declarations * * ************************************************************************ -} -- | A binding top-level 'Name' in an interface file (e.g. the name of an -- 'IfaceDecl'). type IfaceTopBndr = Name -- It's convenient to have a Name in the IfaceSyn, although in each -- case the namespace is implied by the context. However, having an -- Name makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints -- very convenient. Moreover, having the key of the binder means that -- we can encode known-key things cleverly in the symbol table. See Note -- [Symbol table representation of Names] -- -- We don't serialise the namespace onto the disk though; rather we -- drop it when serialising and add it back in when deserialising. getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr getIfaceTopBndr bh = get bh putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO () putIfaceTopBndr bh name = case getUserData bh of UserData{ ud_put_binding_name = put_binding_name } -> --pprTrace "putIfaceTopBndr" (ppr name) $ put_binding_name bh name data IfaceDecl = IfaceId { ifName :: IfaceTopBndr, ifType :: IfaceType, ifIdDetails :: IfaceIdDetails, ifIdInfo :: IfaceIdInfo } | IfaceData { ifName :: IfaceTopBndr, -- Type constructor ifBinders :: [IfaceTyConBinder], ifResKind :: IfaceType, -- Result kind of type constructor ifCType :: Maybe CType, -- C type for CAPI FFI ifRoles :: [Role], -- Roles ifCtxt :: IfaceContext, -- The "stupid theta" ifCons :: IfaceConDecls, -- Includes new/data/data family info ifGadtSyntax :: Bool, -- True <=> declared using -- GADT syntax ifParent :: IfaceTyConParent -- The axiom, for a newtype, -- or data/newtype family instance } | IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor ifRoles :: [Role], -- Roles ifBinders :: [IfaceTyConBinder], ifResKind :: IfaceKind, -- Kind of the *result* ifSynRhs :: IfaceType } | IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor ifResVar :: Maybe IfLclName, -- Result variable name, used -- only for pretty-printing -- with --show-iface ifBinders :: [IfaceTyConBinder], ifResKind :: IfaceKind, -- Kind of the *tycon* ifFamFlav :: IfaceFamTyConFlav, ifFamInj :: Injectivity } -- injectivity information | IfaceClass { ifName :: IfaceTopBndr, -- Name of the class TyCon ifRoles :: [Role], -- Roles ifBinders :: [IfaceTyConBinder], ifFDs :: [FunDep IfLclName], -- Functional dependencies ifBody :: IfaceClassBody -- Methods, superclasses, ATs } | IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name ifTyCon :: IfaceTyCon, -- LHS TyCon ifRole :: Role, -- Role of axiom ifAxBranches :: [IfaceAxBranch] -- Branches } | IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym ifPatIsInfix :: Bool, ifPatMatcher :: (IfExtName, Bool), ifPatBuilder :: Maybe (IfExtName, Bool), -- Everything below is redundant, -- but needed to implement pprIfaceDecl ifPatUnivBndrs :: [IfaceForAllBndr], ifPatExBndrs :: [IfaceForAllBndr], ifPatProvCtxt :: IfaceContext, ifPatReqCtxt :: IfaceContext, ifPatArgs :: [IfaceType], ifPatTy :: IfaceType, ifFieldLabels :: [FieldLabel] } -- See also 'ClassBody' data IfaceClassBody -- Abstract classes don't specify their body; they only occur in @hs-boot@ and -- @hsig@ files. = IfAbstractClass | IfConcreteClass { ifClassCtxt :: IfaceContext, -- Super classes ifATs :: [IfaceAT], -- Associated type families ifSigs :: [IfaceClassOp], -- Method signatures ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition } data IfaceTyConParent = IfNoParent | IfDataInstance IfExtName -- Axiom name IfaceTyCon -- Family TyCon (pretty-printing only, not used in TcIface) -- see Note [Pretty printing via IfaceSyn] in PprTyThing IfaceAppArgs -- Arguments of the family TyCon data IfaceFamTyConFlav = IfaceDataFamilyTyCon -- Data family | IfaceOpenSynFamilyTyCon | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch])) -- ^ Name of associated axiom and branches for pretty printing purposes, -- or 'Nothing' for an empty closed family without an axiom -- See Note [Pretty printing via IfaceSyn] in PprTyThing | IfaceAbstractClosedSynFamilyTyCon | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only data IfaceClassOp = IfaceClassOp IfaceTopBndr IfaceType -- Class op type (Maybe (DefMethSpec IfaceType)) -- Default method -- The types of both the class op itself, -- and the default method, are *not* quantified -- over the class variables data IfaceAT = IfaceAT -- See Class.ClassATItem IfaceDecl -- The associated type declaration (Maybe IfaceType) -- Default associated type instance, if any -- This is just like CoAxBranch data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] , ifaxbEtaTyVars :: [IfaceTvBndr] , ifaxbCoVars :: [IfaceIdBndr] , ifaxbLHS :: IfaceAppArgs , ifaxbRoles :: [Role] , ifaxbRHS :: IfaceType , ifaxbIncomps :: [BranchIndex] } -- See Note [Storing compatibility] in CoAxiom data IfaceConDecls = IfAbstractTyCon -- c.f TyCon.AbstractTyCon | IfDataTyCon [IfaceConDecl] -- Data type decls | IfNewTyCon IfaceConDecl -- Newtype decls -- For IfDataTyCon and IfNewTyCon we store: -- * the data constructor(s); -- The field labels are stored individually in the IfaceConDecl -- (there is some redundancy here, because a field label may occur -- in multiple IfaceConDecls and represent the same field label) data IfaceConDecl = IfCon { ifConName :: IfaceTopBndr, -- Constructor name ifConWrapper :: Bool, -- True <=> has a wrapper ifConInfix :: Bool, -- True <=> declared infix -- The universal type variables are precisely those -- of the type constructor of this data constructor -- This is *easy* to guarantee when creating the IfCon -- but it's not so easy for the original TyCon/DataCon -- So this guarantee holds for IfaceConDecl, but *not* for DataCon ifConExTCvs :: [IfaceBndr], -- Existential ty/covars ifConUserTvBinders :: [IfaceForAllBndr], -- The tyvars, in the order the user wrote them -- INVARIANT: the set of tyvars in ifConUserTvBinders is exactly the -- set of tyvars (*not* covars) of ifConExTCvs, unioned -- with the set of ifBinders (from the parent IfaceDecl) -- whose tyvars do not appear in ifConEqSpec -- See Note [DataCon user type variable binders] in DataCon ifConEqSpec :: IfaceEqSpec, -- Equality constraints ifConCtxt :: IfaceContext, -- Non-stupid context ifConArgTys :: [IfaceType], -- Arg types ifConFields :: [FieldLabel], -- ...ditto... (field labels) ifConStricts :: [IfaceBang], -- Empty (meaning all lazy), -- or 1-1 corresp with arg tys -- See Note [Bangs on imported data constructors] in MkId ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts type IfaceEqSpec = [(IfLclName,IfaceType)] -- | This corresponds to an HsImplBang; that is, the final -- implementation decision about the data constructor arg data IfaceBang = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion -- | This corresponds to HsSrcBang data IfaceSrcBang = IfSrcBang SrcUnpackedness SrcStrictness data IfaceClsInst = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst ifDFun :: IfExtName, -- The dfun ifOFlag :: OverlapFlag, -- Overlap flag ifInstOrph :: IsOrphan } -- See Note [Orphans] in InstEnv -- There's always a separate IfaceDecl for the DFun, which gives -- its IdInfo with its full type and version number. -- The instance declarations taken together have a version number, -- and we don't want that to wobble gratuitously -- If this instance decl is *used*, we'll record a usage on the dfun; -- and if the head does not change it won't be used if it wasn't before -- The ifFamInstTys field of IfaceFamInst contains a list of the rough -- match types data IfaceFamInst = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name , ifFamInstTys :: [Maybe IfaceTyCon] -- See above , ifFamInstAxiom :: IfExtName -- The axiom , ifFamInstOrph :: IsOrphan -- Just like IfaceClsInst } data IfaceRule = IfaceRule { ifRuleName :: RuleName, ifActivation :: Activation, ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars ifRuleHead :: IfExtName, -- Head of lhs ifRuleArgs :: [IfaceExpr], -- Args of LHS ifRuleRhs :: IfaceExpr, ifRuleAuto :: Bool, ifRuleOrph :: IsOrphan -- Just like IfaceClsInst } data IfaceAnnotation = IfaceAnnotation { ifAnnotatedTarget :: IfaceAnnTarget, ifAnnotatedValue :: AnnPayload } type IfaceAnnTarget = AnnTarget OccName data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName instance Outputable IfaceCompleteMatch where ppr (IfaceCompleteMatch cls ty) = text "COMPLETE" <> colon <+> ppr cls <+> dcolon <+> ppr ty -- Here's a tricky case: -- * Compile with -O module A, and B which imports A.f -- * Change function f in A, and recompile without -O -- * When we read in old A.hi we read in its IdInfo (as a thunk) -- (In earlier GHCs we used to drop IdInfo immediately on reading, -- but we do not do that now. Instead it's discarded when the -- ModIface is read into the various decl pools.) -- * The version comparison sees that new (=NoInfo) differs from old (=HasInfo *) -- and so gives a new version. data IfaceIdInfo = NoInfo -- When writing interface file without -O | HasInfo [IfaceInfoItem] -- Has info, and here it is data IfaceInfoItem = HsArity Arity | HsStrictness StrictSig | HsInline InlinePragma | HsUnfold Bool -- True <=> isStrongLoopBreaker is true IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs | HsLevity -- Present <=> never levity polymorphic -- NB: Specialisations and rules come in separately and are -- only later attached to the Id. Partial reason: some are orphans. data IfaceUnfolding = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding -- Possibly could eliminate the Bool here, the information -- is also in the InlinePragma. | IfCompulsory IfaceExpr -- Only used for default methods, in fact | IfInlineRule Arity -- INLINE pragmas Bool -- OK to inline even if *un*-saturated Bool -- OK to inline even if context is boring IfaceExpr | IfDFunUnfold [IfaceBndr] [IfaceExpr] -- We only serialise the IdDetails of top-level Ids, and even then -- we only need a very limited selection. Notably, none of the -- implicit ones are needed here, because they are not put it -- interface files data IfaceIdDetails = IfVanillaId | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool | IfDFunId {- Note [Versioning of instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See [https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#instances] ************************************************************************ * * Functions over declarations * * ************************************************************************ -} visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls IfAbstractTyCon = [] visibleIfConDecls (IfDataTyCon cs) = cs visibleIfConDecls (IfNewTyCon c) = [c] ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] -- *Excludes* the 'main' name, but *includes* the implicitly-bound names -- Deeply revolting, because it has to predict what gets bound, -- especially the question of whether there's a wrapper for a datacon -- See Note [Implicit TyThings] in HscTypes -- N.B. the set of names returned here *must* match the set of -- TyThings returned by HscTypes.implicitTyThings, in the sense that -- TyThing.getOccName should define a bijection between the two lists. -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) -- The order of the list does not matter. ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons }) = case cons of IfAbstractTyCon -> [] IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass }) = [] ifaceDeclImplicitBndrs (IfaceClass { ifName = cls_tc_name , ifBody = IfConcreteClass { ifClassCtxt = sc_ctxt, ifSigs = sigs, ifATs = ats }}) = -- (possibly) newtype coercion co_occs ++ -- data constructor (DataCon namespace) -- data worker (Id namespace) -- no wrapper (class dictionaries never have a wrapper) [dc_occ, dcww_occ] ++ -- associated types [occName (ifName at) | IfaceAT at _ <- ats ] ++ -- superclass selectors [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++ -- operation selectors [occName op | IfaceClassOp op _ _ <- sigs] where cls_tc_occ = occName cls_tc_name n_ctxt = length sc_ctxt n_sigs = length sigs co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ] | otherwise = [] dcww_occ = mkDataConWorkerOcc dc_occ dc_occ = mkClassDataConOcc cls_tc_occ is_newtype = n_sigs + n_ctxt == 1 -- Sigh (keep this synced with buildClass) ifaceDeclImplicitBndrs _ = [] ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName] ifaceConDeclImplicitBndrs (IfCon { ifConWrapper = has_wrapper, ifConName = con_name }) = [occName con_name, work_occ] ++ wrap_occs where con_occ = occName con_name work_occ = mkDataConWorkerOcc con_occ -- Id namespace wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ] -- Id namespace | otherwise = [] -- ----------------------------------------------------------------------------- -- The fingerprints of an IfaceDecl -- We better give each name bound by the declaration a -- different fingerprint! So we calculate the fingerprint of -- each binder by combining the fingerprint of the whole -- declaration with the name of the binder. (#5614, #7215) ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)] ifaceDeclFingerprints hash decl = (getOccName decl, hash) : [ (occ, computeFingerprint' (hash,occ)) | occ <- ifaceDeclImplicitBndrs decl ] where computeFingerprint' = unsafeDupablePerformIO . computeFingerprint (panic "ifaceDeclFingerprints") {- ************************************************************************ * * Expressions * * ************************************************************************ -} data IfaceExpr = IfaceLcl IfLclName | IfaceExt IfExtName | IfaceType IfaceType | IfaceCo IfaceCoercion | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted | IfaceLam IfaceLamBndr IfaceExpr | IfaceApp IfaceExpr IfaceExpr | IfaceCase IfaceExpr IfLclName [IfaceAlt] | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] | IfaceLet IfaceBinding IfaceExpr | IfaceCast IfaceExpr IfaceCoercion | IfaceLit Literal | IfaceFCall ForeignCall IfaceType | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E data IfaceTickish = IfaceHpcTick Module Int -- from HpcTick x | IfaceSCC CostCentre Bool Bool -- from ProfNote | IfaceSource RealSrcSpan String -- from SourceNote -- no breakpoints: we never export these into interface files type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) -- Note: IfLclName, not IfaceBndr (and same with the case binder) -- We reconstruct the kind/type of the thing from the context -- thus saving bulk in interface files data IfaceConAlt = IfaceDefault | IfaceDataAlt IfExtName | IfaceLitAlt Literal data IfaceBinding = IfaceNonRec IfaceLetBndr IfaceExpr | IfaceRec [(IfaceLetBndr, IfaceExpr)] -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too -- It's used for *non-top-level* let/rec binders -- See Note [IdInfo on nested let-bindings] data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo data IfaceJoinInfo = IfaceNotJoinPoint | IfaceJoinPoint JoinArity {- Note [Empty case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In IfaceSyn an IfaceCase does not record the types of the alternatives, unlike CorSyn Case. But we need this type if the alternatives are empty. Hence IfaceECase. See Note [Empty case alternatives] in CoreSyn. Note [Expose recursive functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For supercompilation we want to put *all* unfoldings in the interface file, even for functions that are recursive (or big). So we need to know when an unfolding belongs to a loop-breaker so that we can refrain from inlining it (except during supercompilation). Note [IdInfo on nested let-bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Occasionally we want to preserve IdInfo on nested let bindings. The one that came up was a NOINLINE pragma on a let-binding inside an INLINE function. The user (Duncan Coutts) really wanted the NOINLINE control to cross the separate compilation boundary. In general we retain all info that is left by CoreTidy.tidyLetBndr, since that is what is seen by importing module with --make Note [Displaying axiom incompatibilities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ With -fprint-axiom-incomps we display which closed type family equations are incompatible with which. This information is sometimes necessary because GHC doesn't try equations in order: any equation can be used when all preceding equations that are incompatible with it do not apply. For example, the last "a && a = a" equation in Data.Type.Bool.&& is actually compatible with all previous equations, and can reduce at any time. This is displayed as: Prelude> :i Data.Type.Equality.== type family (==) (a :: k) (b :: k) :: Bool where {- #0 -} (==) (f a) (g b) = (f == g) && (a == b) {- #1 -} (==) a a = 'True -- incompatible with: #0 {- #2 -} (==) _1 _2 = 'False -- incompatible with: #1, #0 The comment after an equation refers to all previous equations (0-indexed) that are incompatible with it. ************************************************************************ * * Printing IfaceDecl * * ************************************************************************ -} pprAxBranch :: SDoc -> BranchIndex -> IfaceAxBranch -> SDoc -- The TyCon might be local (just an OccName), or this might -- be a branch for an imported TyCon, so it would be an ExtName -- So it's easier to take an SDoc here -- -- This function is used -- to print interface files, -- in debug messages -- in :info F for GHCi, which goes via toConToIfaceDecl on the family tycon -- For user error messages we use Coercion.pprCoAxiom and friends pprAxBranch pp_tc idx (IfaceAxBranch { ifaxbTyVars = tvs , ifaxbCoVars = _cvs , ifaxbLHS = pat_tys , ifaxbRHS = rhs , ifaxbIncomps = incomps }) = WARN( not (null _cvs), pp_tc $$ ppr _cvs ) hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs)) $+$ nest 4 maybe_incomps where -- See Note [Printing foralls in type family instances] in IfaceType ppr_binders = maybe_index <+> pprUserIfaceForAll (map (mkIfaceForAllTvBndr Specified) tvs) pp_lhs = hang pp_tc 2 (pprParendIfaceAppArgs pat_tys) -- See Note [Displaying axiom incompatibilities] maybe_index = sdocWithDynFlags $ \dflags -> ppWhen (gopt Opt_PrintAxiomIncomps dflags) $ text "{-" <+> (text "#" <> ppr idx) <+> text "-}" maybe_incomps = sdocWithDynFlags $ \dflags -> ppWhen (gopt Opt_PrintAxiomIncomps dflags && notNull incomps) $ text "--" <+> text "incompatible with:" <+> pprWithCommas (\incomp -> text "#" <> ppr incomp) incomps instance Outputable IfaceAnnotation where ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value instance NamedThing IfaceClassOp where getName (IfaceClassOp n _ _) = n instance HasOccName IfaceClassOp where occName = getOccName instance NamedThing IfaceConDecl where getName = ifConName instance HasOccName IfaceConDecl where occName = getOccName instance NamedThing IfaceDecl where getName = ifName instance HasOccName IfaceDecl where occName = getOccName instance Outputable IfaceDecl where ppr = pprIfaceDecl showToIface {- Note [Minimal complete definition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The minimal complete definition should only be included if a complete class definition is shown. Since the minimal complete definition is anonymous we can't reuse the same mechanism that is used for the filtering of method signatures. Instead we just check if anything at all is filtered and hide it in that case. -} data ShowSub = ShowSub { ss_how_much :: ShowHowMuch , ss_forall :: ShowForAllFlag } -- See Note [Printing IfaceDecl binders] -- The alternative pretty printer referred to in the note. newtype AltPpr = AltPpr (Maybe (OccName -> SDoc)) data ShowHowMuch = ShowHeader AltPpr -- ^Header information only, not rhs | ShowSome [OccName] AltPpr -- ^ Show only some sub-components. Specifically, -- -- [@[]@] Print all sub-components. -- [@(n:ns)@] Print sub-component @n@ with @ShowSub = ns@; -- elide other sub-components to @...@ -- May 14: the list is max 1 element long at the moment | ShowIface -- ^Everything including GHC-internal information (used in --show-iface) {- Note [Printing IfaceDecl binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The binders in an IfaceDecl are just OccNames, so we don't know what module they come from. But when we pretty-print a TyThing by converting to an IfaceDecl (see PprTyThing), the TyThing may come from some other module so we really need the module qualifier. We solve this by passing in a pretty-printer for the binders. When printing an interface file (--show-iface), we want to print everything unqualified, so we can just print the OccName directly. -} instance Outputable ShowHowMuch where ppr (ShowHeader _) = text "ShowHeader" ppr ShowIface = text "ShowIface" ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs showToHeader :: ShowSub showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing , ss_forall = ShowForAllWhen } showToIface :: ShowSub showToIface = ShowSub { ss_how_much = ShowIface , ss_forall = ShowForAllWhen } ppShowIface :: ShowSub -> SDoc -> SDoc ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc ppShowIface _ _ = Outputable.empty -- show if all sub-components or the complete interface is shown ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- Note [Minimal complete definition] ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc ppShowAllSubs _ _ = Outputable.empty ppShowRhs :: ShowSub -> SDoc -> SDoc ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _ = Outputable.empty ppShowRhs _ doc = doc showSub :: HasOccName n => ShowSub -> n -> Bool showSub (ShowSub { ss_how_much = ShowHeader _ }) _ = False showSub (ShowSub { ss_how_much = ShowSome (n:_) _ }) thing = n == occName thing showSub (ShowSub { ss_how_much = _ }) _ = True ppr_trim :: [Maybe SDoc] -> [SDoc] -- Collapse a group of Nothings to a single "..." ppr_trim xs = snd (foldr go (False, []) xs) where go (Just doc) (_, so_far) = (False, doc : so_far) go Nothing (True, so_far) = (True, so_far) go Nothing (False, so_far) = (True, text "..." : so_far) isIfaceDataInstance :: IfaceTyConParent -> Bool isIfaceDataInstance IfNoParent = False isIfaceDataInstance _ = True pprClassRoles :: ShowSub -> IfaceTopBndr -> [IfaceTyConBinder] -> [Role] -> SDoc pprClassRoles ss clas binders roles = pprRoles (== Nominal) (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas)) binders roles pprClassStandaloneKindSig :: ShowSub -> IfaceTopBndr -> IfaceKind -> SDoc pprClassStandaloneKindSig ss clas = pprStandaloneKindSig (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas)) constraintIfaceKind :: IfaceKind constraintIfaceKind = IfaceTyConApp (IfaceTyCon constraintKindTyConName (IfaceTyConInfo NotPromoted IfaceNormalTyCon)) IA_Nil pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc -- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi -- See Note [Pretty-printing TyThings] in PprTyThing pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, ifCtxt = context, ifResKind = kind, ifRoles = roles, ifCons = condecls, ifParent = parent, ifGadtSyntax = gadt, ifBinders = binders }) | gadt = vcat [ pp_roles , pp_ki_sig , pp_nd <+> pp_lhs <+> pp_kind <+> pp_where , nest 2 (vcat pp_cons) , nest 2 $ ppShowIface ss pp_extra ] | otherwise = vcat [ pp_roles , pp_ki_sig , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons) , nest 2 $ ppShowIface ss pp_extra ] where is_data_instance = isIfaceDataInstance parent -- See Note [Printing foralls in type family instances] in IfaceType pp_data_inst_forall :: SDoc pp_data_inst_forall = pprUserIfaceForAll forall_bndrs forall_bndrs :: [IfaceForAllBndr] forall_bndrs = [Bndr (binderVar tc_bndr) Specified | tc_bndr <- binders] cons = visibleIfConDecls condecls pp_where = ppWhen (gadt && not (null cons)) $ text "where" pp_cons = ppr_trim (map show_con cons) :: [SDoc] pp_kind = ppUnless (if ki_sig_printable then isIfaceTauType kind -- Even in the presence of a standalone kind signature, a non-tau -- result kind annotation cannot be discarded as it determines the arity. -- See Note [Arity inference in kcDeclHeader_sig] in TcHsType else isIfaceLiftedTypeKind kind) (dcolon <+> ppr kind) pp_lhs = case parent of IfNoParent -> pprIfaceDeclHead suppress_bndr_sig context ss tycon binders IfDataInstance{} -> text "instance" <+> pp_data_inst_forall <+> pprIfaceTyConParent parent pp_roles | is_data_instance = empty | otherwise = pprRoles (== Representational) name_doc binders roles -- Don't display roles for data family instances (yet) -- See discussion on #8672. ki_sig_printable = -- If we print a standalone kind signature for a data instance, we leak -- the internal constructor name: -- -- type T15827.R:Dka :: forall k. k -> * -- data instance forall k (a :: k). D a = MkD (Proxy a) -- -- This T15827.R:Dka is a compiler-generated type constructor for the -- data instance. not is_data_instance pp_ki_sig = ppWhen ki_sig_printable $ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders kind) -- See Note [Suppressing binder signatures] in IfaceType suppress_bndr_sig = SuppressBndrSig ki_sig_printable name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon) add_bars [] = Outputable.empty add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs) ok_con dc = showSub ss dc || any (showSub ss . flSelector) (ifConFields dc) show_con dc | ok_con dc = Just $ pprIfaceConDecl ss gadt tycon binders parent dc | otherwise = Nothing pp_nd = case condecls of IfAbstractTyCon{} -> text "data" IfDataTyCon{} -> text "data" IfNewTyCon{} -> text "newtype" pp_extra = vcat [pprCType ctype] pprIfaceDecl ss (IfaceClass { ifName = clas , ifRoles = roles , ifFDs = fds , ifBinders = binders , ifBody = IfAbstractClass }) = vcat [ pprClassRoles ss clas binders roles , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind) , text "class" <+> pprIfaceDeclHead suppress_bndr_sig [] ss clas binders <+> pprFundeps fds ] where -- See Note [Suppressing binder signatures] in IfaceType suppress_bndr_sig = SuppressBndrSig True pprIfaceDecl ss (IfaceClass { ifName = clas , ifRoles = roles , ifFDs = fds , ifBinders = binders , ifBody = IfConcreteClass { ifATs = ats, ifSigs = sigs, ifClassCtxt = context, ifMinDef = minDef }}) = vcat [ pprClassRoles ss clas binders roles , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind) , text "class" <+> pprIfaceDeclHead suppress_bndr_sig context ss clas binders <+> pprFundeps fds <+> pp_where , nest 2 (vcat [ vcat asocs, vcat dsigs , ppShowAllSubs ss (pprMinDef minDef)])] where pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where") asocs = ppr_trim $ map maybeShowAssoc ats dsigs = ppr_trim $ map maybeShowSig sigs maybeShowAssoc :: IfaceAT -> Maybe SDoc maybeShowAssoc asc@(IfaceAT d _) | showSub ss d = Just $ pprIfaceAT ss asc | otherwise = Nothing maybeShowSig :: IfaceClassOp -> Maybe SDoc maybeShowSig sg | showSub ss sg = Just $ pprIfaceClassOp ss sg | otherwise = Nothing pprMinDef :: BooleanFormula IfLclName -> SDoc pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions text "{-# MINIMAL" <+> pprBooleanFormula (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+> text "#-}" -- See Note [Suppressing binder signatures] in IfaceType suppress_bndr_sig = SuppressBndrSig True pprIfaceDecl ss (IfaceSynonym { ifName = tc , ifBinders = binders , ifSynRhs = mono_ty , ifResKind = res_kind}) = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) , hang (text "type" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tc binders <+> equals) 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ]) ] where (tvs, theta, tau) = splitIfaceSigmaTy mono_ty name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tc) -- See Note [Suppressing binder signatures] in IfaceType suppress_bndr_sig = SuppressBndrSig True pprIfaceDecl ss (IfaceFamily { ifName = tycon , ifFamFlav = rhs, ifBinders = binders , ifResKind = res_kind , ifResVar = res_var, ifFamInj = inj }) | IfaceDataFamilyTyCon <- rhs = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) , text "data family" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders ] | otherwise = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) , hang (text "type family" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders <+> ppShowRhs ss (pp_where rhs)) 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs)) $$ nest 2 (ppShowRhs ss (pp_branches rhs)) ] where name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon) pp_where (IfaceClosedSynFamilyTyCon {}) = text "where" pp_where _ = empty pp_inj Nothing _ = empty pp_inj (Just res) inj | Injective injectivity <- inj = hsep [ equals, ppr res , pp_inj_cond res injectivity] | otherwise = hsep [ equals, ppr res ] pp_inj_cond res inj = case filterByList inj binders of [] -> empty tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)] pp_rhs IfaceDataFamilyTyCon = ppShowIface ss (text "data") pp_rhs IfaceOpenSynFamilyTyCon = ppShowIface ss (text "open") pp_rhs IfaceAbstractClosedSynFamilyTyCon = ppShowIface ss (text "closed, abstract") pp_rhs (IfaceClosedSynFamilyTyCon {}) = empty -- see pp_branches pp_rhs IfaceBuiltInSynFamTyCon = ppShowIface ss (text "built-in") pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs))) = vcat (unzipWith (pprAxBranch (pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon)) ) $ zip [0..] brs) $$ ppShowIface ss (text "axiom" <+> ppr ax) pp_branches _ = Outputable.empty -- See Note [Suppressing binder signatures] in IfaceType suppress_bndr_sig = SuppressBndrSig True pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs, ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, ifPatArgs = arg_tys, ifPatTy = pat_ty} ) = sdocWithDynFlags mk_msg where mk_msg dflags = hang (text "pattern" <+> pprPrefixOcc name) 2 (dcolon <+> sep [univ_msg , pprIfaceContextArr req_ctxt , ppWhen insert_empty_ctxt $ parens empty <+> darrow , ex_msg , pprIfaceContextArr prov_ctxt , pprIfaceType $ foldr (IfaceFunTy VisArg) pat_ty arg_tys ]) where univ_msg = pprUserIfaceForAll univ_bndrs ex_msg = pprUserIfaceForAll ex_bndrs insert_empty_ctxt = null req_ctxt && not (null prov_ctxt && isEmpty dflags ex_msg) pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty, ifIdDetails = details, ifIdInfo = info }) = vcat [ hang (pprPrefixIfDeclBndr (ss_how_much ss) (occName var) <+> dcolon) 2 (pprIfaceSigmaType (ss_forall ss) ty) , ppShowIface ss (ppr details) , ppShowIface ss (ppr info) ] pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon , ifAxBranches = branches }) = hang (text "axiom" <+> ppr name <+> dcolon) 2 (vcat $ unzipWith (pprAxBranch (ppr tycon)) $ zip [0..] branches) pprCType :: Maybe CType -> SDoc pprCType Nothing = Outputable.empty pprCType (Just cType) = text "C type:" <+> ppr cType -- if, for each role, suppress_if role is True, then suppress the role -- output pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder] -> [Role] -> SDoc pprRoles suppress_if tyCon bndrs roles = sdocWithDynFlags $ \dflags -> let froles = suppressIfaceInvisibles dflags bndrs roles in ppUnless (all suppress_if froles || null froles) $ text "type role" <+> tyCon <+> hsep (map ppr froles) pprStandaloneKindSig :: SDoc -> IfaceType -> SDoc pprStandaloneKindSig tyCon ty = text "type" <+> tyCon <+> text "::" <+> ppr ty pprInfixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc pprInfixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name = pprInfixVar (isSymOcc name) (ppr_bndr name) pprInfixIfDeclBndr _ name = pprInfixVar (isSymOcc name) (ppr name) pprPrefixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc pprPrefixIfDeclBndr (ShowHeader (AltPpr (Just ppr_bndr))) name = parenSymOcc name (ppr_bndr name) pprPrefixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name = parenSymOcc name (ppr_bndr name) pprPrefixIfDeclBndr _ name = parenSymOcc name (ppr name) instance Outputable IfaceClassOp where ppr = pprIfaceClassOp showToIface pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc pprIfaceClassOp ss (IfaceClassOp n ty dm) = pp_sig n ty $$ generic_dm where generic_dm | Just (GenericDM dm_ty) <- dm = text "default" <+> pp_sig n dm_ty | otherwise = empty pp_sig n ty = pprPrefixIfDeclBndr (ss_how_much ss) (occName n) <+> dcolon <+> pprIfaceSigmaType ShowForAllWhen ty instance Outputable IfaceAT where ppr = pprIfaceAT showToIface pprIfaceAT :: ShowSub -> IfaceAT -> SDoc pprIfaceAT ss (IfaceAT d mb_def) = vcat [ pprIfaceDecl ss d , case mb_def of Nothing -> Outputable.empty Just rhs -> nest 2 $ text "Default:" <+> ppr rhs ] instance Outputable IfaceTyConParent where ppr p = pprIfaceTyConParent p pprIfaceTyConParent :: IfaceTyConParent -> SDoc pprIfaceTyConParent IfNoParent = Outputable.empty pprIfaceTyConParent (IfDataInstance _ tc tys) = pprIfaceTypeApp topPrec tc tys pprIfaceDeclHead :: SuppressBndrSig -> IfaceContext -> ShowSub -> Name -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression -> SDoc pprIfaceDeclHead suppress_sig context ss tc_occ bndrs = sdocWithDynFlags $ \ dflags -> sep [ pprIfaceContextArr context , pprPrefixIfDeclBndr (ss_how_much ss) (occName tc_occ) <+> pprIfaceTyConBinders suppress_sig (suppressIfaceInvisibles dflags bndrs bndrs) ] pprIfaceConDecl :: ShowSub -> Bool -> IfaceTopBndr -> [IfaceTyConBinder] -> IfaceTyConParent -> IfaceConDecl -> SDoc pprIfaceConDecl ss gadt_style tycon tc_binders parent (IfCon { ifConName = name, ifConInfix = is_infix, ifConUserTvBinders = user_tvbs, ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, ifConStricts = stricts, ifConFields = fields }) | gadt_style = pp_prefix_con <+> dcolon <+> ppr_gadt_ty | otherwise = ppr_ex_quant pp_h98_con where pp_h98_con | not (null fields) = pp_prefix_con <+> pp_field_args | is_infix , [ty1, ty2] <- pp_args = sep [ ty1 , pprInfixIfDeclBndr how_much (occName name) , ty2] | otherwise = pp_prefix_con <+> sep pp_args how_much = ss_how_much ss tys_w_strs :: [(IfaceBang, IfaceType)] tys_w_strs = zip stricts arg_tys pp_prefix_con = pprPrefixIfDeclBndr how_much (occName name) -- If we're pretty-printing a H98-style declaration with existential -- quantification, then user_tvbs will always consist of the universal -- tyvar binders followed by the existential tyvar binders. So to recover -- the visibilities of the existential tyvar binders, we can simply drop -- the universal tyvar binders from user_tvbs. ex_tvbs = dropList tc_binders user_tvbs ppr_ex_quant = pprIfaceForAllPartMust ex_tvbs ctxt pp_gadt_res_ty = mk_user_con_res_ty eq_spec ppr_gadt_ty = pprIfaceForAllPart user_tvbs ctxt pp_tau -- A bit gruesome this, but we can't form the full con_tau, and ppr it, -- because we don't have a Name for the tycon, only an OccName pp_tau | null fields = case pp_args ++ [pp_gadt_res_ty] of (t:ts) -> fsep (t : map (arrow <+>) ts) [] -> panic "pp_con_taus" | otherwise = sep [pp_field_args, arrow <+> pp_gadt_res_ty] ppr_bang IfNoBang = whenPprDebug $ char '_' ppr_bang IfStrict = char '!' ppr_bang IfUnpack = text "{-# UNPACK #-}" ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <> pprParendIfaceCoercion co pprFieldArgTy, pprArgTy :: (IfaceBang, IfaceType) -> SDoc -- If using record syntax, the only reason one would need to parenthesize -- a compound field type is if it's preceded by a bang pattern. pprFieldArgTy (bang, ty) = ppr_arg_ty (bang_prec bang) bang ty -- If not using record syntax, a compound field type might need to be -- parenthesized if one of the following holds: -- -- 1. We're using Haskell98 syntax. -- 2. The field type is preceded with a bang pattern. pprArgTy (bang, ty) = ppr_arg_ty (max gadt_prec (bang_prec bang)) bang ty ppr_arg_ty :: PprPrec -> IfaceBang -> IfaceType -> SDoc ppr_arg_ty prec bang ty = ppr_bang bang <> pprPrecIfaceType prec ty -- If we're displaying the fields GADT-style, e.g., -- -- data Foo a where -- MkFoo :: (Int -> Int) -> Maybe a -> Foo -- -- Then we use `funPrec`, since that will ensure `Int -> Int` gets the -- parentheses that it requires, but simple compound types like `Maybe a` -- (which don't require parentheses in a function argument position) won't -- get them, assuming that there are no bang patterns (see bang_prec). -- -- If we're displaying the fields Haskell98-style, e.g., -- -- data Foo a = MkFoo (Int -> Int) (Maybe a) -- -- Then not only must we parenthesize `Int -> Int`, we must also -- parenthesize compound fields like (Maybe a). Therefore, we pick -- `appPrec`, which has higher precedence than `funPrec`. gadt_prec :: PprPrec gadt_prec | gadt_style = funPrec | otherwise = appPrec -- The presence of bang patterns or UNPACK annotations requires -- surrounding the type with parentheses, if needed (#13699) bang_prec :: IfaceBang -> PprPrec bang_prec IfNoBang = topPrec bang_prec IfStrict = appPrec bang_prec IfUnpack = appPrec bang_prec IfUnpackCo{} = appPrec pp_args :: [SDoc] -- No records, e.g., ` Maybe a -> Int -> ...` or -- `!(Maybe a) -> !Int -> ...` pp_args = map pprArgTy tys_w_strs pp_field_args :: SDoc -- Records, e.g., { x :: Maybe a, y :: Int } or -- { x :: !(Maybe a), y :: !Int } pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $ zipWith maybe_show_label fields tys_w_strs maybe_show_label :: FieldLabel -> (IfaceBang, IfaceType) -> Maybe SDoc maybe_show_label lbl bty | showSub ss sel = Just (pprPrefixIfDeclBndr how_much occ <+> dcolon <+> pprFieldArgTy bty) | otherwise = Nothing where sel = flSelector lbl occ = mkVarOccFS (flLabel lbl) mk_user_con_res_ty :: IfaceEqSpec -> SDoc -- See Note [Result type of a data family GADT] mk_user_con_res_ty eq_spec | IfDataInstance _ tc tys <- parent = pprIfaceType (IfaceTyConApp tc (substIfaceAppArgs gadt_subst tys)) | otherwise = ppr_tc_app gadt_subst where gadt_subst = mkIfaceTySubst eq_spec -- When pretty-printing a GADT return type, we: -- -- 1. Take the data tycon binders, extract their variable names and -- visibilities, and construct suitable arguments from them. (This is -- the role of mk_tc_app_args.) -- 2. Apply the GADT substitution constructed from the eq_spec. -- (See Note [Result type of a data family GADT].) -- 3. Pretty-print the data type constructor applied to its arguments. -- This process will omit any invisible arguments, such as coercion -- variables, if necessary. (See Note -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.) ppr_tc_app gadt_subst = pprPrefixIfDeclBndr how_much (occName tycon) <+> pprParendIfaceAppArgs (substIfaceAppArgs gadt_subst (mk_tc_app_args tc_binders)) mk_tc_app_args :: [IfaceTyConBinder] -> IfaceAppArgs mk_tc_app_args [] = IA_Nil mk_tc_app_args (Bndr bndr vis:tc_bndrs) = IA_Arg (IfaceTyVar (ifaceBndrName bndr)) (tyConBndrVisArgFlag vis) (mk_tc_app_args tc_bndrs) instance Outputable IfaceRule where ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, ifRuleOrph = orph }) = sep [ hsep [ pprRuleName name , if isOrphan orph then text "[orphan]" else Outputable.empty , ppr act , pp_foralls ] , nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), text "=" <+> ppr rhs]) ] where pp_foralls = ppUnless (null bndrs) $ forAllLit <+> pprIfaceBndrs bndrs <> dot instance Outputable IfaceClsInst where ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag , ifInstCls = cls, ifInstTys = mb_tcs , ifInstOrph = orph }) = hang (text "instance" <+> ppr flag <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) 2 (equals <+> ppr dfun_id) instance Outputable IfaceFamInst where ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs , ifFamInstAxiom = tycon_ax, ifFamInstOrph = orph }) = hang (text "family instance" <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs) 2 (equals <+> ppr tycon_ax) ppr_rough :: Maybe IfaceTyCon -> SDoc ppr_rough Nothing = dot ppr_rough (Just tc) = ppr tc {- Note [Result type of a data family GADT] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data family T a data instance T (p,q) where T1 :: T (Int, Maybe c) T2 :: T (Bool, q) The IfaceDecl actually looks like data TPr p q where T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q T2 :: forall p q. (p~Bool) => TPr p q To reconstruct the result types for T1 and T2 that we want to pretty print, we substitute the eq-spec [p->Int, q->Maybe c] in the arg pattern (p,q) to give T (Int, Maybe c) Remember that in IfaceSyn, the TyCon and DataCon share the same universal type variables. ----------------------------- Printing IfaceExpr ------------------------------------ -} instance Outputable IfaceExpr where ppr e = pprIfaceExpr noParens e noParens :: SDoc -> SDoc noParens pp = pp pprParendIfaceExpr :: IfaceExpr -> SDoc pprParendIfaceExpr = pprIfaceExpr parens -- | Pretty Print an IfaceExpre -- -- The first argument should be a function that adds parens in context that need -- an atomic value (e.g. function args) pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc pprIfaceExpr _ (IfaceLcl v) = ppr v pprIfaceExpr _ (IfaceExt v) = ppr v pprIfaceExpr _ (IfaceLit l) = ppr l pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceCoercion co pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as) pprIfaceExpr add_par i@(IfaceLam _ _) = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow, pprIfaceExpr noParens body]) where (bndrs,body) = collect [] i collect bs (IfaceLam b e) = collect (b:bs) e collect bs e = (reverse bs, e) pprIfaceExpr add_par (IfaceECase scrut ty) = add_par (sep [ text "case" <+> pprIfaceExpr noParens scrut , text "ret_ty" <+> pprParendIfaceType ty , text "of {}" ]) pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) = add_par (sep [text "case" <+> pprIfaceExpr noParens scrut <+> text "of" <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, pprIfaceExpr noParens rhs <+> char '}']) pprIfaceExpr add_par (IfaceCase scrut bndr alts) = add_par (sep [text "case" <+> pprIfaceExpr noParens scrut <+> text "of" <+> ppr bndr <+> char '{', nest 2 (sep (map ppr_alt alts)) <+> char '}']) pprIfaceExpr _ (IfaceCast expr co) = sep [pprParendIfaceExpr expr, nest 2 (text "`cast`"), pprParendIfaceCoercion co] pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) = add_par (sep [text "let {", nest 2 (ppr_bind (b, rhs)), text "} in", pprIfaceExpr noParens body]) pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) = add_par (sep [text "letrec {", nest 2 (sep (map ppr_bind pairs)), text "} in", pprIfaceExpr noParens body]) pprIfaceExpr add_par (IfaceTick tickish e) = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e) ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, arrow <+> pprIfaceExpr noParens rhs] ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc ppr_bind (IfLetBndr b ty info ji, rhs) = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr ji <+> ppr info), equals <+> pprIfaceExpr noParens rhs] ------------------ pprIfaceTickish :: IfaceTickish -> SDoc pprIfaceTickish (IfaceHpcTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix) pprIfaceTickish (IfaceSCC cc tick scope) = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) pprIfaceTickish (IfaceSource src _names) = braces (pprUserRealSpan True src) ------------------ pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $ nest 2 (pprParendIfaceExpr arg) : args pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args) ------------------ instance Outputable IfaceConAlt where ppr IfaceDefault = text "DEFAULT" ppr (IfaceLitAlt l) = ppr l ppr (IfaceDataAlt d) = ppr d ------------------ instance Outputable IfaceIdDetails where ppr IfVanillaId = Outputable.empty ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc <+> if b then text "" else Outputable.empty ppr IfDFunId = text "DFunId" instance Outputable IfaceIdInfo where ppr NoInfo = Outputable.empty ppr (HasInfo is) = text "{-" <+> pprWithCommas ppr is <+> text "-}" instance Outputable IfaceInfoItem where ppr (HsUnfold lb unf) = text "Unfolding" <> ppWhen lb (text "(loop-breaker)") <> colon <+> ppr unf ppr (HsInline prag) = text "Inline:" <+> ppr prag ppr (HsArity arity) = text "Arity:" <+> int arity ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str ppr HsNoCafRefs = text "HasNoCafRefs" ppr HsLevity = text "Never levity-polymorphic" instance Outputable IfaceJoinInfo where ppr IfaceNotJoinPoint = empty ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar) instance Outputable IfaceUnfolding where ppr (IfCompulsory e) = text "" <+> parens (ppr e) ppr (IfCoreUnfold s e) = (if s then text "" else Outputable.empty) <+> parens (ppr e) ppr (IfInlineRule a uok bok e) = sep [text "InlineRule" <+> ppr (a,uok,bok), pprParendIfaceExpr e] ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot) 2 (sep (map pprParendIfaceExpr es)) {- ************************************************************************ * * Finding the Names in IfaceSyn * * ************************************************************************ This is used for dependency analysis in MkIface, so that we fingerprint a declaration before the things that depend on it. It is specific to interface-file fingerprinting in the sense that we don't collect *all* Names: for example, the DFun of an instance is recorded textually rather than by its fingerprint when fingerprinting the instance, so DFuns are not dependencies. -} freeNamesIfDecl :: IfaceDecl -> NameSet freeNamesIfDecl (IfaceId { ifType = t, ifIdDetails = d, ifIdInfo = i}) = freeNamesIfType t &&& freeNamesIfIdInfo i &&& freeNamesIfIdDetails d freeNamesIfDecl (IfaceData { ifBinders = bndrs, ifResKind = res_k , ifParent = p, ifCtxt = ctxt, ifCons = cons }) = freeNamesIfVarBndrs bndrs &&& freeNamesIfType res_k &&& freeNamesIfaceTyConParent p &&& freeNamesIfContext ctxt &&& freeNamesIfConDecls cons freeNamesIfDecl (IfaceSynonym { ifBinders = bndrs, ifResKind = res_k , ifSynRhs = rhs }) = freeNamesIfVarBndrs bndrs &&& freeNamesIfKind res_k &&& freeNamesIfType rhs freeNamesIfDecl (IfaceFamily { ifBinders = bndrs, ifResKind = res_k , ifFamFlav = flav }) = freeNamesIfVarBndrs bndrs &&& freeNamesIfKind res_k &&& freeNamesIfFamFlav flav freeNamesIfDecl (IfaceClass{ ifBinders = bndrs, ifBody = cls_body }) = freeNamesIfVarBndrs bndrs &&& freeNamesIfClassBody cls_body freeNamesIfDecl (IfaceAxiom { ifTyCon = tc, ifAxBranches = branches }) = freeNamesIfTc tc &&& fnList freeNamesIfAxBranch branches freeNamesIfDecl (IfacePatSyn { ifPatMatcher = (matcher, _) , ifPatBuilder = mb_builder , ifPatUnivBndrs = univ_bndrs , ifPatExBndrs = ex_bndrs , ifPatProvCtxt = prov_ctxt , ifPatReqCtxt = req_ctxt , ifPatArgs = args , ifPatTy = pat_ty , ifFieldLabels = lbls }) = unitNameSet matcher &&& maybe emptyNameSet (unitNameSet . fst) mb_builder &&& freeNamesIfVarBndrs univ_bndrs &&& freeNamesIfVarBndrs ex_bndrs &&& freeNamesIfContext prov_ctxt &&& freeNamesIfContext req_ctxt &&& fnList freeNamesIfType args &&& freeNamesIfType pat_ty &&& mkNameSet (map flSelector lbls) freeNamesIfClassBody :: IfaceClassBody -> NameSet freeNamesIfClassBody IfAbstractClass = emptyNameSet freeNamesIfClassBody (IfConcreteClass{ ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }) = freeNamesIfContext ctxt &&& fnList freeNamesIfAT ats &&& fnList freeNamesIfClsSig sigs freeNamesIfAxBranch :: IfaceAxBranch -> NameSet freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars , ifaxbCoVars = covars , ifaxbLHS = lhs , ifaxbRHS = rhs }) = fnList freeNamesIfTvBndr tyvars &&& fnList freeNamesIfIdBndr covars &&& freeNamesIfAppArgs lhs &&& freeNamesIfType rhs freeNamesIfIdDetails :: IfaceIdDetails -> NameSet freeNamesIfIdDetails (IfRecSelId tc _) = either freeNamesIfTc freeNamesIfDecl tc freeNamesIfIdDetails _ = emptyNameSet -- All other changes are handled via the version info on the tycon freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br))) = unitNameSet ax &&& fnList freeNamesIfAxBranch br freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet freeNamesIfContext :: IfaceContext -> NameSet freeNamesIfContext = fnList freeNamesIfType freeNamesIfAT :: IfaceAT -> NameSet freeNamesIfAT (IfaceAT decl mb_def) = freeNamesIfDecl decl &&& case mb_def of Nothing -> emptyNameSet Just rhs -> freeNamesIfType rhs freeNamesIfClsSig :: IfaceClassOp -> NameSet freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty freeNamesDM _ = emptyNameSet freeNamesIfConDecls :: IfaceConDecls -> NameSet freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c freeNamesIfConDecls _ = emptyNameSet freeNamesIfConDecl :: IfaceConDecl -> NameSet freeNamesIfConDecl (IfCon { ifConExTCvs = ex_tvs, ifConCtxt = ctxt , ifConArgTys = arg_tys , ifConFields = flds , ifConEqSpec = eq_spec , ifConStricts = bangs }) = fnList freeNamesIfBndr ex_tvs &&& freeNamesIfContext ctxt &&& fnList freeNamesIfType arg_tys &&& mkNameSet (map flSelector flds) &&& fnList freeNamesIfType (map snd eq_spec) &&& -- equality constraints fnList freeNamesIfBang bangs freeNamesIfBang :: IfaceBang -> NameSet freeNamesIfBang (IfUnpackCo co) = freeNamesIfCoercion co freeNamesIfBang _ = emptyNameSet freeNamesIfKind :: IfaceType -> NameSet freeNamesIfKind = freeNamesIfType freeNamesIfAppArgs :: IfaceAppArgs -> NameSet freeNamesIfAppArgs (IA_Arg t _ ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts freeNamesIfAppArgs IA_Nil = emptyNameSet freeNamesIfType :: IfaceType -> NameSet freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet freeNamesIfType (IfaceTyVar _) = emptyNameSet freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs t freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts freeNamesIfType (IfaceLitTy _) = emptyNameSet freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfVarBndr tv &&& freeNamesIfType t freeNamesIfType (IfaceFunTy _ s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c freeNamesIfMCoercion :: IfaceMCoercion -> NameSet freeNamesIfMCoercion IfaceMRefl = emptyNameSet freeNamesIfMCoercion (IfaceMCo co) = freeNamesIfCoercion co freeNamesIfCoercion :: IfaceCoercion -> NameSet freeNamesIfCoercion (IfaceReflCo t) = freeNamesIfType t freeNamesIfCoercion (IfaceGReflCo _ t mco) = freeNamesIfType t &&& freeNamesIfMCoercion mco freeNamesIfCoercion (IfaceFunCo _ c1 c2) = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 freeNamesIfCoercion (IfaceTyConAppCo _ tc cos) = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos freeNamesIfCoercion (IfaceAppCo c1 c2) = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 freeNamesIfCoercion (IfaceForAllCo _ kind_co co) = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos) = unitNameSet ax &&& fnList freeNamesIfCoercion cos freeNamesIfCoercion (IfaceUnivCo p _ t1 t2) = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2 freeNamesIfCoercion (IfaceSymCo c) = freeNamesIfCoercion c freeNamesIfCoercion (IfaceTransCo c1 c2) = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 freeNamesIfCoercion (IfaceNthCo _ co) = freeNamesIfCoercion co freeNamesIfCoercion (IfaceLRCo _ co) = freeNamesIfCoercion co freeNamesIfCoercion (IfaceInstCo co co2) = freeNamesIfCoercion co &&& freeNamesIfCoercion co2 freeNamesIfCoercion (IfaceKindCo c) = freeNamesIfCoercion c freeNamesIfCoercion (IfaceSubCo co) = freeNamesIfCoercion co freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos) -- the axiom is just a string, so we don't count it as a name. = fnList freeNamesIfCoercion cos freeNamesIfProv :: IfaceUnivCoProv -> NameSet freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co freeNamesIfProv (IfacePluginProv _) = emptyNameSet freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr freeNamesIfVarBndrs :: [VarBndr IfaceBndr vis] -> NameSet freeNamesIfVarBndrs = fnList freeNamesIfVarBndr freeNamesIfBndr :: IfaceBndr -> NameSet freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b freeNamesIfBndrs :: [IfaceBndr] -> NameSet freeNamesIfBndrs = fnList freeNamesIfBndr freeNamesIfLetBndr :: IfaceLetBndr -> NameSet -- Remember IfaceLetBndr is used only for *nested* bindings -- The IdInfo can contain an unfolding (in the case of -- local INLINE pragmas), so look there too freeNamesIfLetBndr (IfLetBndr _name ty info _ji) = freeNamesIfType ty &&& freeNamesIfIdInfo info freeNamesIfTvBndr :: IfaceTvBndr -> NameSet freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k -- kinds can have Names inside, because of promotion freeNamesIfIdBndr :: IfaceIdBndr -> NameSet freeNamesIfIdBndr (_fs,k) = freeNamesIfKind k freeNamesIfIdInfo :: IfaceIdInfo -> NameSet freeNamesIfIdInfo NoInfo = emptyNameSet freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i freeNamesItem :: IfaceInfoItem -> NameSet freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u freeNamesItem _ = emptyNameSet freeNamesIfUnfold :: IfaceUnfolding -> NameSet freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es freeNamesIfExpr :: IfaceExpr -> NameSet freeNamesIfExpr (IfaceExt v) = unitNameSet v freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty freeNamesIfExpr (IfaceCase s _ alts) = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts where fn_alt (_con,_bs,r) = freeNamesIfExpr r -- Depend on the data constructors. Just one will do! -- Note [Tracking data constructors] fn_cons [] = emptyNameSet fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con fn_cons (_ : _ ) = emptyNameSet freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body freeNamesIfExpr (IfaceLet (IfaceRec as) x) = fnList fn_pair as &&& freeNamesIfExpr x where fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs freeNamesIfExpr _ = emptyNameSet freeNamesIfTc :: IfaceTyCon -> NameSet freeNamesIfTc tc = unitNameSet (ifaceTyConName tc) -- ToDo: shouldn't we include IfaceIntTc & co.? freeNamesIfRule :: IfaceRule -> NameSet freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f , ifRuleArgs = es, ifRuleRhs = rhs }) = unitNameSet f &&& fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es &&& freeNamesIfExpr rhs freeNamesIfFamInst :: IfaceFamInst -> NameSet freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName , ifFamInstAxiom = axName }) = unitNameSet famName &&& unitNameSet axName freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet freeNamesIfaceTyConParent IfNoParent = emptyNameSet freeNamesIfaceTyConParent (IfDataInstance ax tc tys) = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys -- helpers (&&&) :: NameSet -> NameSet -> NameSet (&&&) = unionNameSet fnList :: (a -> NameSet) -> [a] -> NameSet fnList f = foldr (&&&) emptyNameSet . map f {- Note [Tracking data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In a case expression case e of { C a -> ...; ... } You might think that we don't need to include the datacon C in the free names, because its type will probably show up in the free names of 'e'. But in rare circumstances this may not happen. Here's the one that bit me: module DynFlags where import {-# SOURCE #-} Packages( PackageState ) data DynFlags = DF ... PackageState ... module Packages where import DynFlags data PackageState = PS ... lookupModule (df :: DynFlags) = case df of DF ...p... -> case p of PS ... -> ... Now, lookupModule depends on DynFlags, but the transitive dependency on the *locally-defined* type PackageState is not visible. We need to take account of the use of the data constructor PS in the pattern match. ************************************************************************ * * Binary instances * * ************************************************************************ Note that there is a bit of subtlety here when we encode names. While IfaceTopBndrs is really just a synonym for Name, we need to take care to encode them with {get,put}IfaceTopBndr. The difference becomes important when we go to fingerprint an IfaceDecl. See Note [Fingerprinting IfaceDecls] for details. -} instance Binary IfaceDecl where put_ bh (IfaceId name ty details idinfo) = do putByte bh 0 putIfaceTopBndr bh name lazyPut bh (ty, details, idinfo) -- See Note [Lazy deserialization of IfaceId] put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do putByte bh 2 putIfaceTopBndr bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh a6 put_ bh a7 put_ bh a8 put_ bh a9 put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do putByte bh 3 putIfaceTopBndr bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do putByte bh 4 putIfaceTopBndr bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh a6 -- NB: Written in a funny way to avoid an interface change put_ bh (IfaceClass { ifName = a2, ifRoles = a3, ifBinders = a4, ifFDs = a5, ifBody = IfConcreteClass { ifClassCtxt = a1, ifATs = a6, ifSigs = a7, ifMinDef = a8 }}) = do putByte bh 5 put_ bh a1 putIfaceTopBndr bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh a6 put_ bh a7 put_ bh a8 put_ bh (IfaceAxiom a1 a2 a3 a4) = do putByte bh 6 putIfaceTopBndr bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do putByte bh 7 putIfaceTopBndr bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh a6 put_ bh a7 put_ bh a8 put_ bh a9 put_ bh a10 put_ bh a11 put_ bh (IfaceClass { ifName = a1, ifRoles = a2, ifBinders = a3, ifFDs = a4, ifBody = IfAbstractClass }) = do putByte bh 8 putIfaceTopBndr bh a1 put_ bh a2 put_ bh a3 put_ bh a4 get bh = do h <- getByte bh case h of 0 -> do name <- get bh ~(ty, details, idinfo) <- lazyGet bh -- See Note [Lazy deserialization of IfaceId] return (IfaceId name ty details idinfo) 1 -> error "Binary.get(TyClDecl): ForeignType" 2 -> do a1 <- getIfaceTopBndr bh a2 <- get bh a3 <- get bh a4 <- get bh a5 <- get bh a6 <- get bh a7 <- get bh a8 <- get bh a9 <- get bh return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) 3 -> do a1 <- getIfaceTopBndr bh a2 <- get bh a3 <- get bh a4 <- get bh a5 <- get bh return (IfaceSynonym a1 a2 a3 a4 a5) 4 -> do a1 <- getIfaceTopBndr bh a2 <- get bh a3 <- get bh a4 <- get bh a5 <- get bh a6 <- get bh return (IfaceFamily a1 a2 a3 a4 a5 a6) 5 -> do a1 <- get bh a2 <- getIfaceTopBndr bh a3 <- get bh a4 <- get bh a5 <- get bh a6 <- get bh a7 <- get bh a8 <- get bh return (IfaceClass { ifName = a2, ifRoles = a3, ifBinders = a4, ifFDs = a5, ifBody = IfConcreteClass { ifClassCtxt = a1, ifATs = a6, ifSigs = a7, ifMinDef = a8 }}) 6 -> do a1 <- getIfaceTopBndr bh a2 <- get bh a3 <- get bh a4 <- get bh return (IfaceAxiom a1 a2 a3 a4) 7 -> do a1 <- getIfaceTopBndr bh a2 <- get bh a3 <- get bh a4 <- get bh a5 <- get bh a6 <- get bh a7 <- get bh a8 <- get bh a9 <- get bh a10 <- get bh a11 <- get bh return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) 8 -> do a1 <- getIfaceTopBndr bh a2 <- get bh a3 <- get bh a4 <- get bh return (IfaceClass { ifName = a1, ifRoles = a2, ifBinders = a3, ifFDs = a4, ifBody = IfAbstractClass }) _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) {- Note [Lazy deserialization of IfaceId] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The use of lazyPut and lazyGet in the IfaceId Binary instance is purely for performance reasons, to avoid deserializing details about identifiers that will never be used. It's not involved in tying the knot in the type checker. It saved ~1% of the total build time of GHC. When we read an interface file, we extend the PTE, a mapping of Names to TyThings, with the declarations we have read. The extension of the PTE is strict in the Names, but not in the TyThings themselves. LoadIface.loadDecl calculates the list of (Name, TyThing) bindings to add to the PTE. For an IfaceId, there's just one binding to add; and the ty, details, and idinfo fields of an IfaceId are used only in the TyThing. So by reading those fields lazily we may be able to save the work of ever having to deserialize them (into IfaceType, etc.). For IfaceData and IfaceClass, loadDecl creates extra implicit bindings (the constructors and field selectors of the data declaration, or the methods of the class), whose Names depend on more than just the Name of the type constructor or class itself. So deserializing them lazily would be more involved. Similar comments apply to the other constructors of IfaceDecl with the additional point that they probably represent a small proportion of all declarations. -} instance Binary IfaceFamTyConFlav where put_ bh IfaceDataFamilyTyCon = putByte bh 0 put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1 put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3 put_ _ IfaceBuiltInSynFamTyCon = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty get bh = do { h <- getByte bh ; case h of 0 -> return IfaceDataFamilyTyCon 1 -> return IfaceOpenSynFamilyTyCon 2 -> do { mb <- get bh ; return (IfaceClosedSynFamilyTyCon mb) } 3 -> return IfaceAbstractClosedSynFamilyTyCon _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag" (ppr (fromIntegral h :: Int)) } instance Binary IfaceClassOp where put_ bh (IfaceClassOp n ty def) = do putIfaceTopBndr bh n put_ bh ty put_ bh def get bh = do n <- getIfaceTopBndr bh ty <- get bh def <- get bh return (IfaceClassOp n ty def) instance Binary IfaceAT where put_ bh (IfaceAT dec defs) = do put_ bh dec put_ bh defs get bh = do dec <- get bh defs <- get bh return (IfaceAT dec defs) instance Binary IfaceAxBranch where put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) = do put_ bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh a6 put_ bh a7 get bh = do a1 <- get bh a2 <- get bh a3 <- get bh a4 <- get bh a5 <- get bh a6 <- get bh a7 <- get bh return (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) instance Binary IfaceConDecls where put_ bh IfAbstractTyCon = putByte bh 0 put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c get bh = do h <- getByte bh case h of 0 -> return IfAbstractTyCon 1 -> liftM IfDataTyCon (get bh) 2 -> liftM IfNewTyCon (get bh) _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls" instance Binary IfaceConDecl where put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do putIfaceTopBndr bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh a6 put_ bh a7 put_ bh a8 put_ bh (length a9) mapM_ (put_ bh) a9 put_ bh a10 put_ bh a11 get bh = do a1 <- getIfaceTopBndr bh a2 <- get bh a3 <- get bh a4 <- get bh a5 <- get bh a6 <- get bh a7 <- get bh a8 <- get bh n_fields <- get bh a9 <- replicateM n_fields (get bh) a10 <- get bh a11 <- get bh return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) instance Binary IfaceBang where put_ bh IfNoBang = putByte bh 0 put_ bh IfStrict = putByte bh 1 put_ bh IfUnpack = putByte bh 2 put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co get bh = do h <- getByte bh case h of 0 -> do return IfNoBang 1 -> do return IfStrict 2 -> do return IfUnpack _ -> do { a <- get bh; return (IfUnpackCo a) } instance Binary IfaceSrcBang where put_ bh (IfSrcBang a1 a2) = do put_ bh a1 put_ bh a2 get bh = do a1 <- get bh a2 <- get bh return (IfSrcBang a1 a2) instance Binary IfaceClsInst where put_ bh (IfaceClsInst cls tys dfun flag orph) = do put_ bh cls put_ bh tys put_ bh dfun put_ bh flag put_ bh orph get bh = do cls <- get bh tys <- get bh dfun <- get bh flag <- get bh orph <- get bh return (IfaceClsInst cls tys dfun flag orph) instance Binary IfaceFamInst where put_ bh (IfaceFamInst fam tys name orph) = do put_ bh fam put_ bh tys put_ bh name put_ bh orph get bh = do fam <- get bh tys <- get bh name <- get bh orph <- get bh return (IfaceFamInst fam tys name orph) instance Binary IfaceRule where put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do put_ bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh a6 put_ bh a7 put_ bh a8 get bh = do a1 <- get bh a2 <- get bh a3 <- get bh a4 <- get bh a5 <- get bh a6 <- get bh a7 <- get bh a8 <- get bh return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) instance Binary IfaceAnnotation where put_ bh (IfaceAnnotation a1 a2) = do put_ bh a1 put_ bh a2 get bh = do a1 <- get bh a2 <- get bh return (IfaceAnnotation a1 a2) instance Binary IfaceIdDetails where put_ bh IfVanillaId = putByte bh 0 put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b put_ bh IfDFunId = putByte bh 2 get bh = do h <- getByte bh case h of 0 -> return IfVanillaId 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } _ -> return IfDFunId instance Binary IfaceIdInfo where put_ bh NoInfo = putByte bh 0 put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut get bh = do h <- getByte bh case h of 0 -> return NoInfo _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet instance Binary IfaceInfoItem where put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad put_ bh HsNoCafRefs = putByte bh 4 put_ bh HsLevity = putByte bh 5 get bh = do h <- getByte bh case h of 0 -> liftM HsArity $ get bh 1 -> liftM HsStrictness $ get bh 2 -> do lb <- get bh ad <- get bh return (HsUnfold lb ad) 3 -> liftM HsInline $ get bh 4 -> return HsNoCafRefs _ -> return HsLevity instance Binary IfaceUnfolding where put_ bh (IfCoreUnfold s e) = do putByte bh 0 put_ bh s put_ bh e put_ bh (IfInlineRule a b c d) = do putByte bh 1 put_ bh a put_ bh b put_ bh c put_ bh d put_ bh (IfDFunUnfold as bs) = do putByte bh 2 put_ bh as put_ bh bs put_ bh (IfCompulsory e) = do putByte bh 3 put_ bh e get bh = do h <- getByte bh case h of 0 -> do s <- get bh e <- get bh return (IfCoreUnfold s e) 1 -> do a <- get bh b <- get bh c <- get bh d <- get bh return (IfInlineRule a b c d) 2 -> do as <- get bh bs <- get bh return (IfDFunUnfold as bs) _ -> do e <- get bh return (IfCompulsory e) instance Binary IfaceExpr where put_ bh (IfaceLcl aa) = do putByte bh 0 put_ bh aa put_ bh (IfaceType ab) = do putByte bh 1 put_ bh ab put_ bh (IfaceCo ab) = do putByte bh 2 put_ bh ab put_ bh (IfaceTuple ac ad) = do putByte bh 3 put_ bh ac put_ bh ad put_ bh (IfaceLam (ae, os) af) = do putByte bh 4 put_ bh ae put_ bh os put_ bh af put_ bh (IfaceApp ag ah) = do putByte bh 5 put_ bh ag put_ bh ah put_ bh (IfaceCase ai aj ak) = do putByte bh 6 put_ bh ai put_ bh aj put_ bh ak put_ bh (IfaceLet al am) = do putByte bh 7 put_ bh al put_ bh am put_ bh (IfaceTick an ao) = do putByte bh 8 put_ bh an put_ bh ao put_ bh (IfaceLit ap) = do putByte bh 9 put_ bh ap put_ bh (IfaceFCall as at) = do putByte bh 10 put_ bh as put_ bh at put_ bh (IfaceExt aa) = do putByte bh 11 put_ bh aa put_ bh (IfaceCast ie ico) = do putByte bh 12 put_ bh ie put_ bh ico put_ bh (IfaceECase a b) = do putByte bh 13 put_ bh a put_ bh b get bh = do h <- getByte bh case h of 0 -> do aa <- get bh return (IfaceLcl aa) 1 -> do ab <- get bh return (IfaceType ab) 2 -> do ab <- get bh return (IfaceCo ab) 3 -> do ac <- get bh ad <- get bh return (IfaceTuple ac ad) 4 -> do ae <- get bh os <- get bh af <- get bh return (IfaceLam (ae, os) af) 5 -> do ag <- get bh ah <- get bh return (IfaceApp ag ah) 6 -> do ai <- get bh aj <- get bh ak <- get bh return (IfaceCase ai aj ak) 7 -> do al <- get bh am <- get bh return (IfaceLet al am) 8 -> do an <- get bh ao <- get bh return (IfaceTick an ao) 9 -> do ap <- get bh return (IfaceLit ap) 10 -> do as <- get bh at <- get bh return (IfaceFCall as at) 11 -> do aa <- get bh return (IfaceExt aa) 12 -> do ie <- get bh ico <- get bh return (IfaceCast ie ico) 13 -> do a <- get bh b <- get bh return (IfaceECase a b) _ -> panic ("get IfaceExpr " ++ show h) instance Binary IfaceTickish where put_ bh (IfaceHpcTick m ix) = do putByte bh 0 put_ bh m put_ bh ix put_ bh (IfaceSCC cc tick push) = do putByte bh 1 put_ bh cc put_ bh tick put_ bh push put_ bh (IfaceSource src name) = do putByte bh 2 put_ bh (srcSpanFile src) put_ bh (srcSpanStartLine src) put_ bh (srcSpanStartCol src) put_ bh (srcSpanEndLine src) put_ bh (srcSpanEndCol src) put_ bh name get bh = do h <- getByte bh case h of 0 -> do m <- get bh ix <- get bh return (IfaceHpcTick m ix) 1 -> do cc <- get bh tick <- get bh push <- get bh return (IfaceSCC cc tick push) 2 -> do file <- get bh sl <- get bh sc <- get bh el <- get bh ec <- get bh let start = mkRealSrcLoc file sl sc end = mkRealSrcLoc file el ec name <- get bh return (IfaceSource (mkRealSrcSpan start end) name) _ -> panic ("get IfaceTickish " ++ show h) instance Binary IfaceConAlt where put_ bh IfaceDefault = putByte bh 0 put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac get bh = do h <- getByte bh case h of 0 -> return IfaceDefault 1 -> liftM IfaceDataAlt $ get bh _ -> liftM IfaceLitAlt $ get bh instance Binary IfaceBinding where put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac get bh = do h <- getByte bh case h of 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } _ -> do { ac <- get bh; return (IfaceRec ac) } instance Binary IfaceLetBndr where put_ bh (IfLetBndr a b c d) = do put_ bh a put_ bh b put_ bh c put_ bh d get bh = do a <- get bh b <- get bh c <- get bh d <- get bh return (IfLetBndr a b c d) instance Binary IfaceJoinInfo where put_ bh IfaceNotJoinPoint = putByte bh 0 put_ bh (IfaceJoinPoint ar) = do putByte bh 1 put_ bh ar get bh = do h <- getByte bh case h of 0 -> return IfaceNotJoinPoint _ -> liftM IfaceJoinPoint $ get bh instance Binary IfaceTyConParent where put_ bh IfNoParent = putByte bh 0 put_ bh (IfDataInstance ax pr ty) = do putByte bh 1 put_ bh ax put_ bh pr put_ bh ty get bh = do h <- getByte bh case h of 0 -> return IfNoParent _ -> do ax <- get bh pr <- get bh ty <- get bh return $ IfDataInstance ax pr ty instance Binary IfaceCompleteMatch where put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts get bh = IfaceCompleteMatch <$> get bh <*> get bh {- ************************************************************************ * * NFData instances See Note [Avoiding space leaks in toIface*] in ToIface * * ************************************************************************ -} instance NFData IfaceDecl where rnf = \case IfaceId f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 IfaceData f1 f2 f3 f4 f5 f6 f7 f8 f9 -> f1 `seq` seqList f2 `seq` f3 `seq` f4 `seq` f5 `seq` rnf f6 `seq` rnf f7 `seq` rnf f8 `seq` rnf f9 IfaceSynonym f1 f2 f3 f4 f5 -> rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 IfaceFamily f1 f2 f3 f4 f5 f6 -> rnf f1 `seq` rnf f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 `seq` f6 `seq` () IfaceClass f1 f2 f3 f4 f5 -> rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 IfaceAxiom nm tycon role ax -> rnf nm `seq` rnf tycon `seq` role `seq` rnf ax IfacePatSyn f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` f11 `seq` () instance NFData IfaceAxBranch where rnf (IfaceAxBranch f1 f2 f3 f4 f5 f6 f7) = rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` rnf f7 instance NFData IfaceClassBody where rnf = \case IfAbstractClass -> () IfConcreteClass f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` () instance NFData IfaceAT where rnf (IfaceAT f1 f2) = rnf f1 `seq` rnf f2 instance NFData IfaceClassOp where rnf (IfaceClassOp f1 f2 f3) = rnf f1 `seq` rnf f2 `seq` f3 `seq` () instance NFData IfaceTyConParent where rnf = \case IfNoParent -> () IfDataInstance f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 instance NFData IfaceConDecls where rnf = \case IfAbstractTyCon -> () IfDataTyCon f1 -> rnf f1 IfNewTyCon f1 -> rnf f1 instance NFData IfaceConDecl where rnf (IfCon f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11) = rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` rnf f7 `seq` rnf f8 `seq` f9 `seq` rnf f10 `seq` rnf f11 instance NFData IfaceSrcBang where rnf (IfSrcBang f1 f2) = f1 `seq` f2 `seq` () instance NFData IfaceBang where rnf x = x `seq` () instance NFData IfaceIdDetails where rnf = \case IfVanillaId -> () IfRecSelId (Left tycon) b -> rnf tycon `seq` rnf b IfRecSelId (Right decl) b -> rnf decl `seq` rnf b IfDFunId -> () instance NFData IfaceIdInfo where rnf = \case NoInfo -> () HasInfo f1 -> rnf f1 instance NFData IfaceInfoItem where rnf = \case HsArity a -> rnf a HsStrictness str -> seqStrictSig str HsInline p -> p `seq` () -- TODO: seq further? HsUnfold b unf -> rnf b `seq` rnf unf HsNoCafRefs -> () HsLevity -> () instance NFData IfaceUnfolding where rnf = \case IfCoreUnfold inlinable expr -> rnf inlinable `seq` rnf expr IfCompulsory expr -> rnf expr IfInlineRule arity b1 b2 e -> rnf arity `seq` rnf b1 `seq` rnf b2 `seq` rnf e IfDFunUnfold bndrs exprs -> rnf bndrs `seq` rnf exprs instance NFData IfaceExpr where rnf = \case IfaceLcl nm -> rnf nm IfaceExt nm -> rnf nm IfaceType ty -> rnf ty IfaceCo co -> rnf co IfaceTuple sort exprs -> sort `seq` rnf exprs IfaceLam bndr expr -> rnf bndr `seq` rnf expr IfaceApp e1 e2 -> rnf e1 `seq` rnf e2 IfaceCase e nm alts -> rnf e `seq` nm `seq` rnf alts IfaceECase e ty -> rnf e `seq` rnf ty IfaceLet bind e -> rnf bind `seq` rnf e IfaceCast e co -> rnf e `seq` rnf co IfaceLit l -> l `seq` () -- FIXME IfaceFCall fc ty -> fc `seq` rnf ty IfaceTick tick e -> rnf tick `seq` rnf e instance NFData IfaceBinding where rnf = \case IfaceNonRec bndr e -> rnf bndr `seq` rnf e IfaceRec binds -> rnf binds instance NFData IfaceLetBndr where rnf (IfLetBndr nm ty id_info join_info) = rnf nm `seq` rnf ty `seq` rnf id_info `seq` rnf join_info instance NFData IfaceFamTyConFlav where rnf = \case IfaceDataFamilyTyCon -> () IfaceOpenSynFamilyTyCon -> () IfaceClosedSynFamilyTyCon f1 -> rnf f1 IfaceAbstractClosedSynFamilyTyCon -> () IfaceBuiltInSynFamTyCon -> () instance NFData IfaceJoinInfo where rnf x = x `seq` () instance NFData IfaceTickish where rnf = \case IfaceHpcTick m i -> rnf m `seq` rnf i IfaceSCC cc b1 b2 -> cc `seq` rnf b1 `seq` rnf b2 IfaceSource src str -> src `seq` rnf str instance NFData IfaceConAlt where rnf = \case IfaceDefault -> () IfaceDataAlt nm -> rnf nm IfaceLitAlt lit -> lit `seq` () instance NFData IfaceCompleteMatch where rnf (IfaceCompleteMatch f1 f2) = rnf f1 `seq` rnf f2 instance NFData IfaceRule where rnf (IfaceRule f1 f2 f3 f4 f5 f6 f7 f8) = rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` f8 `seq` () instance NFData IfaceFamInst where rnf (IfaceFamInst f1 f2 f3 f4) = rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` () instance NFData IfaceClsInst where rnf (IfaceClsInst f1 f2 f3 f4 f5) = f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` () instance NFData IfaceAnnotation where rnf (IfaceAnnotation f1 f2) = f1 `seq` f2 `seq` () ghc-lib-parser-8.10.2.20200808/compiler/iface/IfaceType.hs0000644000000000000000000022524013713635745020602 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 This module defines interface types and binders -} {-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} -- FlexibleInstances for Binary (DefMethSpec IfaceType) module IfaceType ( IfExtName, IfLclName, IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), IfaceMCoercion(..), IfaceUnivCoProv(..), IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), IfaceTyLit(..), IfaceAppArgs(..), IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), ShowForAllFlag(..), mkIfaceForAllTvBndr, mkIfaceTyConKind, ifForAllBndrVar, ifForAllBndrName, ifaceBndrName, ifTyConBinderVar, ifTyConBinderName, -- Equality testing isIfaceLiftedTypeKind, -- Conversion from IfaceAppArgs to IfaceTypes/ArgFlags appArgsIfaceTypes, appArgsIfaceTypesArgFlags, -- Printing SuppressBndrSig(..), UseBndrParens(..), pprIfaceType, pprParendIfaceType, pprPrecIfaceType, pprIfaceContext, pprIfaceContextArr, pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders, pprIfaceBndrs, pprIfaceAppArgs, pprParendIfaceAppArgs, pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll, pprIfaceSigmaType, pprIfaceTyLit, pprIfaceCoercion, pprParendIfaceCoercion, splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp, isIfaceTauType, suppressIfaceInvisibles, stripIfaceInvisVars, stripInvisArgs, mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, inDomIfaceTySubst ) where #include "GhclibHsVersions.h" import GhcPrelude import {-# SOURCE #-} TysWiredIn ( coercibleTyCon, heqTyCon , liftedRepDataConTyCon, tupleTyConName ) import {-# SOURCE #-} Type ( isRuntimeRepTy ) import DynFlags import TyCon hiding ( pprPromotionQuote ) import CoAxiom import Var import PrelNames import Name import BasicTypes import Binary import Outputable import FastString import FastStringEnv import Util import Data.Maybe( isJust ) import qualified Data.Semigroup as Semi import Control.DeepSeq {- ************************************************************************ * * Local (nested) binders * * ************************************************************************ -} type IfLclName = FastString -- A local name in iface syntax type IfExtName = Name -- An External or WiredIn Name can appear in IfaceSyn -- (However Internal or System Names never should) data IfaceBndr -- Local (non-top-level) binders = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr type IfaceIdBndr = (IfLclName, IfaceType) type IfaceTvBndr = (IfLclName, IfaceKind) ifaceTvBndrName :: IfaceTvBndr -> IfLclName ifaceTvBndrName (n,_) = n ifaceIdBndrName :: IfaceIdBndr -> IfLclName ifaceIdBndrName (n,_) = n ifaceBndrName :: IfaceBndr -> IfLclName ifaceBndrName (IfaceTvBndr bndr) = ifaceTvBndrName bndr ifaceBndrName (IfaceIdBndr bndr) = ifaceIdBndrName bndr ifaceBndrType :: IfaceBndr -> IfaceType ifaceBndrType (IfaceIdBndr (_, t)) = t ifaceBndrType (IfaceTvBndr (_, t)) = t type IfaceLamBndr = (IfaceBndr, IfaceOneShot) data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy = IfaceNoOneShot -- and Note [The oneShot function] in MkId | IfaceOneShot {- %************************************************************************ %* * IfaceType %* * %************************************************************************ -} ------------------------------- type IfaceKind = IfaceType -- | A kind of universal type, used for types and kinds. -- -- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType' -- before being printed. See Note [Pretty printing via IfaceSyn] in PprTyThing data IfaceType = IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType] | IfaceTyVar IfLclName -- Type/coercion variable only, not tycon | IfaceLitTy IfaceTyLit | IfaceAppTy IfaceType IfaceAppArgs -- See Note [Suppressing invisible arguments] for -- an explanation of why the second field isn't -- IfaceType, analogous to AppTy. | IfaceFunTy AnonArgFlag IfaceType IfaceType | IfaceForAllTy IfaceForAllBndr IfaceType | IfaceTyConApp IfaceTyCon IfaceAppArgs -- Not necessarily saturated -- Includes newtypes, synonyms, tuples | IfaceCastTy IfaceType IfaceCoercion | IfaceCoercionTy IfaceCoercion | IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp) TupleSort -- What sort of tuple? PromotionFlag -- A bit like IfaceTyCon IfaceAppArgs -- arity = length args -- For promoted data cons, the kind args are omitted type IfacePredType = IfaceType type IfaceContext = [IfacePredType] data IfaceTyLit = IfaceNumTyLit Integer | IfaceStrTyLit FastString deriving (Eq) type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag -- | Make an 'IfaceForAllBndr' from an 'IfaceTvBndr'. mkIfaceForAllTvBndr :: ArgFlag -> IfaceTvBndr -> IfaceForAllBndr mkIfaceForAllTvBndr vis var = Bndr (IfaceTvBndr var) vis -- | Build the 'tyConKind' from the binders and the result kind. -- Keep in sync with 'mkTyConKind' in types/TyCon. mkIfaceTyConKind :: [IfaceTyConBinder] -> IfaceKind -> IfaceKind mkIfaceTyConKind bndrs res_kind = foldr mk res_kind bndrs where mk :: IfaceTyConBinder -> IfaceKind -> IfaceKind mk (Bndr tv (AnonTCB af)) k = IfaceFunTy af (ifaceBndrType tv) k mk (Bndr tv (NamedTCB vis)) k = IfaceForAllTy (Bndr tv vis) k -- | Stores the arguments in a type application as a list. -- See @Note [Suppressing invisible arguments]@. data IfaceAppArgs = IA_Nil | IA_Arg IfaceType -- The type argument ArgFlag -- The argument's visibility. We store this here so -- that we can: -- -- 1. Avoid pretty-printing invisible (i.e., specified -- or inferred) arguments when -- -fprint-explicit-kinds isn't enabled, or -- 2. When -fprint-explicit-kinds *is*, enabled, print -- specified arguments in @(...) and inferred -- arguments in @{...}. IfaceAppArgs -- The rest of the arguments instance Semi.Semigroup IfaceAppArgs where IA_Nil <> xs = xs IA_Arg ty argf rest <> xs = IA_Arg ty argf (rest Semi.<> xs) instance Monoid IfaceAppArgs where mempty = IA_Nil mappend = (Semi.<>) -- Encodes type constructors, kind constructors, -- coercion constructors, the lot. -- We have to tag them in order to pretty print them -- properly. data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName , ifaceTyConInfo :: IfaceTyConInfo } deriving (Eq) -- | The various types of TyCons which have special, built-in syntax. data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon | IfaceTupleTyCon !Arity !TupleSort -- ^ e.g. @(a, b, c)@ or @(#a, b, c#)@. -- The arity is the tuple width, not the tycon arity -- (which is twice the width in the case of unboxed -- tuples). | IfaceSumTyCon !Arity -- ^ e.g. @(a | b | c)@ | IfaceEqualityTyCon -- ^ A heterogeneous equality TyCon -- (i.e. eqPrimTyCon, eqReprPrimTyCon, heqTyCon) -- that is actually being applied to two types -- of the same kind. This affects pretty-printing -- only: see Note [Equality predicates in IfaceType] deriving (Eq) {- Note [Free tyvars in IfaceType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to an IfaceType and pretty printing that. This eliminates a lot of pretty-print duplication, and it matches what we do with pretty- printing TyThings. See Note [Pretty printing via IfaceSyn] in PprTyThing. It works fine for closed types, but when printing debug traces (e.g. when using -ddump-tc-trace) we print a lot of /open/ types. These types are full of TcTyVars, and it's absolutely crucial to print them in their full glory, with their unique, TcTyVarDetails etc. So we simply embed a TyVar in IfaceType with the IfaceFreeTyVar constructor. Note that: * We never expect to serialise an IfaceFreeTyVar into an interface file, nor to deserialise one. IfaceFreeTyVar is used only in the "convert to IfaceType and then pretty-print" pipeline. We do the same for covars, naturally. Note [Equality predicates in IfaceType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC has several varieties of type equality (see Note [The equality types story] in TysPrim for details). In an effort to avoid confusing users, we suppress the differences during pretty printing unless certain flags are enabled. Here is how each equality predicate* is printed in homogeneous and heterogeneous contexts, depending on which combination of the -fprint-explicit-kinds and -fprint-equality-relations flags is used: -------------------------------------------------------------------------------------------- | Predicate | Neither flag | -fprint-explicit-kinds | |-------------------------------|----------------------------|-----------------------------| | a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | | a ~~ b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | | a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | | a ~# b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | | a ~# b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | | Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | | a ~R# b, homogeneously | Coercible a b | Coercible @Type a b | | a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | |-------------------------------|----------------------------|-----------------------------| | Predicate | -fprint-equality-relations | Both flags | |-------------------------------|----------------------------|-----------------------------| | a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | | a ~~ b, homogeneously | a ~~ b | (a :: Type) ~~ (b :: Type) | | a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | | a ~# b, homogeneously | a ~# b | (a :: Type) ~# (b :: Type) | | a ~# b, heterogeneously | a ~# c | (a :: Type) ~# (c :: k) | | Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | | a ~R# b, homogeneously | a ~R# b | (a :: Type) ~R# (b :: Type) | | a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | -------------------------------------------------------------------------------------------- (* There is no heterogeneous, representational, lifted equality counterpart to (~~). There could be, but there seems to be no use for it.) This table adheres to the following rules: A. With -fprint-equality-relations, print the true equality relation. B. Without -fprint-equality-relations: i. If the equality is representational and homogeneous, use Coercible. ii. Otherwise, if the equality is representational, use ~R#. iii. If the equality is nominal and homogeneous, use ~. iv. Otherwise, if the equality is nominal, use ~~. C. With -fprint-explicit-kinds, print kinds on both sides of an infix operator, as above; or print the kind with Coercible. D. Without -fprint-explicit-kinds, don't print kinds. A hetero-kinded equality is used homogeneously when it is applied to two identical kinds. Unfortunately, determining this from an IfaceType isn't possible since we can't see through type synonyms. Consequently, we need to record whether this particular application is homogeneous in IfaceTyConSort for the purposes of pretty-printing. See Note [The equality types story] in TysPrim. -} data IfaceTyConInfo -- Used to guide pretty-printing -- and to disambiguate D from 'D (they share a name) = IfaceTyConInfo { ifaceTyConIsPromoted :: PromotionFlag , ifaceTyConSort :: IfaceTyConSort } deriving (Eq) data IfaceMCoercion = IfaceMRefl | IfaceMCo IfaceCoercion data IfaceCoercion = IfaceReflCo IfaceType | IfaceGReflCo Role IfaceType (IfaceMCoercion) | IfaceFunCo Role IfaceCoercion IfaceCoercion | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] | IfaceAppCo IfaceCoercion IfaceCoercion | IfaceForAllCo IfaceBndr IfaceCoercion IfaceCoercion | IfaceCoVarCo IfLclName | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion] | IfaceAxiomRuleCo IfLclName [IfaceCoercion] -- There are only a fixed number of CoAxiomRules, so it suffices -- to use an IfaceLclName to distinguish them. -- See Note [Adding built-in type families] in TcTypeNats | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType | IfaceSymCo IfaceCoercion | IfaceTransCo IfaceCoercion IfaceCoercion | IfaceNthCo Int IfaceCoercion | IfaceLRCo LeftOrRight IfaceCoercion | IfaceInstCo IfaceCoercion IfaceCoercion | IfaceKindCo IfaceCoercion | IfaceSubCo IfaceCoercion | IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType] | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion] data IfaceUnivCoProv = IfaceUnsafeCoerceProv | IfacePhantomProv IfaceCoercion | IfaceProofIrrelProv IfaceCoercion | IfacePluginProv String {- Note [Holes in IfaceCoercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When typechecking fails the typechecker will produce a HoleCo to stand in place of the unproven assertion. While we generally don't want to let these unproven assertions leak into interface files, we still need to be able to pretty-print them as we use IfaceType's pretty-printer to render Types. For this reason IfaceCoercion has a IfaceHoleCo constructor; however, we fails when asked to serialize to a IfaceHoleCo to ensure that they don't end up in an interface file. %************************************************************************ %* * Functions over IFaceTypes * * ************************************************************************ -} ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key isIfaceLiftedTypeKind :: IfaceKind -> Bool isIfaceLiftedTypeKind (IfaceTyConApp tc IA_Nil) = isLiftedTypeKindTyConName (ifaceTyConName tc) isIfaceLiftedTypeKind (IfaceTyConApp tc (IA_Arg (IfaceTyConApp ptr_rep_lifted IA_Nil) Required IA_Nil)) = tc `ifaceTyConHasKey` tYPETyConKey && ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey isIfaceLiftedTypeKind _ = False splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) -- Mainly for printing purposes -- -- Here we split nested IfaceSigmaTy properly. -- -- @ -- forall t. T t => forall m a b. M m => (a -> m b) -> t a -> m (t b) -- @ -- -- If you called @splitIfaceSigmaTy@ on this type: -- -- @ -- ([t, m, a, b], [T t, M m], (a -> m b) -> t a -> m (t b)) -- @ splitIfaceSigmaTy ty = case (bndrs, theta) of ([], []) -> (bndrs, theta, tau) _ -> let (bndrs', theta', tau') = splitIfaceSigmaTy tau in (bndrs ++ bndrs', theta ++ theta', tau') where (bndrs, rho) = split_foralls ty (theta, tau) = split_rho rho split_foralls (IfaceForAllTy bndr ty) = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) } split_foralls rho = ([], rho) split_rho (IfaceFunTy InvisArg ty1 ty2) = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } split_rho tau = ([], tau) suppressIfaceInvisibles :: DynFlags -> [IfaceTyConBinder] -> [a] -> [a] suppressIfaceInvisibles dflags tys xs | gopt Opt_PrintExplicitKinds dflags = xs | otherwise = suppress tys xs where suppress _ [] = [] suppress [] a = a suppress (k:ks) (x:xs) | isInvisibleTyConBinder k = suppress ks xs | otherwise = x : suppress ks xs stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder] stripIfaceInvisVars dflags tyvars | gopt Opt_PrintExplicitKinds dflags = tyvars | otherwise = filterOut isInvisibleTyConBinder tyvars -- | Extract an 'IfaceBndr' from an 'IfaceForAllBndr'. ifForAllBndrVar :: IfaceForAllBndr -> IfaceBndr ifForAllBndrVar = binderVar -- | Extract the variable name from an 'IfaceForAllBndr'. ifForAllBndrName :: IfaceForAllBndr -> IfLclName ifForAllBndrName fab = ifaceBndrName (ifForAllBndrVar fab) -- | Extract an 'IfaceBndr' from an 'IfaceTyConBinder'. ifTyConBinderVar :: IfaceTyConBinder -> IfaceBndr ifTyConBinderVar = binderVar -- | Extract the variable name from an 'IfaceTyConBinder'. ifTyConBinderName :: IfaceTyConBinder -> IfLclName ifTyConBinderName tcb = ifaceBndrName (ifTyConBinderVar tcb) ifTypeIsVarFree :: IfaceType -> Bool -- Returns True if the type definitely has no variables at all -- Just used to control pretty printing ifTypeIsVarFree ty = go ty where go (IfaceTyVar {}) = False go (IfaceFreeTyVar {}) = False go (IfaceAppTy fun args) = go fun && go_args args go (IfaceFunTy _ arg res) = go arg && go res go (IfaceForAllTy {}) = False go (IfaceTyConApp _ args) = go_args args go (IfaceTupleTy _ _ args) = go_args args go (IfaceLitTy _) = True go (IfaceCastTy {}) = False -- Safe go (IfaceCoercionTy {}) = False -- Safe go_args IA_Nil = True go_args (IA_Arg arg _ args) = go arg && go_args args {- Note [Substitution on IfaceType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Substitutions on IfaceType are done only during pretty-printing to construct the result type of a GADT, and does not deal with binders (eg IfaceForAll), so it doesn't need fancy capture stuff. -} type IfaceTySubst = FastStringEnv IfaceType -- Note [Substitution on IfaceType] mkIfaceTySubst :: [(IfLclName,IfaceType)] -> IfaceTySubst -- See Note [Substitution on IfaceType] mkIfaceTySubst eq_spec = mkFsEnv eq_spec inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool -- See Note [Substitution on IfaceType] inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs) substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType -- See Note [Substitution on IfaceType] substIfaceType env ty = go ty where go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv go (IfaceTyVar tv) = substIfaceTyVar env tv go (IfaceAppTy t ts) = IfaceAppTy (go t) (substIfaceAppArgs env ts) go (IfaceFunTy af t1 t2) = IfaceFunTy af (go t1) (go t2) go ty@(IfaceLitTy {}) = ty go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceAppArgs env tys) go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceAppArgs env tys) go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty) go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co) go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co) go_mco IfaceMRefl = IfaceMRefl go_mco (IfaceMCo co) = IfaceMCo $ go_co co go_co (IfaceReflCo ty) = IfaceReflCo (go ty) go_co (IfaceGReflCo r ty mco) = IfaceGReflCo r (go ty) (go_mco mco) go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2) go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos) go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2) go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty) go_co (IfaceFreeCoVar cv) = IfaceFreeCoVar cv go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv go_co (IfaceHoleCo cv) = IfaceHoleCo cv go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos) go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2) go_co (IfaceSymCo co) = IfaceSymCo (go_co co) go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2) go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co) go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co) go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2) go_co (IfaceKindCo co) = IfaceKindCo (go_co co) go_co (IfaceSubCo co) = IfaceSubCo (go_co co) go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos) go_cos = map go_co go_prov IfaceUnsafeCoerceProv = IfaceUnsafeCoerceProv go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co) go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co) go_prov (IfacePluginProv str) = IfacePluginProv str substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs substIfaceAppArgs env args = go args where go IA_Nil = IA_Nil go (IA_Arg ty arg tys) = IA_Arg (substIfaceType env ty) arg (go tys) substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType substIfaceTyVar env tv | Just ty <- lookupFsEnv env tv = ty | otherwise = IfaceTyVar tv {- ************************************************************************ * * Functions over IfaceAppArgs * * ************************************************************************ -} stripInvisArgs :: DynFlags -> IfaceAppArgs -> IfaceAppArgs stripInvisArgs dflags tys | gopt Opt_PrintExplicitKinds dflags = tys | otherwise = suppress_invis tys where suppress_invis c = case c of IA_Nil -> IA_Nil IA_Arg t argf ts | isVisibleArgFlag argf -> IA_Arg t argf $ suppress_invis ts -- Keep recursing through the remainder of the arguments, as it's -- possible that there are remaining invisible ones. -- See the "In type declarations" section of Note [VarBndrs, -- TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. | otherwise -> suppress_invis ts appArgsIfaceTypes :: IfaceAppArgs -> [IfaceType] appArgsIfaceTypes IA_Nil = [] appArgsIfaceTypes (IA_Arg t _ ts) = t : appArgsIfaceTypes ts appArgsIfaceTypesArgFlags :: IfaceAppArgs -> [(IfaceType, ArgFlag)] appArgsIfaceTypesArgFlags IA_Nil = [] appArgsIfaceTypesArgFlags (IA_Arg t a ts) = (t, a) : appArgsIfaceTypesArgFlags ts ifaceVisAppArgsLength :: IfaceAppArgs -> Int ifaceVisAppArgsLength = go 0 where go !n IA_Nil = n go n (IA_Arg _ argf rest) | isVisibleArgFlag argf = go (n+1) rest | otherwise = go n rest {- Note [Suppressing invisible arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use the IfaceAppArgs data type to specify which of the arguments to a type should be displayed when pretty-printing, under the control of -fprint-explicit-kinds. See also Type.filterOutInvisibleTypes. For example, given T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism 'Just :: forall k. k -> 'Maybe k -- Promoted we want T * Tree Int prints as T Tree Int 'Just * prints as Just * For type constructors (IfaceTyConApp), IfaceAppArgs is a quite natural fit, since the corresponding Core constructor: data Type = ... | TyConApp TyCon [Type] Already puts all of its arguments into a list. So when converting a Type to an IfaceType (see toIfaceAppArgsX in ToIface), we simply use the kind of the TyCon (which is cached) to guide the process of converting the argument Types into an IfaceAppArgs list. We also want this behavior for IfaceAppTy, since given: data Proxy (a :: k) f :: forall (t :: forall a. a -> Type). Proxy Type (t Bool True) We want to print the return type as `Proxy (t True)` without the use of -fprint-explicit-kinds (#15330). Accomplishing this is trickier than in the tycon case, because the corresponding Core constructor for IfaceAppTy: data Type = ... | AppTy Type Type Only stores one argument at a time. Therefore, when converting an AppTy to an IfaceAppTy (in toIfaceTypeX in ToIface), we: 1. Flatten the chain of AppTys down as much as possible 2. Use typeKind to determine the function Type's kind 3. Use this kind to guide the process of converting the argument Types into an IfaceAppArgs list. By flattening the arguments like this, we obtain two benefits: (a) We can reuse the same machinery to pretty-print IfaceTyConApp arguments as we do IfaceTyApp arguments, which means that we only need to implement the logic to filter out invisible arguments once. (b) Unlike for tycons, finding the kind of a type in general (through typeKind) is not a constant-time operation, so by flattening the arguments first, we decrease the number of times we have to call typeKind. Note [Pretty-printing invisible arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note [Suppressing invisible arguments] is all about how to avoid printing invisible arguments when the -fprint-explicit-kinds flag is disables. Well, what about when it's enabled? Then we can and should print invisible kind arguments, and this Note explains how we do it. As two running examples, consider the following code: {-# LANGUAGE PolyKinds #-} data T1 a data T2 (a :: k) When displaying these types (with -fprint-explicit-kinds on), we could just do the following: T1 k a T2 k a That certainly gets the job done. But it lacks a crucial piece of information: is the `k` argument inferred or specified? To communicate this, we use visible kind application syntax to distinguish the two cases: T1 @{k} a T2 @k a Here, @{k} indicates that `k` is an inferred argument, and @k indicates that `k` is a specified argument. (See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep for a lengthier explanation on what "inferred" and "specified" mean.) ************************************************************************ * * Pretty-printing * * ************************************************************************ -} if_print_coercions :: SDoc -- ^ if printing coercions -> SDoc -- ^ otherwise -> SDoc if_print_coercions yes no = sdocWithDynFlags $ \dflags -> getPprStyle $ \style -> if gopt Opt_PrintExplicitCoercions dflags || dumpStyle style || debugStyle style then yes else no pprIfaceInfixApp :: PprPrec -> SDoc -> SDoc -> SDoc -> SDoc pprIfaceInfixApp ctxt_prec pp_tc pp_ty1 pp_ty2 = maybeParen ctxt_prec opPrec $ sep [pp_ty1, pp_tc <+> pp_ty2] pprIfacePrefixApp :: PprPrec -> SDoc -> [SDoc] -> SDoc pprIfacePrefixApp ctxt_prec pp_fun pp_tys | null pp_tys = pp_fun | otherwise = maybeParen ctxt_prec appPrec $ hang pp_fun 2 (sep pp_tys) isIfaceTauType :: IfaceType -> Bool isIfaceTauType (IfaceForAllTy _ _) = False isIfaceTauType (IfaceFunTy InvisArg _ _) = False isIfaceTauType _ = True -- ----------------------------- Printing binders ------------------------------------ instance Outputable IfaceBndr where ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr bndr (SuppressBndrSig False) (UseBndrParens False) pprIfaceBndrs :: [IfaceBndr] -> SDoc pprIfaceBndrs bs = sep (map ppr bs) pprIfaceLamBndr :: IfaceLamBndr -> SDoc pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]" pprIfaceIdBndr :: IfaceIdBndr -> SDoc pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty) {- Note [Suppressing binder signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When printing the binders in a 'forall', we want to keep the kind annotations: forall (a :: k). blah ^^^^ good On the other hand, when we print the binders of a data declaration in :info, the kind information would be redundant due to the standalone kind signature: type F :: Symbol -> Type type F (s :: Symbol) = blah ^^^^^^^^^ redundant Here we'd like to omit the kind annotation: type F :: Symbol -> Type type F s = blah -} -- | Do we want to suppress kind annotations on binders? -- See Note [Suppressing binder signatures] newtype SuppressBndrSig = SuppressBndrSig Bool newtype UseBndrParens = UseBndrParens Bool pprIfaceTvBndr :: IfaceTvBndr -> SuppressBndrSig -> UseBndrParens -> SDoc pprIfaceTvBndr (tv, ki) (SuppressBndrSig suppress_sig) (UseBndrParens use_parens) | suppress_sig = ppr tv | isIfaceLiftedTypeKind ki = ppr tv | otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr ki) where maybe_parens | use_parens = parens | otherwise = id pprIfaceTyConBinders :: SuppressBndrSig -> [IfaceTyConBinder] -> SDoc pprIfaceTyConBinders suppress_sig = sep . map go where go :: IfaceTyConBinder -> SDoc go (Bndr (IfaceIdBndr bndr) _) = pprIfaceIdBndr bndr go (Bndr (IfaceTvBndr bndr) vis) = -- See Note [Pretty-printing invisible arguments] case vis of AnonTCB VisArg -> ppr_bndr (UseBndrParens True) AnonTCB InvisArg -> char '@' <> braces (ppr_bndr (UseBndrParens False)) -- The above case is rare. (See Note [AnonTCB InvisArg] in TyCon.) -- Should we print these differently? NamedTCB Required -> ppr_bndr (UseBndrParens True) NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True) NamedTCB Inferred -> char '@' <> braces (ppr_bndr (UseBndrParens False)) where ppr_bndr = pprIfaceTvBndr bndr suppress_sig instance Binary IfaceBndr where put_ bh (IfaceIdBndr aa) = do putByte bh 0 put_ bh aa put_ bh (IfaceTvBndr ab) = do putByte bh 1 put_ bh ab get bh = do h <- getByte bh case h of 0 -> do aa <- get bh return (IfaceIdBndr aa) _ -> do ab <- get bh return (IfaceTvBndr ab) instance Binary IfaceOneShot where put_ bh IfaceNoOneShot = do putByte bh 0 put_ bh IfaceOneShot = do putByte bh 1 get bh = do h <- getByte bh case h of 0 -> do return IfaceNoOneShot _ -> do return IfaceOneShot -- ----------------------------- Printing IfaceType ------------------------------------ --------------------------------- instance Outputable IfaceType where ppr ty = pprIfaceType ty pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc pprIfaceType = pprPrecIfaceType topPrec pprParendIfaceType = pprPrecIfaceType appPrec pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc -- We still need `eliminateRuntimeRep`, since the `pprPrecIfaceType` maybe -- called from other places, besides `:type` and `:info`. pprPrecIfaceType prec ty = eliminateRuntimeRep (ppr_ty prec) ty ppr_sigma :: PprPrec -> IfaceType -> SDoc ppr_sigma ctxt_prec ty = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty) ppr_ty :: PprPrec -> IfaceType -> SDoc ppr_ty ctxt_prec ty@(IfaceForAllTy {}) = ppr_sigma ctxt_prec ty ppr_ty ctxt_prec ty@(IfaceFunTy InvisArg _ _) = ppr_sigma ctxt_prec ty ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar! ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [TcTyVars in IfaceType] ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n -- Function types ppr_ty ctxt_prec (IfaceFunTy _ ty1 ty2) -- Should be VisArg = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. maybeParen ctxt_prec funPrec $ sep [ppr_ty funPrec ty1, sep (ppr_fun_tail ty2)] where ppr_fun_tail (IfaceFunTy VisArg ty1 ty2) = (arrow <+> ppr_ty funPrec ty1) : ppr_fun_tail ty2 ppr_fun_tail other_ty = [arrow <+> pprIfaceType other_ty] ppr_ty ctxt_prec (IfaceAppTy t ts) = if_print_coercions ppr_app_ty ppr_app_ty_no_casts where ppr_app_ty = sdocWithDynFlags $ \dflags -> pprIfacePrefixApp ctxt_prec (ppr_ty funPrec t) (map (ppr_app_arg appPrec) (tys_wo_kinds dflags)) tys_wo_kinds dflags = appArgsIfaceTypesArgFlags $ stripInvisArgs dflags ts -- Strip any casts from the head of the application ppr_app_ty_no_casts = case t of IfaceCastTy head _ -> ppr_ty ctxt_prec (mk_app_tys head ts) _ -> ppr_app_ty mk_app_tys :: IfaceType -> IfaceAppArgs -> IfaceType mk_app_tys (IfaceTyConApp tc tys1) tys2 = IfaceTyConApp tc (tys1 `mappend` tys2) mk_app_tys t1 tys2 = IfaceAppTy t1 tys2 ppr_ty ctxt_prec (IfaceCastTy ty co) = if_print_coercions (parens (ppr_ty topPrec ty <+> text "|>" <+> ppr co)) (ppr_ty ctxt_prec ty) ppr_ty ctxt_prec (IfaceCoercionTy co) = if_print_coercions (ppr_co ctxt_prec co) (text "<>") {- Note [Defaulting RuntimeRep variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ RuntimeRep variables are considered by many (most?) users to be little more than syntactic noise. When the notion was introduced there was a signficant and understandable push-back from those with pedagogy in mind, which argued that RuntimeRep variables would throw a wrench into nearly any teach approach since they appear in even the lowly ($) function's type, ($) :: forall (w :: RuntimeRep) a (b :: TYPE w). (a -> b) -> a -> b which is significantly less readable than its non RuntimeRep-polymorphic type of ($) :: (a -> b) -> a -> b Moreover, unboxed types don't appear all that often in run-of-the-mill Haskell programs, so it makes little sense to make all users pay this syntactic overhead. For this reason it was decided that we would hide RuntimeRep variables for now (see #11549). We do this by defaulting all type variables of kind RuntimeRep to LiftedRep. This is done in a pass right before pretty-printing (defaultRuntimeRepVars, controlled by -fprint-explicit-runtime-reps) This applies to /quantified/ variables like 'w' above. What about variables that are /free/ in the type being printed, which certainly happens in error messages. Suppose (#16074) we are reporting a mismatch between two skolems (a :: RuntimeRep) ~ (b :: RuntimeRep) We certainly don't want to say "Can't match LiftedRep ~ LiftedRep"! But if we are printing the type (forall (a :: Type r). blah we do want to turn that (free) r into LiftedRep, so it prints as (forall a. blah) Conclusion: keep track of whether we we are in the kind of a binder; ohly if so, convert free RuntimeRep variables to LiftedRep. -} -- | Default 'RuntimeRep' variables to 'LiftedPtr'. e.g. -- -- @ -- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r). -- (a -> b) -> a -> b -- @ -- -- turns in to, -- -- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @ -- -- We do this to prevent RuntimeRep variables from incurring a significant -- syntactic overhead in otherwise simple type signatures (e.g. ($)). See -- Note [Defaulting RuntimeRep variables] and #11549 for further discussion. -- defaultRuntimeRepVars :: IfaceType -> IfaceType defaultRuntimeRepVars ty = go False emptyFsEnv ty where go :: Bool -- True <=> Inside the kind of a binder -> FastStringEnv () -- Set of enclosing forall-ed RuntimeRep variables -> IfaceType -- (replace them with LiftedRep) -> IfaceType go ink subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) | isRuntimeRep var_kind , isInvisibleArgFlag argf -- Don't default *visible* quantification -- or we get the mess in #13963 = let subs' = extendFsEnv subs var () -- Record that we should replace it with LiftedRep, -- and recurse, discarding the forall in go ink subs' ty go ink subs (IfaceForAllTy bndr ty) = IfaceForAllTy (go_ifacebndr subs bndr) (go ink subs ty) go _ subs ty@(IfaceTyVar tv) | tv `elemFsEnv` subs = IfaceTyConApp liftedRep IA_Nil | otherwise = ty go in_kind _ ty@(IfaceFreeTyVar tv) -- See Note [Defaulting RuntimeRep variables], about free vars | in_kind && Type.isRuntimeRepTy (tyVarKind tv) = IfaceTyConApp liftedRep IA_Nil | otherwise = ty go ink subs (IfaceTyConApp tc tc_args) = IfaceTyConApp tc (go_args ink subs tc_args) go ink subs (IfaceTupleTy sort is_prom tc_args) = IfaceTupleTy sort is_prom (go_args ink subs tc_args) go ink subs (IfaceFunTy af arg res) = IfaceFunTy af (go ink subs arg) (go ink subs res) go ink subs (IfaceAppTy t ts) = IfaceAppTy (go ink subs t) (go_args ink subs ts) go ink subs (IfaceCastTy x co) = IfaceCastTy (go ink subs x) co go _ _ ty@(IfaceLitTy {}) = ty go _ _ ty@(IfaceCoercionTy {}) = ty go_ifacebndr :: FastStringEnv () -> IfaceForAllBndr -> IfaceForAllBndr go_ifacebndr subs (Bndr (IfaceIdBndr (n, t)) argf) = Bndr (IfaceIdBndr (n, go True subs t)) argf go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf) = Bndr (IfaceTvBndr (n, go True subs t)) argf go_args :: Bool -> FastStringEnv () -> IfaceAppArgs -> IfaceAppArgs go_args _ _ IA_Nil = IA_Nil go_args ink subs (IA_Arg ty argf args) = IA_Arg (go ink subs ty) argf (go_args ink subs args) liftedRep :: IfaceTyCon liftedRep = IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon) where dc_name = getName liftedRepDataConTyCon isRuntimeRep :: IfaceType -> Bool isRuntimeRep (IfaceTyConApp tc _) = tc `ifaceTyConHasKey` runtimeRepTyConKey isRuntimeRep _ = False eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc eliminateRuntimeRep f ty = sdocWithDynFlags $ \dflags -> getPprStyle $ \sty -> if userStyle sty && not (gopt Opt_PrintExplicitRuntimeReps dflags) then f (defaultRuntimeRepVars ty) else f ty instance Outputable IfaceAppArgs where ppr tca = pprIfaceAppArgs tca pprIfaceAppArgs, pprParendIfaceAppArgs :: IfaceAppArgs -> SDoc pprIfaceAppArgs = ppr_app_args topPrec pprParendIfaceAppArgs = ppr_app_args appPrec ppr_app_args :: PprPrec -> IfaceAppArgs -> SDoc ppr_app_args ctx_prec = go where go :: IfaceAppArgs -> SDoc go IA_Nil = empty go (IA_Arg t argf ts) = ppr_app_arg ctx_prec (t, argf) <+> go ts -- See Note [Pretty-printing invisible arguments] ppr_app_arg :: PprPrec -> (IfaceType, ArgFlag) -> SDoc ppr_app_arg ctx_prec (t, argf) = sdocWithDynFlags $ \dflags -> let print_kinds = gopt Opt_PrintExplicitKinds dflags in case argf of Required -> ppr_ty ctx_prec t Specified | print_kinds -> char '@' <> ppr_ty appPrec t Inferred | print_kinds -> char '@' <> braces (ppr_ty topPrec t) _ -> empty ------------------- pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc pprIfaceForAllPart tvs ctxt sdoc = ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc -- | Like 'pprIfaceForAllPart', but always uses an explicit @forall@. pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc pprIfaceForAllPartMust tvs ctxt sdoc = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc pprIfaceForAllCoPart tvs sdoc = sep [ pprIfaceForAllCo tvs, sdoc ] ppr_iface_forall_part :: ShowForAllFlag -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc ppr_iface_forall_part show_forall tvs ctxt sdoc = sep [ case show_forall of ShowForAllMust -> pprIfaceForAll tvs ShowForAllWhen -> pprUserIfaceForAll tvs , pprIfaceContextArr ctxt , sdoc] -- | Render the "forall ... ." or "forall ... ->" bit of a type. pprIfaceForAll :: [IfaceForAllBndr] -> SDoc pprIfaceForAll [] = empty pprIfaceForAll bndrs@(Bndr _ vis : _) = sep [ add_separator (forAllLit <+> fsep docs) , pprIfaceForAll bndrs' ] where (bndrs', docs) = ppr_itv_bndrs bndrs vis add_separator stuff = case vis of Required -> stuff <+> arrow _inv -> stuff <> dot -- | Render the ... in @(forall ... .)@ or @(forall ... ->)@. -- Returns both the list of not-yet-rendered binders and the doc. -- No anonymous binders here! ppr_itv_bndrs :: [IfaceForAllBndr] -> ArgFlag -- ^ visibility of the first binder in the list -> ([IfaceForAllBndr], [SDoc]) ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1 | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in (bndrs', pprIfaceForAllBndr bndr : doc) | otherwise = (all_bndrs, []) ppr_itv_bndrs [] _ = ([], []) pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc pprIfaceForAllCo [] = empty pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc pprIfaceForAllBndr bndr = case bndr of Bndr (IfaceTvBndr tv) Inferred -> sdocWithDynFlags $ \dflags -> if gopt Opt_PrintExplicitForalls dflags then braces $ pprIfaceTvBndr tv suppress_sig (UseBndrParens False) else pprIfaceTvBndr tv suppress_sig (UseBndrParens True) Bndr (IfaceTvBndr tv) _ -> pprIfaceTvBndr tv suppress_sig (UseBndrParens True) Bndr (IfaceIdBndr idv) _ -> pprIfaceIdBndr idv where -- See Note [Suppressing binder signatures] in IfaceType suppress_sig = SuppressBndrSig False pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc pprIfaceForAllCoBndr (tv, kind_co) = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co) -- | Show forall flag -- -- Unconditionally show the forall quantifier with ('ShowForAllMust') -- or when ('ShowForAllWhen') the names used are free in the binder -- or when compiling with -fprint-explicit-foralls. data ShowForAllFlag = ShowForAllMust | ShowForAllWhen pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc pprIfaceSigmaType show_forall ty = eliminateRuntimeRep ppr_fn ty where ppr_fn iface_ty = let (tvs, theta, tau) = splitIfaceSigmaTy iface_ty in ppr_iface_forall_part show_forall tvs theta (ppr tau) pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc pprUserIfaceForAll tvs = sdocWithDynFlags $ \dflags -> -- See Note [When to print foralls] in this module. ppWhen (any tv_has_kind_var tvs || any tv_is_required tvs || gopt Opt_PrintExplicitForalls dflags) $ pprIfaceForAll tvs where tv_has_kind_var (Bndr (IfaceTvBndr (_,kind)) _) = not (ifTypeIsVarFree kind) tv_has_kind_var _ = False tv_is_required = isVisibleArgFlag . binderArgFlag {- Note [When to print foralls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We opt to explicitly pretty-print `forall`s if any of the following criteria are met: 1. -fprint-explicit-foralls is on. 2. A bound type variable has a polymorphic kind. E.g., forall k (a::k). Proxy a -> Proxy a Since a's kind mentions a variable k, we print the foralls. 3. A bound type variable is a visible argument (#14238). Suppose we are printing the kind of: T :: forall k -> k -> Type The "forall k ->" notation means that this kind argument is required. That is, it must be supplied at uses of T. E.g., f :: T (Type->Type) Monad -> Int So we print an explicit "T :: forall k -> k -> Type", because omitting it and printing "T :: k -> Type" would be utterly misleading. See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. N.B. Until now (Aug 2018) we didn't check anything for coercion variables. Note [Printing foralls in type family instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use the same criteria as in Note [When to print foralls] to determine whether a type family instance should be pretty-printed with an explicit `forall`. Example: type family Foo (a :: k) :: k where Foo Maybe = [] Foo (a :: Type) = Int Foo a = a Without -fprint-explicit-foralls enabled, this will be pretty-printed as: type family Foo (a :: k) :: k where Foo Maybe = [] Foo a = Int forall k (a :: k). Foo a = a Note that only the third equation has an explicit forall, since it has a type variable with a non-Type kind. (If -fprint-explicit-foralls were enabled, then the second equation would be preceded with `forall a.`.) There is one tricky point in the implementation: what visibility do we give the type variables in a type family instance? Type family instances only store type *variables*, not type variable *binders*, and only the latter has visibility information. We opt to default the visibility of each of these type variables to Specified because users can't ever instantiate these variables manually, so the choice of visibility is only relevant to pretty-printing. (This is why the `k` in `forall k (a :: k). ...` above is printed the way it is, even though it wasn't written explicitly in the original source code.) We adopt the same strategy for data family instances. Example: data family DF (a :: k) data instance DF '[a, b] = DFList That data family instance is pretty-printed as: data instance forall j (a :: j) (b :: j). DF '[a, b] = DFList This is despite that the representation tycon for this data instance (call it $DF:List) actually has different visibilities for its binders. However, the visibilities of these binders are utterly irrelevant to the programmer, who cares only about the specificity of variables in `DF`'s type, not $DF:List's type. Therefore, we opt to pretty-print all variables in data family instances as Specified. Note [Printing promoted type constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this GHCi session (#14343) > _ :: Proxy '[ 'True ] error: Found hole: _ :: Proxy '['True] This would be bad, because the '[' looks like a character literal. Solution: in type-level lists and tuples, add a leading space if the first type is itself promoted. See pprSpaceIfPromotedTyCon. -} ------------------- -- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'. -- See Note [Printing promoted type constructors] pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _) = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of IsPromoted -> (space <>) _ -> id pprSpaceIfPromotedTyCon _ = id -- See equivalent function in TyCoRep.hs pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc -- Given a type-level list (t1 ': t2), see if we can print -- it in list notation [t1, ...]. -- Precondition: Opt_PrintExplicitKinds is off pprIfaceTyList ctxt_prec ty1 ty2 = case gather ty2 of (arg_tys, Nothing) -> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys))))) (arg_tys, Just tl) -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1) 2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]]) where gather :: IfaceType -> ([IfaceType], Maybe IfaceType) -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl gather (IfaceTyConApp tc tys) | tc `ifaceTyConHasKey` consDataConKey , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys , isInvisibleArgFlag argf , (args, tl) <- gather ty2 = (ty1:args, tl) | tc `ifaceTyConHasKey` nilDataConKey = ([], Nothing) gather ty = ([], Just ty) pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc pprTyTcApp ctxt_prec tc tys = sdocWithDynFlags $ \dflags -> getPprStyle $ \style -> pprTyTcApp' ctxt_prec tc tys dflags style pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> DynFlags -> PprStyle -> SDoc pprTyTcApp' ctxt_prec tc tys dflags style | ifaceTyConName tc `hasKey` ipClassKey , IA_Arg (IfaceLitTy (IfaceStrTyLit n)) Required (IA_Arg ty Required IA_Nil) <- tys = maybeParen ctxt_prec funPrec $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty | IfaceTupleTyCon arity sort <- ifaceTyConSort info , not (debugStyle style) , arity == ifaceVisAppArgsLength tys = pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys | IfaceSumTyCon arity <- ifaceTyConSort info = pprSum arity (ifaceTyConIsPromoted info) tys | tc `ifaceTyConHasKey` consDataConKey , not (gopt Opt_PrintExplicitKinds dflags) , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys , isInvisibleArgFlag argf = pprIfaceTyList ctxt_prec ty1 ty2 | tc `ifaceTyConHasKey` tYPETyConKey , IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys , rep `ifaceTyConHasKey` liftedRepDataConKey = kindType | otherwise = getPprDebug $ \dbg -> if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey -- Suppress detail unles you _really_ want to see -> text "(TypeError ...)" | Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys) -> doc | otherwise -> ppr_iface_tc_app ppr_app_arg ctxt_prec tc tys_wo_kinds where info = ifaceTyConInfo tc tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs dflags tys -- | Pretty-print a type-level equality. -- Returns (Just doc) if the argument is a /saturated/ application -- of eqTyCon (~) -- eqPrimTyCon (~#) -- eqReprPrimTyCon (~R#) -- heqTyCon (~~) -- -- See Note [Equality predicates in IfaceType] -- and Note [The equality types story] in TysPrim ppr_equality :: PprPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc ppr_equality ctxt_prec tc args | hetero_eq_tc , [k1, k2, t1, t2] <- args = Just $ print_equality (k1, k2, t1, t2) | hom_eq_tc , [k, t1, t2] <- args = Just $ print_equality (k, k, t1, t2) | otherwise = Nothing where homogeneous = tc_name `hasKey` eqTyConKey -- (~) || hetero_tc_used_homogeneously where hetero_tc_used_homogeneously = case ifaceTyConSort $ ifaceTyConInfo tc of IfaceEqualityTyCon -> True _other -> False -- True <=> a heterogeneous equality whose arguments -- are (in this case) of the same kind tc_name = ifaceTyConName tc pp = ppr_ty hom_eq_tc = tc_name `hasKey` eqTyConKey -- (~) hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey -- (~#) || tc_name `hasKey` eqReprPrimTyConKey -- (~R#) || tc_name `hasKey` heqTyConKey -- (~~) nominal_eq_tc = tc_name `hasKey` heqTyConKey -- (~~) || tc_name `hasKey` eqPrimTyConKey -- (~#) print_equality args = sdocWithDynFlags $ \dflags -> getPprStyle $ \style -> print_equality' args style dflags print_equality' (ki1, ki2, ty1, ty2) style dflags | -- If -fprint-equality-relations is on, just print the original TyCon print_eqs = ppr_infix_eq (ppr tc) | -- Homogeneous use of heterogeneous equality (ty1 ~~ ty2) -- or unlifted equality (ty1 ~# ty2) nominal_eq_tc, homogeneous = ppr_infix_eq (text "~") | -- Heterogeneous use of unlifted equality (ty1 ~# ty2) not homogeneous = ppr_infix_eq (ppr heqTyCon) | -- Homogeneous use of representational unlifted equality (ty1 ~R# ty2) tc_name `hasKey` eqReprPrimTyConKey, homogeneous = let ki | print_kinds = [pp appPrec ki1] | otherwise = [] in pprIfacePrefixApp ctxt_prec (ppr coercibleTyCon) (ki ++ [pp appPrec ty1, pp appPrec ty2]) -- The other cases work as you'd expect | otherwise = ppr_infix_eq (ppr tc) where ppr_infix_eq :: SDoc -> SDoc ppr_infix_eq eq_op = pprIfaceInfixApp ctxt_prec eq_op (pp_ty_ki ty1 ki1) (pp_ty_ki ty2 ki2) where pp_ty_ki ty ki | print_kinds = parens (pp topPrec ty <+> dcolon <+> pp opPrec ki) | otherwise = pp opPrec ty print_kinds = gopt Opt_PrintExplicitKinds dflags print_eqs = gopt Opt_PrintEqualityRelations dflags || dumpStyle style || debugStyle style pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app (\prec (co, _) -> ppr_co prec co) ctxt_prec tc (map (, Required) tys) -- We are trying to re-use ppr_iface_tc_app here, which requires its -- arguments to be accompanied by visibilities. But visibility is -- irrelevant when printing coercions, so just default everything to -- Required. -- | Pretty-prints an application of a type constructor to some arguments -- (whose visibilities are known). This is polymorphic (over @a@) since we use -- this function to pretty-print two different things: -- -- 1. Types (from `pprTyTcApp'`) -- -- 2. Coercions (from 'pprIfaceCoTcApp') ppr_iface_tc_app :: (PprPrec -> (a, ArgFlag) -> SDoc) -> PprPrec -> IfaceTyCon -> [(a, ArgFlag)] -> SDoc ppr_iface_tc_app pp _ tc [ty] | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty) ppr_iface_tc_app pp ctxt_prec tc tys | tc `ifaceTyConHasKey` liftedTypeKindTyConKey = kindType | not (isSymOcc (nameOccName (ifaceTyConName tc))) = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys) | [ ty1@(_, Required) , ty2@(_, Required) ] <- tys -- Infix, two visible arguments (we know nothing of precedence though). -- Don't apply this special case if one of the arguments is invisible, -- lest we print something like (@LiftedRep -> @LiftedRep) (#15941). = pprIfaceInfixApp ctxt_prec (ppr tc) (pp opPrec ty1) (pp opPrec ty2) | otherwise = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys) pprSum :: Arity -> PromotionFlag -> IfaceAppArgs -> SDoc pprSum _arity is_promoted args = -- drop the RuntimeRep vars. -- See Note [Unboxed tuple RuntimeRep vars] in TyCon let tys = appArgsIfaceTypes args args' = drop (length tys `div` 2) tys in pprPromotionQuoteI is_promoted <> sumParens (pprWithBars (ppr_ty topPrec) args') pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc pprTuple ctxt_prec sort promoted args = case promoted of IsPromoted -> let tys = appArgsIfaceTypes args args' = drop (length tys `div` 2) tys spaceIfPromoted = case args' of arg0:_ -> pprSpaceIfPromotedTyCon arg0 _ -> id in ppr_tuple_app args' $ pprPromotionQuoteI IsPromoted <> tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args')) NotPromoted | ConstraintTuple <- sort , IA_Nil <- args -> maybeParen ctxt_prec sigPrec $ text "() :: Constraint" | otherwise -> -- drop the RuntimeRep vars. -- See Note [Unboxed tuple RuntimeRep vars] in TyCon let tys = appArgsIfaceTypes args args' = case sort of UnboxedTuple -> drop (length tys `div` 2) tys _ -> tys in ppr_tuple_app args' $ pprPromotionQuoteI promoted <> tupleParens sort (pprWithCommas pprIfaceType args') where ppr_tuple_app :: [IfaceType] -> SDoc -> SDoc ppr_tuple_app args_wo_runtime_reps ppr_args_w_parens -- Special-case unary boxed tuples so that they are pretty-printed as -- `Unit x`, not `(x)` | [_] <- args_wo_runtime_reps , BoxedTuple <- sort = let unit_tc_info = IfaceTyConInfo promoted IfaceNormalTyCon unit_tc = IfaceTyCon (tupleTyConName sort 1) unit_tc_info in pprPrecIfaceType ctxt_prec $ IfaceTyConApp unit_tc args | otherwise = ppr_args_w_parens pprIfaceTyLit :: IfaceTyLit -> SDoc pprIfaceTyLit (IfaceNumTyLit n) = integer n pprIfaceTyLit (IfaceStrTyLit n) = text (show n) pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc pprIfaceCoercion = ppr_co topPrec pprParendIfaceCoercion = ppr_co appPrec ppr_co :: PprPrec -> IfaceCoercion -> SDoc ppr_co _ (IfaceReflCo ty) = angleBrackets (ppr ty) <> ppr_role Nominal ppr_co _ (IfaceGReflCo r ty IfaceMRefl) = angleBrackets (ppr ty) <> ppr_role r ppr_co ctxt_prec (IfaceGReflCo r ty (IfaceMCo co)) = ppr_special_co ctxt_prec (text "GRefl" <+> ppr r <+> pprParendIfaceType ty) [co] ppr_co ctxt_prec (IfaceFunCo r co1 co2) = maybeParen ctxt_prec funPrec $ sep (ppr_co funPrec co1 : ppr_fun_tail co2) where ppr_fun_tail (IfaceFunCo r co1 co2) = (arrow <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail co2 ppr_fun_tail other_co = [arrow <> ppr_role r <+> pprIfaceCoercion other_co] ppr_co _ (IfaceTyConAppCo r tc cos) = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r ppr_co ctxt_prec (IfaceAppCo co1 co2) = maybeParen ctxt_prec appPrec $ ppr_co funPrec co1 <+> pprParendIfaceCoercion co2 ppr_co ctxt_prec co@(IfaceForAllCo {}) = maybeParen ctxt_prec funPrec $ pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co) where (tvs, inner_co) = split_co co split_co (IfaceForAllCo (IfaceTvBndr (name, _)) kind_co co') = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') split_co (IfaceForAllCo (IfaceIdBndr (name, _)) kind_co co') = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') split_co co' = ([], co') -- Why these three? See Note [TcTyVars in IfaceType] ppr_co _ (IfaceFreeCoVar covar) = ppr covar ppr_co _ (IfaceCoVarCo covar) = ppr covar ppr_co _ (IfaceHoleCo covar) = braces (ppr covar) ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2) = maybeParen ctxt_prec appPrec $ text "UnsafeCo" <+> ppr r <+> pprParendIfaceType ty1 <+> pprParendIfaceType ty2 ppr_co _ (IfaceUnivCo prov role ty1 ty2) = text "Univ" <> (parens $ sep [ ppr role <+> pprIfaceUnivCoProv prov , dcolon <+> ppr ty1 <> comma <+> ppr ty2 ]) ppr_co ctxt_prec (IfaceInstCo co ty) = maybeParen ctxt_prec appPrec $ text "Inst" <+> pprParendIfaceCoercion co <+> pprParendIfaceCoercion ty ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos) = maybeParen ctxt_prec appPrec $ ppr tc <+> parens (interpp'SP cos) ppr_co ctxt_prec (IfaceAxiomInstCo n i cos) = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos ppr_co ctxt_prec (IfaceSymCo co) = ppr_special_co ctxt_prec (text "Sym") [co] ppr_co ctxt_prec (IfaceTransCo co1 co2) = maybeParen ctxt_prec opPrec $ ppr_co opPrec co1 <+> semi <+> ppr_co opPrec co2 ppr_co ctxt_prec (IfaceNthCo d co) = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co] ppr_co ctxt_prec (IfaceLRCo lr co) = ppr_special_co ctxt_prec (ppr lr) [co] ppr_co ctxt_prec (IfaceSubCo co) = ppr_special_co ctxt_prec (text "Sub") [co] ppr_co ctxt_prec (IfaceKindCo co) = ppr_special_co ctxt_prec (text "Kind") [co] ppr_special_co :: PprPrec -> SDoc -> [IfaceCoercion] -> SDoc ppr_special_co ctxt_prec doc cos = maybeParen ctxt_prec appPrec (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))]) ppr_role :: Role -> SDoc ppr_role r = underscore <> pp_role where pp_role = case r of Nominal -> char 'N' Representational -> char 'R' Phantom -> char 'P' ------------------ pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc pprIfaceUnivCoProv IfaceUnsafeCoerceProv = text "unsafe" pprIfaceUnivCoProv (IfacePhantomProv co) = text "phantom" <+> pprParendIfaceCoercion co pprIfaceUnivCoProv (IfaceProofIrrelProv co) = text "irrel" <+> pprParendIfaceCoercion co pprIfaceUnivCoProv (IfacePluginProv s) = text "plugin" <+> doubleQuotes (text s) ------------------- instance Outputable IfaceTyCon where ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) pprPromotionQuote :: IfaceTyCon -> SDoc pprPromotionQuote tc = pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc pprPromotionQuoteI :: PromotionFlag -> SDoc pprPromotionQuoteI NotPromoted = empty pprPromotionQuoteI IsPromoted = char '\'' instance Outputable IfaceCoercion where ppr = pprIfaceCoercion instance Binary IfaceTyCon where put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i get bh = do n <- get bh i <- get bh return (IfaceTyCon n i) instance Binary IfaceTyConSort where put_ bh IfaceNormalTyCon = putByte bh 0 put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity put_ bh IfaceEqualityTyCon = putByte bh 3 get bh = do n <- getByte bh case n of 0 -> return IfaceNormalTyCon 1 -> IfaceTupleTyCon <$> get bh <*> get bh 2 -> IfaceSumTyCon <$> get bh _ -> return IfaceEqualityTyCon instance Binary IfaceTyConInfo where put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s get bh = IfaceTyConInfo <$> get bh <*> get bh instance Outputable IfaceTyLit where ppr = pprIfaceTyLit instance Binary IfaceTyLit where put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n get bh = do tag <- getByte bh case tag of 1 -> do { n <- get bh ; return (IfaceNumTyLit n) } 2 -> do { n <- get bh ; return (IfaceStrTyLit n) } _ -> panic ("get IfaceTyLit " ++ show tag) instance Binary IfaceAppArgs where put_ bh tk = case tk of IA_Arg t a ts -> putByte bh 0 >> put_ bh t >> put_ bh a >> put_ bh ts IA_Nil -> putByte bh 1 get bh = do c <- getByte bh case c of 0 -> do t <- get bh a <- get bh ts <- get bh return $! IA_Arg t a ts 1 -> return IA_Nil _ -> panic ("get IfaceAppArgs " ++ show c) ------------------- -- Some notes about printing contexts -- -- In the event that we are printing a singleton context (e.g. @Eq a@) we can -- omit parentheses. However, we must take care to set the precedence correctly -- to opPrec, since something like @a :~: b@ must be parenthesized (see -- #9658). -- -- When printing a larger context we use 'fsep' instead of 'sep' so that -- the context doesn't get displayed as a giant column. Rather than, -- instance (Eq a, -- Eq b, -- Eq c, -- Eq d, -- Eq e, -- Eq f, -- Eq g, -- Eq h, -- Eq i, -- Eq j, -- Eq k, -- Eq l) => -- Eq (a, b, c, d, e, f, g, h, i, j, k, l) -- -- we want -- -- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, -- Eq j, Eq k, Eq l) => -- Eq (a, b, c, d, e, f, g, h, i, j, k, l) -- | Prints "(C a, D b) =>", including the arrow. -- Used when we want to print a context in a type, so we -- use 'funPrec' to decide whether to parenthesise a singleton -- predicate; e.g. Num a => a -> a pprIfaceContextArr :: [IfacePredType] -> SDoc pprIfaceContextArr [] = empty pprIfaceContextArr [pred] = ppr_ty funPrec pred <+> darrow pprIfaceContextArr preds = ppr_parend_preds preds <+> darrow -- | Prints a context or @()@ if empty -- You give it the context precedence pprIfaceContext :: PprPrec -> [IfacePredType] -> SDoc pprIfaceContext _ [] = text "()" pprIfaceContext prec [pred] = ppr_ty prec pred pprIfaceContext _ preds = ppr_parend_preds preds ppr_parend_preds :: [IfacePredType] -> SDoc ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds))) instance Binary IfaceType where put_ _ (IfaceFreeTyVar tv) = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv) put_ bh (IfaceForAllTy aa ab) = do putByte bh 0 put_ bh aa put_ bh ab put_ bh (IfaceTyVar ad) = do putByte bh 1 put_ bh ad put_ bh (IfaceAppTy ae af) = do putByte bh 2 put_ bh ae put_ bh af put_ bh (IfaceFunTy af ag ah) = do putByte bh 3 put_ bh af put_ bh ag put_ bh ah put_ bh (IfaceTyConApp tc tys) = do { putByte bh 5; put_ bh tc; put_ bh tys } put_ bh (IfaceCastTy a b) = do { putByte bh 6; put_ bh a; put_ bh b } put_ bh (IfaceCoercionTy a) = do { putByte bh 7; put_ bh a } put_ bh (IfaceTupleTy s i tys) = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys } put_ bh (IfaceLitTy n) = do { putByte bh 9; put_ bh n } get bh = do h <- getByte bh case h of 0 -> do aa <- get bh ab <- get bh return (IfaceForAllTy aa ab) 1 -> do ad <- get bh return (IfaceTyVar ad) 2 -> do ae <- get bh af <- get bh return (IfaceAppTy ae af) 3 -> do af <- get bh ag <- get bh ah <- get bh return (IfaceFunTy af ag ah) 5 -> do { tc <- get bh; tys <- get bh ; return (IfaceTyConApp tc tys) } 6 -> do { a <- get bh; b <- get bh ; return (IfaceCastTy a b) } 7 -> do { a <- get bh ; return (IfaceCoercionTy a) } 8 -> do { s <- get bh; i <- get bh; tys <- get bh ; return (IfaceTupleTy s i tys) } _ -> do n <- get bh return (IfaceLitTy n) instance Binary IfaceMCoercion where put_ bh IfaceMRefl = do putByte bh 1 put_ bh (IfaceMCo co) = do putByte bh 2 put_ bh co get bh = do tag <- getByte bh case tag of 1 -> return IfaceMRefl 2 -> do a <- get bh return $ IfaceMCo a _ -> panic ("get IfaceMCoercion " ++ show tag) instance Binary IfaceCoercion where put_ bh (IfaceReflCo a) = do putByte bh 1 put_ bh a put_ bh (IfaceGReflCo a b c) = do putByte bh 2 put_ bh a put_ bh b put_ bh c put_ bh (IfaceFunCo a b c) = do putByte bh 3 put_ bh a put_ bh b put_ bh c put_ bh (IfaceTyConAppCo a b c) = do putByte bh 4 put_ bh a put_ bh b put_ bh c put_ bh (IfaceAppCo a b) = do putByte bh 5 put_ bh a put_ bh b put_ bh (IfaceForAllCo a b c) = do putByte bh 6 put_ bh a put_ bh b put_ bh c put_ bh (IfaceCoVarCo a) = do putByte bh 7 put_ bh a put_ bh (IfaceAxiomInstCo a b c) = do putByte bh 8 put_ bh a put_ bh b put_ bh c put_ bh (IfaceUnivCo a b c d) = do putByte bh 9 put_ bh a put_ bh b put_ bh c put_ bh d put_ bh (IfaceSymCo a) = do putByte bh 10 put_ bh a put_ bh (IfaceTransCo a b) = do putByte bh 11 put_ bh a put_ bh b put_ bh (IfaceNthCo a b) = do putByte bh 12 put_ bh a put_ bh b put_ bh (IfaceLRCo a b) = do putByte bh 13 put_ bh a put_ bh b put_ bh (IfaceInstCo a b) = do putByte bh 14 put_ bh a put_ bh b put_ bh (IfaceKindCo a) = do putByte bh 15 put_ bh a put_ bh (IfaceSubCo a) = do putByte bh 16 put_ bh a put_ bh (IfaceAxiomRuleCo a b) = do putByte bh 17 put_ bh a put_ bh b put_ _ (IfaceFreeCoVar cv) = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv) put_ _ (IfaceHoleCo cv) = pprPanic "Can't serialise IfaceHoleCo" (ppr cv) -- See Note [Holes in IfaceCoercion] get bh = do tag <- getByte bh case tag of 1 -> do a <- get bh return $ IfaceReflCo a 2 -> do a <- get bh b <- get bh c <- get bh return $ IfaceGReflCo a b c 3 -> do a <- get bh b <- get bh c <- get bh return $ IfaceFunCo a b c 4 -> do a <- get bh b <- get bh c <- get bh return $ IfaceTyConAppCo a b c 5 -> do a <- get bh b <- get bh return $ IfaceAppCo a b 6 -> do a <- get bh b <- get bh c <- get bh return $ IfaceForAllCo a b c 7 -> do a <- get bh return $ IfaceCoVarCo a 8 -> do a <- get bh b <- get bh c <- get bh return $ IfaceAxiomInstCo a b c 9 -> do a <- get bh b <- get bh c <- get bh d <- get bh return $ IfaceUnivCo a b c d 10-> do a <- get bh return $ IfaceSymCo a 11-> do a <- get bh b <- get bh return $ IfaceTransCo a b 12-> do a <- get bh b <- get bh return $ IfaceNthCo a b 13-> do a <- get bh b <- get bh return $ IfaceLRCo a b 14-> do a <- get bh b <- get bh return $ IfaceInstCo a b 15-> do a <- get bh return $ IfaceKindCo a 16-> do a <- get bh return $ IfaceSubCo a 17-> do a <- get bh b <- get bh return $ IfaceAxiomRuleCo a b _ -> panic ("get IfaceCoercion " ++ show tag) instance Binary IfaceUnivCoProv where put_ bh IfaceUnsafeCoerceProv = putByte bh 1 put_ bh (IfacePhantomProv a) = do putByte bh 2 put_ bh a put_ bh (IfaceProofIrrelProv a) = do putByte bh 3 put_ bh a put_ bh (IfacePluginProv a) = do putByte bh 4 put_ bh a get bh = do tag <- getByte bh case tag of 1 -> return $ IfaceUnsafeCoerceProv 2 -> do a <- get bh return $ IfacePhantomProv a 3 -> do a <- get bh return $ IfaceProofIrrelProv a 4 -> do a <- get bh return $ IfacePluginProv a _ -> panic ("get IfaceUnivCoProv " ++ show tag) instance Binary (DefMethSpec IfaceType) where put_ bh VanillaDM = putByte bh 0 put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t get bh = do h <- getByte bh case h of 0 -> return VanillaDM _ -> do { t <- get bh; return (GenericDM t) } instance NFData IfaceType where rnf = \case IfaceFreeTyVar f1 -> f1 `seq` () IfaceTyVar f1 -> rnf f1 IfaceLitTy f1 -> rnf f1 IfaceAppTy f1 f2 -> rnf f1 `seq` rnf f2 IfaceFunTy f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 IfaceForAllTy f1 f2 -> f1 `seq` rnf f2 IfaceTyConApp f1 f2 -> rnf f1 `seq` rnf f2 IfaceCastTy f1 f2 -> rnf f1 `seq` rnf f2 IfaceCoercionTy f1 -> rnf f1 IfaceTupleTy f1 f2 f3 -> f1 `seq` f2 `seq` rnf f3 instance NFData IfaceTyLit where rnf = \case IfaceNumTyLit f1 -> rnf f1 IfaceStrTyLit f1 -> rnf f1 instance NFData IfaceCoercion where rnf = \case IfaceReflCo f1 -> rnf f1 IfaceGReflCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 IfaceFunCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 IfaceTyConAppCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 IfaceAppCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceForAllCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 IfaceCoVarCo f1 -> rnf f1 IfaceAxiomInstCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 IfaceAxiomRuleCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceUnivCo f1 f2 f3 f4 -> rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 IfaceSymCo f1 -> rnf f1 IfaceTransCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceNthCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceLRCo f1 f2 -> f1 `seq` rnf f2 IfaceInstCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceKindCo f1 -> rnf f1 IfaceSubCo f1 -> rnf f1 IfaceFreeCoVar f1 -> f1 `seq` () IfaceHoleCo f1 -> f1 `seq` () instance NFData IfaceUnivCoProv where rnf x = seq x () instance NFData IfaceMCoercion where rnf x = seq x () instance NFData IfaceOneShot where rnf x = seq x () instance NFData IfaceTyConSort where rnf = \case IfaceNormalTyCon -> () IfaceTupleTyCon arity sort -> rnf arity `seq` sort `seq` () IfaceSumTyCon arity -> rnf arity IfaceEqualityTyCon -> () instance NFData IfaceTyConInfo where rnf (IfaceTyConInfo f s) = f `seq` rnf s instance NFData IfaceTyCon where rnf (IfaceTyCon nm info) = rnf nm `seq` rnf info instance NFData IfaceBndr where rnf = \case IfaceIdBndr id_bndr -> rnf id_bndr IfaceTvBndr tv_bndr -> rnf tv_bndr instance NFData IfaceAppArgs where rnf = \case IA_Nil -> () IA_Arg f1 f2 f3 -> rnf f1 `seq` f2 `seq` rnf f3 ghc-lib-parser-8.10.2.20200808/compiler/types/InstEnv.hs0000644000000000000000000012222013713635745020406 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[InstEnv]{Utilities for typechecking instance declarations} The bits common to TcInstDcls and TcDeriv. -} {-# LANGUAGE CPP, DeriveDataTypeable #-} module InstEnv ( DFunId, InstMatch, ClsInstLookupResult, OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, instanceDFunId, updateClsInstDFun, instanceRoughTcs, fuzzyClsInstCmp, orphNamesOfClsInst, InstEnvs(..), VisibleOrphanModules, InstEnv, emptyInstEnv, extendInstEnv, deleteFromInstEnv, deleteDFunFromInstEnv, identicalClsInstHead, extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses, memberInstEnv, instIsVisible, classInstances, instanceBindFun, instanceCantMatch, roughMatchTcs, isOverlappable, isOverlapping, isIncoherent ) where #include "GhclibHsVersions.h" import GhcPrelude import TcType -- InstEnv is really part of the type checker, -- and depends on TcType in many ways import CoreSyn ( IsOrphan(..), isOrphan, chooseOrphanAnchor ) import Module import Class import Var import VarSet import Name import NameSet import Unify import Outputable import ErrUtils import BasicTypes import UniqDFM import Util import Id import Data.Data ( Data ) import Data.Maybe ( isJust, isNothing ) {- ************************************************************************ * * ClsInst: the data type for type-class instances * * ************************************************************************ -} -- | A type-class instance. Note that there is some tricky laziness at work -- here. See Note [ClsInst laziness and the rough-match fields] for more -- details. data ClsInst = ClsInst { -- Used for "rough matching"; see -- Note [ClsInst laziness and the rough-match fields] -- INVARIANT: is_tcs = roughMatchTcs is_tys is_cls_nm :: Name -- ^ Class name , is_tcs :: [Maybe Name] -- ^ Top of type args -- | @is_dfun_name = idName . is_dfun@. -- -- We use 'is_dfun_name' for the visibility check, -- 'instIsVisible', which needs to know the 'Module' which the -- dictionary is defined in. However, we cannot use the 'Module' -- attached to 'is_dfun' since doing so would mean we would -- potentially pull in an entire interface file unnecessarily. -- This was the cause of #12367. , is_dfun_name :: Name -- Used for "proper matching"; see Note [Proper-match fields] , is_tvs :: [TyVar] -- Fresh template tyvars for full match -- See Note [Template tyvars are fresh] , is_cls :: Class -- The real class , is_tys :: [Type] -- Full arg types (mentioning is_tvs) -- INVARIANT: is_dfun Id has type -- forall is_tvs. (...) => is_cls is_tys -- (modulo alpha conversion) , is_dfun :: DFunId -- See Note [Haddock assumptions] , is_flag :: OverlapFlag -- See detailed comments with -- the decl of BasicTypes.OverlapFlag , is_orphan :: IsOrphan } deriving Data -- | A fuzzy comparison function for class instances, intended for sorting -- instances before displaying them to the user. fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering fuzzyClsInstCmp x y = stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend` mconcat (map cmp (zip (is_tcs x) (is_tcs y))) where cmp (Nothing, Nothing) = EQ cmp (Nothing, Just _) = LT cmp (Just _, Nothing) = GT cmp (Just x, Just y) = stableNameCmp x y isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i)) isOverlapping i = hasOverlappingFlag (overlapMode (is_flag i)) isIncoherent i = hasIncoherentFlag (overlapMode (is_flag i)) {- Note [ClsInst laziness and the rough-match fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we load 'instance A.C B.T' from A.hi, but suppose that the type B.T is otherwise unused in the program. Then it's stupid to load B.hi, the data type declaration for B.T -- and perhaps further instance declarations! We avoid this as follows: * is_cls_nm, is_tcs, is_dfun_name are all Names. We can poke them to our heart's content. * Proper-match fields. is_dfun, and its related fields is_tvs, is_cls, is_tys contain TyVars, Class, Type, Class etc, and so are all lazy thunks. When we poke any of these fields we'll typecheck the DFunId declaration, and hence pull in interfaces that it refers to. See Note [Proper-match fields]. * Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking inside the DFunId. The rough-match fields allow us to say "definitely does not match", based only on Names. This laziness is very important; see #12367. Try hard to avoid pulling on the structured fields unless you really need the instance. * Another place to watch is InstEnv.instIsVisible, which needs the module to which the ClsInst belongs. We can get this from is_dfun_name. * In is_tcs, Nothing means that this type arg is a type variable (Just n) means that this type arg is a TyConApp with a type constructor of n. This is always a real tycon, never a synonym! (Two different synonyms might match, but two different real tycons can't.) NB: newtypes are not transparent, though! -} {- Note [Template tyvars are fresh] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The is_tvs field of a ClsInst has *completely fresh* tyvars. That is, they are * distinct from any other ClsInst * distinct from any tyvars free in predicates that may be looked up in the class instance environment Reason for freshness: we use unification when checking for overlap etc, and that requires the tyvars to be distinct. The invariant is checked by the ASSERT in lookupInstEnv'. Note [Proper-match fields] ~~~~~~~~~~~~~~~~~~~~~~~~~ The is_tvs, is_cls, is_tys fields are simply cached values, pulled out (lazily) from the dfun id. They are cached here simply so that we don't need to decompose the DFunId each time we want to match it. The hope is that the rough-match fields mean that we often never poke the proper-match fields. However, note that: * is_tvs must be a superset of the free vars of is_tys * is_tvs, is_tys may be alpha-renamed compared to the ones in the dfun Id Note [Haddock assumptions] ~~~~~~~~~~~~~~~~~~~~~~~~~~ For normal user-written instances, Haddock relies on * the SrcSpan of * the Name of * the is_dfun of * an Instance being equal to * the SrcSpan of * the instance head type of * the InstDecl used to construct the Instance. -} instanceDFunId :: ClsInst -> DFunId instanceDFunId = is_dfun updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst updateClsInstDFun tidy_dfun ispec = ispec { is_dfun = tidy_dfun (is_dfun ispec) } instanceRoughTcs :: ClsInst -> [Maybe Name] instanceRoughTcs = is_tcs instance NamedThing ClsInst where getName ispec = getName (is_dfun ispec) instance Outputable ClsInst where ppr = pprInstance pprInstance :: ClsInst -> SDoc -- Prints the ClsInst as an instance declaration pprInstance ispec = hang (pprInstanceHdr ispec) 2 (vcat [ text "--" <+> pprDefinedAt (getName ispec) , whenPprDebug (ppr (is_dfun ispec)) ]) -- * pprInstanceHdr is used in VStudio to populate the ClassView tree pprInstanceHdr :: ClsInst -> SDoc -- Prints the ClsInst as an instance declaration pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun) pprInstances :: [ClsInst] -> SDoc pprInstances ispecs = vcat (map pprInstance ispecs) instanceHead :: ClsInst -> ([TyVar], Class, [Type]) -- Returns the head, using the fresh tyavs from the ClsInst instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun }) = (tvs, cls, tys) where (_, _, cls, _) = tcSplitDFunTy (idType dfun) -- | Collects the names of concrete types and type constructors that make -- up the head of a class instance. For instance, given `class Foo a b`: -- -- `instance Foo (Either (Maybe Int) a) Bool` would yield -- [Either, Maybe, Int, Bool] -- -- Used in the implementation of ":info" in GHCi. -- -- The 'tcSplitSigmaTy' is because of -- instance Foo a => Baz T where ... -- The decl is an orphan if Baz and T are both not locally defined, -- even if Foo *is* locally defined orphNamesOfClsInst :: ClsInst -> NameSet orphNamesOfClsInst (ClsInst { is_cls_nm = cls_nm, is_tys = tys }) = orphNamesOfTypes tys `unionNameSet` unitNameSet cls_nm instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type]) -- Decomposes the DFunId instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec)) mkLocalInstance :: DFunId -> OverlapFlag -> [TyVar] -> Class -> [Type] -> ClsInst -- Used for local instances, where we can safely pull on the DFunId. -- Consider using newClsInst instead; this will also warn if -- the instance is an orphan. mkLocalInstance dfun oflag tvs cls tys = ClsInst { is_flag = oflag, is_dfun = dfun , is_tvs = tvs , is_dfun_name = dfun_name , is_cls = cls, is_cls_nm = cls_name , is_tys = tys, is_tcs = roughMatchTcs tys , is_orphan = orph } where cls_name = className cls dfun_name = idName dfun this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name is_local name = nameIsLocalOrFrom this_mod name -- Compute orphanhood. See Note [Orphans] in InstEnv (cls_tvs, fds) = classTvsFds cls arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys] -- See Note [When exactly is an instance decl an orphan?] orph | is_local cls_name = NotOrphan (nameOccName cls_name) | all notOrphan mb_ns = ASSERT( not (null mb_ns) ) head mb_ns | otherwise = IsOrphan notOrphan NotOrphan{} = True notOrphan _ = False mb_ns :: [IsOrphan] -- One for each fundep; a locally-defined name -- that is not in the "determined" arguments mb_ns | null fds = [choose_one arg_names] | otherwise = map do_one fds do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names , not (tv `elem` rtvs)] choose_one nss = chooseOrphanAnchor (unionNameSets nss) mkImportedInstance :: Name -- ^ the name of the class -> [Maybe Name] -- ^ the types which the class was applied to -> Name -- ^ the 'Name' of the dictionary binding -> DFunId -- ^ the 'Id' of the dictionary. -> OverlapFlag -- ^ may this instance overlap? -> IsOrphan -- ^ is this instance an orphan? -> ClsInst -- Used for imported instances, where we get the rough-match stuff -- from the interface file -- The bound tyvars of the dfun are guaranteed fresh, because -- the dfun has been typechecked out of the same interface file mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan = ClsInst { is_flag = oflag, is_dfun = dfun , is_tvs = tvs, is_tys = tys , is_dfun_name = dfun_name , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs , is_orphan = orphan } where (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) {- Note [When exactly is an instance decl an orphan?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (see MkIface.instanceToIfaceInst, which implements this) Roughly speaking, an instance is an orphan if its head (after the =>) mentions nothing defined in this module. Functional dependencies complicate the situation though. Consider module M where { class C a b | a -> b } and suppose we are compiling module X: module X where import M data T = ... instance C Int T where ... This instance is an orphan, because when compiling a third module Y we might get a constraint (C Int v), and we'd want to improve v to T. So we must make sure X's instances are loaded, even if we do not directly use anything from X. More precisely, an instance is an orphan iff If there are no fundeps, then at least of the names in the instance head is locally defined. If there are fundeps, then for every fundep, at least one of the names free in a *non-determined* part of the instance head is defined in this module. (Note that these conditions hold trivially if the class is locally defined.) ************************************************************************ * * InstEnv, ClsInstEnv * * ************************************************************************ A @ClsInstEnv@ all the instances of that class. The @Id@ inside a ClsInstEnv mapping is the dfun for that instance. If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then forall a b, C t1 t2 t3 can be constructed by dfun or, to put it another way, we have instance (...) => C t1 t2 t3, witnessed by dfun -} --------------------------------------------------- {- Note [InstEnv determinism] ~~~~~~~~~~~~~~~~~~~~~~~~~~ We turn InstEnvs into a list in some places that don't directly affect the ABI. That happens when we create output for `:info`. Unfortunately that nondeterminism is nonlocal and it's hard to tell what it affects without following a chain of functions. It's also easy to accidentally make that nondeterminism affect the ABI. Furthermore the envs should be relatively small, so it should be free to use deterministic maps here. Testing with nofib and validate detected no difference between UniqFM and UniqDFM. See also Note [Deterministic UniqFM] -} type InstEnv = UniqDFM ClsInstEnv -- Maps Class to instances for that class -- See Note [InstEnv determinism] -- | 'InstEnvs' represents the combination of the global type class instance -- environment, the local type class instance environment, and the set of -- transitively reachable orphan modules (according to what modules have been -- directly imported) used to test orphan instance visibility. data InstEnvs = InstEnvs { ie_global :: InstEnv, -- External-package instances ie_local :: InstEnv, -- Home-package instances ie_visible :: VisibleOrphanModules -- Set of all orphan modules transitively -- reachable from the module being compiled -- See Note [Instance lookup and orphan instances] } -- | Set of visible orphan modules, according to what modules have been directly -- imported. This is based off of the dep_orphs field, which records -- transitively reachable orphan modules (modules that define orphan instances). type VisibleOrphanModules = ModuleSet newtype ClsInstEnv = ClsIE [ClsInst] -- The instances for a particular class, in any order instance Outputable ClsInstEnv where ppr (ClsIE is) = pprInstances is -- INVARIANTS: -- * The is_tvs are distinct in each ClsInst -- of a ClsInstEnv (so we can safely unify them) -- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: -- [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] -- The "a" in the pattern must be one of the forall'd variables in -- the dfun type. emptyInstEnv :: InstEnv emptyInstEnv = emptyUDFM instEnvElts :: InstEnv -> [ClsInst] instEnvElts ie = [elt | ClsIE elts <- eltsUDFM ie, elt <- elts] -- See Note [InstEnv determinism] instEnvClasses :: InstEnv -> [Class] instEnvClasses ie = [is_cls e | ClsIE (e : _) <- eltsUDFM ie] -- | Test if an instance is visible, by checking that its origin module -- is in 'VisibleOrphanModules'. -- See Note [Instance lookup and orphan instances] instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool instIsVisible vis_mods ispec -- NB: Instances from the interactive package always are visible. We can't -- add interactive modules to the set since we keep creating new ones -- as a GHCi session progresses. = case nameModule_maybe (is_dfun_name ispec) of Nothing -> True Just mod | isInteractiveModule mod -> True | IsOrphan <- is_orphan ispec -> mod `elemModuleSet` vis_mods | otherwise -> True classInstances :: InstEnvs -> Class -> [ClsInst] classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls = get home_ie ++ get pkg_ie where get env = case lookupUDFM env cls of Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts Nothing -> [] -- | Checks for an exact match of ClsInst in the instance environment. -- We use this when we do signature checking in TcRnDriver memberInstEnv :: InstEnv -> ClsInst -> Bool memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) = maybe False (\(ClsIE items) -> any (identicalDFunType ins_item) items) (lookupUDFM inst_env cls_nm) where identicalDFunType cls1 cls2 = eqType (varType (is_dfun cls1)) (varType (is_dfun cls2)) extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv extendInstEnvList inst_env ispecs = foldl' extendInstEnv inst_env ispecs extendInstEnv :: InstEnv -> ClsInst -> InstEnv extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) = addToUDFM_C add inst_env cls_nm (ClsIE [ins_item]) where add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) = adjustUDFM adjust inst_env cls_nm where adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items) deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv -- Delete a specific instance fron an InstEnv deleteDFunFromInstEnv inst_env dfun = adjustUDFM adjust inst_env cls where (_, _, cls, _) = tcSplitDFunTy (idType dfun) adjust (ClsIE items) = ClsIE (filterOut same_dfun items) same_dfun (ClsInst { is_dfun = dfun' }) = dfun == dfun' identicalClsInstHead :: ClsInst -> ClsInst -> Bool -- ^ True when when the instance heads are the same -- e.g. both are Eq [(a,b)] -- Used for overriding in GHCi -- Obviously should be insenstive to alpha-renaming identicalClsInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tys = tys1 }) (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tys = tys2 }) = cls_nm1 == cls_nm2 && not (instanceCantMatch rough1 rough2) -- Fast check for no match, uses the "rough match" fields && isJust (tcMatchTys tys1 tys2) && isJust (tcMatchTys tys2 tys1) {- ************************************************************************ * * Looking up an instance * * ************************************************************************ @lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since the env is kept ordered, the first match must be the only one. The thing we are looking up can have an arbitrary "flexi" part. Note [Instance lookup and orphan instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we are compiling a module M, and we have a zillion packages loaded, and we are looking up an instance for C (T W). If we find a match in module 'X' from package 'p', should be "in scope"; that is, is p:X in the transitive closure of modules imported from M? The difficulty is that the "zillion packages" might include ones loaded through earlier invocations of the GHC API, or earlier module loads in GHCi. They might not be in the dependencies of M itself; and if not, the instances in them should not be visible. #2182, #8427. There are two cases: * If the instance is *not an orphan*, then module X defines C, T, or W. And in order for those types to be involved in typechecking M, it must be that X is in the transitive closure of M's imports. So we can use the instance. * If the instance *is an orphan*, the above reasoning does not apply. So we keep track of the set of orphan modules transitively below M; this is the ie_visible field of InstEnvs, of type VisibleOrphanModules. If module p:X is in this set, then we can use the instance, otherwise we can't. Note [Rules for instance lookup] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ These functions implement the carefully-written rules in the user manual section on "overlapping instances". At risk of duplication, here are the rules. If the rules change, change this text and the user manual simultaneously. The link may be this: http://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#instance-overlap The willingness to be overlapped or incoherent is a property of the instance declaration itself, controlled as follows: * An instance is "incoherent" if it has an INCOHERENT pragma, or if it appears in a module compiled with -XIncoherentInstances. * An instance is "overlappable" if it has an OVERLAPPABLE or OVERLAPS pragma, or if it appears in a module compiled with -XOverlappingInstances, or if the instance is incoherent. * An instance is "overlapping" if it has an OVERLAPPING or OVERLAPS pragma, or if it appears in a module compiled with -XOverlappingInstances, or if the instance is incoherent. compiled with -XOverlappingInstances. Now suppose that, in some client module, we are searching for an instance of the target constraint (C ty1 .. tyn). The search works like this. * Find all instances `I` that *match* the target constraint; that is, the target constraint is a substitution instance of `I`. These instance declarations are the *candidates*. * Eliminate any candidate `IX` for which both of the following hold: - There is another candidate `IY` that is strictly more specific; that is, `IY` is a substitution instance of `IX` but not vice versa. - Either `IX` is *overlappable*, or `IY` is *overlapping*. (This "either/or" design, rather than a "both/and" design, allow a client to deliberately override an instance from a library, without requiring a change to the library.) - If exactly one non-incoherent candidate remains, select it. If all remaining candidates are incoherent, select an arbitrary one. Otherwise the search fails (i.e. when more than one surviving candidate is not incoherent). - If the selected candidate (from the previous step) is incoherent, the search succeeds, returning that candidate. - If not, find all instances that *unify* with the target constraint, but do not *match* it. Such non-candidate instances might match when the target constraint is further instantiated. If all of them are incoherent, the search succeeds, returning the selected candidate; if not, the search fails. Notice that these rules are not influenced by flag settings in the client module, where the instances are *used*. These rules make it possible for a library author to design a library that relies on overlapping instances without the client having to know. Note [Overlapping instances] (NB: these notes are quite old) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Overlap is permitted, but only in such a way that one can make a unique choice when looking up. That is, overlap is only permitted if one template matches the other, or vice versa. So this is ok: [a] [Int] but this is not (Int,a) (b,Int) If overlap is permitted, the list is kept most specific first, so that the first lookup is the right choice. For now we just use association lists. \subsection{Avoiding a problem with overlapping} Consider this little program: \begin{pseudocode} class C a where c :: a class C a => D a where d :: a instance C Int where c = 17 instance D Int where d = 13 instance C a => C [a] where c = [c] instance ({- C [a], -} D a) => D [a] where d = c instance C [Int] where c = [37] main = print (d :: [Int]) \end{pseudocode} What do you think `main' prints (assuming we have overlapping instances, and all that turned on)? Well, the instance for `D' at type `[a]' is defined to be `c' at the same type, and we've got an instance of `C' at `[Int]', so the answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because the `C [Int]' instance is more specific). Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That was easy ;-) Let's just consult hugs for good measure. Wait - if I use old hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it doesn't even compile! What's going on!? What hugs complains about is the `D [a]' instance decl. \begin{pseudocode} ERROR "mj.hs" (line 10): Cannot build superclass instance *** Instance : D [a] *** Context supplied : D a *** Required superclass : C [a] \end{pseudocode} You might wonder what hugs is complaining about. It's saying that you need to add `C [a]' to the context of the `D [a]' instance (as appears in comments). But there's that `C [a]' instance decl one line above that says that I can reduce the need for a `C [a]' instance to the need for a `C a' instance, and in this case, I already have the necessary `C a' instance (since we have `D a' explicitly in the context, and `C' is a superclass of `D'). Unfortunately, the above reasoning indicates a premature commitment to the generic `C [a]' instance. I.e., it prematurely rules out the more specific instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to add the context that hugs suggests (uncomment the `C [a]'), effectively deferring the decision about which instance to use. Now, interestingly enough, 4.04 has this same bug, but it's covered up in this case by a little known `optimization' that was disabled in 4.06. Ghc-4.04 silently inserts any missing superclass context into an instance declaration. In this case, it silently inserts the `C [a]', and everything happens to work out. (See `basicTypes/MkId:mkDictFunId' for the code in question. Search for `Mark Jones', although Mark claims no credit for the `optimization' in question, and would rather it stopped being called the `Mark Jones optimization' ;-) So, what's the fix? I think hugs has it right. Here's why. Let's try something else out with ghc-4.04. Let's add the following line: d' :: D a => [a] d' = c Everyone raise their hand who thinks that `d :: [Int]' should give a different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The `optimization' only applies to instance decls, not to regular bindings, giving inconsistent behavior. Old hugs had this same bug. Here's how we fixed it: like GHC, the list of instances for a given class is ordered, so that more specific instances come before more generic ones. For example, the instance list for C might contain: ..., C Int, ..., C a, ... When we go to look for a `C Int' instance we'll get that one first. But what if we go looking for a `C b' (`b' is unconstrained)? We'll pass the `C Int' instance, and keep going. But if `b' is unconstrained, then we don't know yet if the more specific instance will eventually apply. GHC keeps going, and matches on the generic `C a'. The fix is to, at each step, check to see if there's a reverse match, and if so, abort the search. This prevents hugs from prematurely chosing a generic instance when a more specific one exists. --Jeff BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in this test. Suppose the instance envt had ..., forall a b. C a a b, ..., forall a b c. C a b c, ... (still most specific first) Now suppose we are looking for (C x y Int), where x and y are unconstrained. C x y Int doesn't match the template {a,b} C a a b but neither does C a a b match the template {x,y} C x y Int But still x and y might subsequently be unified so they *do* match. Simple story: unify, don't match. -} type DFunInstType = Maybe Type -- Just ty => Instantiate with this type -- Nothing => Instantiate with any type of this tyvar's kind -- See Note [DFunInstType: instantiating types] type InstMatch = (ClsInst, [DFunInstType]) type ClsInstLookupResult = ( [InstMatch] -- Successful matches , [ClsInst] -- These don't match but do unify , [InstMatch] ) -- Unsafe overlapped instances under Safe Haskell -- (see Note [Safe Haskell Overlapping Instances] in -- TcSimplify). {- Note [DFunInstType: instantiating types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A successful match is a ClsInst, together with the types at which the dfun_id in the ClsInst should be instantiated The instantiating types are (Either TyVar Type)s because the dfun might have some tyvars that *only* appear in arguments dfun :: forall a b. C a b, Ord b => D [a] When we match this against D [ty], we return the instantiating types [Just ty, Nothing] where the 'Nothing' indicates that 'b' can be freely instantiated. (The caller instantiates it to a flexi type variable, which will presumably later become fixed via functional dependencies.) -} -- |Look up an instance in the given instance environment. The given class application must match exactly -- one instance and the match may not contain any flexi type variables. If the lookup is unsuccessful, -- yield 'Left errorMessage'. lookupUniqueInstEnv :: InstEnvs -> Class -> [Type] -> Either MsgDoc (ClsInst, [Type]) lookupUniqueInstEnv instEnv cls tys = case lookupInstEnv False instEnv cls tys of ([(inst, inst_tys)], _, _) | noFlexiVar -> Right (inst, inst_tys') | otherwise -> Left $ text "flexible type variable:" <+> (ppr $ mkTyConApp (classTyCon cls) tys) where inst_tys' = [ty | Just ty <- inst_tys] noFlexiVar = all isJust inst_tys _other -> Left $ text "instance not found" <+> (ppr $ mkTyConApp (classTyCon cls) tys) lookupInstEnv' :: InstEnv -- InstEnv to look in -> VisibleOrphanModules -- But filter against this -> Class -> [Type] -- What we are looking for -> ([InstMatch], -- Successful matches [ClsInst]) -- These don't match but do unify -- (no incoherent ones in here) -- The second component of the result pair happens when we look up -- Foo [a] -- in an InstEnv that has entries for -- Foo [Int] -- Foo [b] -- Then which we choose would depend on the way in which 'a' -- is instantiated. So we report that Foo [b] is a match (mapping b->a) -- but Foo [Int] is a unifier. This gives the caller a better chance of -- giving a suitable error message lookupInstEnv' ie vis_mods cls tys = lookup ie where rough_tcs = roughMatchTcs tys all_tvs = all isNothing rough_tcs -------------- lookup env = case lookupUDFM env cls of Nothing -> ([],[]) -- No instances for this class Just (ClsIE insts) -> find [] [] insts -------------- find ms us [] = (ms, us) find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs , is_tys = tpl_tys }) : rest) | not (instIsVisible vis_mods item) = find ms us rest -- See Note [Instance lookup and orphan instances] -- Fast check for no match, uses the "rough match" fields | instanceCantMatch rough_tcs mb_tcs = find ms us rest | Just subst <- tcMatchTys tpl_tys tys = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest -- Does not match, so next check whether the things unify -- See Note [Overlapping instances] -- Ignore ones that are incoherent: Note [Incoherent instances] | isIncoherent item = find ms us rest | otherwise = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set, (ppr cls <+> ppr tys <+> ppr all_tvs) $$ (ppr tpl_tvs <+> ppr tpl_tys) ) -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them -- See Note [Template tyvars are fresh] case tcUnifyTys instanceBindFun tpl_tys tys of Just _ -> find ms (item:us) rest Nothing -> find ms us rest where tpl_tv_set = mkVarSet tpl_tvs --------------- -- This is the common way to call this function. lookupInstEnv :: Bool -- Check Safe Haskell overlap restrictions -> InstEnvs -- External and home package inst-env -> Class -> [Type] -- What we are looking for -> ClsInstLookupResult -- ^ See Note [Rules for instance lookup] -- ^ See Note [Safe Haskell Overlapping Instances] in TcSimplify -- ^ See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify lookupInstEnv check_overlap_safe (InstEnvs { ie_global = pkg_ie , ie_local = home_ie , ie_visible = vis_mods }) cls tys = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $ (final_matches, final_unifs, unsafe_overlapped) where (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie vis_mods cls tys all_matches = home_matches ++ pkg_matches all_unifs = home_unifs ++ pkg_unifs final_matches = foldr insert_overlapping [] all_matches -- Even if the unifs is non-empty (an error situation) -- we still prune the matches, so that the error message isn't -- misleading (complaining of multiple matches when some should be -- overlapped away) unsafe_overlapped = case final_matches of [match] -> check_safe match _ -> [] -- If the selected match is incoherent, discard all unifiers final_unifs = case final_matches of (m:_) | isIncoherent (fst m) -> [] _ -> all_unifs -- NOTE [Safe Haskell isSafeOverlap] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- We restrict code compiled in 'Safe' mode from overriding code -- compiled in any other mode. The rationale is that code compiled -- in 'Safe' mode is code that is untrusted by the ghc user. So -- we shouldn't let that code change the behaviour of code the -- user didn't compile in 'Safe' mode since that's the code they -- trust. So 'Safe' instances can only overlap instances from the -- same module. A same instance origin policy for safe compiled -- instances. check_safe (inst,_) = case check_overlap_safe && unsafeTopInstance inst of -- make sure it only overlaps instances from the same module True -> go [] all_matches -- most specific is from a trusted location. False -> [] where go bad [] = bad go bad (i@(x,_):unchecked) = if inSameMod x || isOverlappable x then go bad unchecked else go (i:bad) unchecked inSameMod b = let na = getName $ getName inst la = isInternalName na nb = getName $ getName b lb = isInternalName nb in (la && lb) || (nameModule na == nameModule nb) -- We consider the most specific instance unsafe when it both: -- (1) Comes from a module compiled as `Safe` -- (2) Is an orphan instance, OR, an instance for a MPTC unsafeTopInstance inst = isSafeOverlap (is_flag inst) && (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1) --------------- insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] -- ^ Add a new solution, knocking out strictly less specific ones -- See Note [Rules for instance lookup] insert_overlapping new_item [] = [new_item] insert_overlapping new_item@(new_inst,_) (old_item@(old_inst,_) : old_items) | new_beats_old -- New strictly overrides old , not old_beats_new , new_inst `can_override` old_inst = insert_overlapping new_item old_items | old_beats_new -- Old strictly overrides new , not new_beats_old , old_inst `can_override` new_inst = old_item : old_items -- Discard incoherent instances; see Note [Incoherent instances] | isIncoherent old_inst -- Old is incoherent; discard it = insert_overlapping new_item old_items | isIncoherent new_inst -- New is incoherent; discard it = old_item : old_items -- Equal or incomparable, and neither is incoherent; keep both | otherwise = old_item : insert_overlapping new_item old_items where new_beats_old = new_inst `more_specific_than` old_inst old_beats_new = old_inst `more_specific_than` new_inst -- `instB` can be instantiated to match `instA` -- or the two are equal instA `more_specific_than` instB = isJust (tcMatchTys (is_tys instB) (is_tys instA)) instA `can_override` instB = isOverlapping instA || isOverlappable instB -- Overlap permitted if either the more specific instance -- is marked as overlapping, or the more general one is -- marked as overlappable. -- Latest change described in: #9242. -- Previous change: #3877, Dec 10. {- Note [Incoherent instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ For some classes, the choice of a particular instance does not matter, any one is good. E.g. consider class D a b where { opD :: a -> b -> String } instance D Int b where ... instance D a Int where ... g (x::Int) = opD x x -- Wanted: D Int Int For such classes this should work (without having to add an "instance D Int Int", and using -XOverlappingInstances, which would then work). This is what -XIncoherentInstances is for: Telling GHC "I don't care which instance you use; if you can use one, use it." Should this logic only work when *all* candidates have the incoherent flag, or even when all but one have it? The right choice is the latter, which can be justified by comparing the behaviour with how -XIncoherentInstances worked when it was only about the unify-check (note [Overlapping instances]): Example: class C a b c where foo :: (a,b,c) instance C [a] b Int instance [incoherent] [Int] b c instance [incoherent] C a Int c Thanks to the incoherent flags, [Wanted] C [a] b Int works: Only instance one matches, the others just unify, but are marked incoherent. So I can write (foo :: ([a],b,Int)) :: ([Int], Int, Int). but if that works then I really want to be able to write foo :: ([Int], Int, Int) as well. Now all three instances from above match. None is more specific than another, so none is ruled out by the normal overlapping rules. One of them is not incoherent, but we still want this to compile. Hence the "all-but-one-logic". The implementation is in insert_overlapping, where we remove matching incoherent instances as long as there are others. ************************************************************************ * * Binding decisions * * ************************************************************************ -} instanceBindFun :: TyCoVar -> BindFlag instanceBindFun tv | isOverlappableTyVar tv = Skolem | otherwise = BindMe -- Note [Binding when looking up instances] {- Note [Binding when looking up instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When looking up in the instance environment, or family-instance environment, we are careful about multiple matches, as described above in Note [Overlapping instances] The key_tys can contain skolem constants, and we can guarantee that those are never going to be instantiated to anything, so we should not involve them in the unification test. Example: class Foo a where { op :: a -> Int } instance Foo a => Foo [a] -- NB overlap instance Foo [Int] -- NB overlap data T = forall a. Foo a => MkT a f :: T -> Int f (MkT x) = op [x,x] The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd complain, saying that the choice of instance depended on the instantiation of 'a'; but of course it isn't *going* to be instantiated. We do this only for isOverlappableTyVar skolems. For example we reject g :: forall a => [a] -> Int g x = op x on the grounds that the correct instance depends on the instantiation of 'a' -} ghc-lib-parser-8.10.2.20200808/compiler/main/InteractiveEvalTypes.hs0000644000000000000000000000543513713635745022722 0ustar0000000000000000-- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow, 2005-2007 -- -- Running statements interactively -- -- ----------------------------------------------------------------------------- module InteractiveEvalTypes ( Resume(..), History(..), ExecResult(..), SingleStep(..), isStep, ExecOptions(..), BreakInfo(..) ) where import GhcPrelude import GHCi.RemoteTypes import GHCi.Message (EvalExpr, ResumeContext) import Id import Name import Module import RdrName import Type import SrcLoc import Exception import Data.Word import GHC.Stack.CCS data ExecOptions = ExecOptions { execSingleStep :: SingleStep -- ^ stepping mode , execSourceFile :: String -- ^ filename (for errors) , execLineNumber :: Int -- ^ line number (for errors) , execWrap :: ForeignHValue -> EvalExpr ForeignHValue } data SingleStep = RunToCompletion | SingleStep | RunAndLogSteps isStep :: SingleStep -> Bool isStep RunToCompletion = False isStep _ = True data ExecResult = ExecComplete { execResult :: Either SomeException [Name] , execAllocation :: Word64 } | ExecBreak { breakNames :: [Name] , breakInfo :: Maybe BreakInfo } data BreakInfo = BreakInfo { breakInfo_module :: Module , breakInfo_number :: Int } data Resume = Resume { resumeStmt :: String -- the original statement , resumeContext :: ForeignRef (ResumeContext [HValueRef]) , resumeBindings :: ([TyThing], GlobalRdrEnv) , resumeFinalIds :: [Id] -- [Id] to bind on completion , resumeApStack :: ForeignHValue -- The object from which we can get -- value of the free variables. , resumeBreakInfo :: Maybe BreakInfo -- the breakpoint we stopped at -- (module, index) -- (Nothing <=> exception) , resumeSpan :: SrcSpan -- just a copy of the SrcSpan -- from the ModBreaks, -- otherwise it's a pain to -- fetch the ModDetails & -- ModBreaks to get this. , resumeDecl :: String -- ditto , resumeCCS :: RemotePtr CostCentreStack , resumeHistory :: [History] , resumeHistoryIx :: Int -- 0 <==> at the top of the history } data History = History { historyApStack :: ForeignHValue, historyBreakInfo :: BreakInfo, historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint } ghc-lib-parser-8.10.2.20200808/compiler/utils/Json.hs0000644000000000000000000000305113713635745017725 0ustar0000000000000000{-# LANGUAGE GADTs #-} module Json where import GhcPrelude import Outputable import Data.Char import Numeric -- | Simple data type to represent JSON documents. data JsonDoc where JSNull :: JsonDoc JSBool :: Bool -> JsonDoc JSInt :: Int -> JsonDoc JSString :: String -> JsonDoc JSArray :: [JsonDoc] -> JsonDoc JSObject :: [(String, JsonDoc)] -> JsonDoc -- This is simple and slow as it is only used for error reporting renderJSON :: JsonDoc -> SDoc renderJSON d = case d of JSNull -> text "null" JSBool b -> text $ if b then "true" else "false" JSInt n -> ppr n JSString s -> doubleQuotes $ text $ escapeJsonString s JSArray as -> brackets $ pprList renderJSON as JSObject fs -> braces $ pprList renderField fs where renderField :: (String, JsonDoc) -> SDoc renderField (s, j) = doubleQuotes (text s) <> colon <+> renderJSON j pprList pp xs = hcat (punctuate comma (map pp xs)) escapeJsonString :: String -> String escapeJsonString = concatMap escapeChar where escapeChar '\b' = "\\b" escapeChar '\f' = "\\f" escapeChar '\n' = "\\n" escapeChar '\r' = "\\r" escapeChar '\t' = "\\t" escapeChar '"' = "\\\"" escapeChar '\\' = "\\\\" escapeChar c | isControl c || fromEnum c >= 0x7f = uni_esc c escapeChar c = [c] uni_esc c = "\\u" ++ (pad 4 (showHex (fromEnum c) "")) pad n cs | len < n = replicate (n-len) '0' ++ cs | otherwise = cs where len = length cs class ToJson a where json :: a -> JsonDoc ghc-lib-parser-8.10.2.20200808/compiler/prelude/KnownUniques.hs0000644000000000000000000001342113713635745021764 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | This is where we define a mapping from Uniques to their associated -- known-key Names for things associated with tuples and sums. We use this -- mapping while deserializing known-key Names in interface file symbol tables, -- which are encoded as their Unique. See Note [Symbol table representation of -- names] for details. -- module KnownUniques ( -- * Looking up known-key names knownUniqueName -- * Getting the 'Unique's of 'Name's -- ** Anonymous sums , mkSumTyConUnique , mkSumDataConUnique -- ** Tuples -- *** Vanilla , mkTupleTyConUnique , mkTupleDataConUnique -- *** Constraint , mkCTupleTyConUnique , mkCTupleDataConUnique ) where #include "GhclibHsVersions.h" import GhcPrelude import TysWiredIn import TyCon import DataCon import Id import BasicTypes import Outputable import Unique import Name import Util import Data.Bits import Data.Maybe -- | Get the 'Name' associated with a known-key 'Unique'. knownUniqueName :: Unique -> Maybe Name knownUniqueName u = case tag of 'z' -> Just $ getUnboxedSumName n '4' -> Just $ getTupleTyConName Boxed n '5' -> Just $ getTupleTyConName Unboxed n '7' -> Just $ getTupleDataConName Boxed n '8' -> Just $ getTupleDataConName Unboxed n 'k' -> Just $ getCTupleTyConName n 'm' -> Just $ getCTupleDataConUnique n _ -> Nothing where (tag, n) = unpkUnique u -------------------------------------------------- -- Anonymous sums -- -- Sum arities start from 2. The encoding is a bit funny: we break up the -- integral part into bitfields for the arity, an alternative index (which is -- taken to be 0xff in the case of the TyCon), and, in the case of a datacon, a -- tag (used to identify the sum's TypeRep binding). -- -- This layout is chosen to remain compatible with the usual unique allocation -- for wired-in data constructors described in Unique.hs -- -- TyCon for sum of arity k: -- 00000000 kkkkkkkk 11111100 -- TypeRep of TyCon for sum of arity k: -- 00000000 kkkkkkkk 11111101 -- -- DataCon for sum of arity k and alternative n (zero-based): -- 00000000 kkkkkkkk nnnnnn00 -- -- TypeRep for sum DataCon of arity k and alternative n (zero-based): -- 00000000 kkkkkkkk nnnnnn10 mkSumTyConUnique :: Arity -> Unique mkSumTyConUnique arity = ASSERT(arity < 0x3f) -- 0x3f since we only have 6 bits to encode the -- alternative mkUnique 'z' (arity `shiftL` 8 .|. 0xfc) mkSumDataConUnique :: ConTagZ -> Arity -> Unique mkSumDataConUnique alt arity | alt >= arity = panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity) | otherwise = mkUnique 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -} getUnboxedSumName :: Int -> Name getUnboxedSumName n | n .&. 0xfc == 0xfc = case tag of 0x0 -> tyConName $ sumTyCon arity 0x1 -> getRep $ sumTyCon arity _ -> pprPanic "getUnboxedSumName: invalid tag" (ppr tag) | tag == 0x0 = dataConName $ sumDataCon (alt + 1) arity | tag == 0x1 = getName $ dataConWrapId $ sumDataCon (alt + 1) arity | tag == 0x2 = getRep $ promoteDataCon $ sumDataCon (alt + 1) arity | otherwise = pprPanic "getUnboxedSumName" (ppr n) where arity = n `shiftR` 8 alt = (n .&. 0xfc) `shiftR` 2 tag = 0x3 .&. n getRep tycon = fromMaybe (pprPanic "getUnboxedSumName(getRep)" (ppr tycon)) $ tyConRepName_maybe tycon -- Note [Uniques for tuple type and data constructors] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- Wired-in type constructor keys occupy *two* slots: -- * u: the TyCon itself -- * u+1: the TyConRepName of the TyCon -- -- Wired-in tuple data constructor keys occupy *three* slots: -- * u: the DataCon itself -- * u+1: its worker Id -- * u+2: the TyConRepName of the promoted TyCon -------------------------------------------------- -- Constraint tuples mkCTupleTyConUnique :: Arity -> Unique mkCTupleTyConUnique a = mkUnique 'k' (2*a) mkCTupleDataConUnique :: Arity -> Unique mkCTupleDataConUnique a = mkUnique 'm' (3*a) getCTupleTyConName :: Int -> Name getCTupleTyConName n = case n `divMod` 2 of (arity, 0) -> cTupleTyConName arity (arity, 1) -> mkPrelTyConRepName $ cTupleTyConName arity _ -> panic "getCTupleTyConName: impossible" getCTupleDataConUnique :: Int -> Name getCTupleDataConUnique n = case n `divMod` 3 of (arity, 0) -> cTupleDataConName arity (_arity, 1) -> panic "getCTupleDataConName: no worker" (arity, 2) -> mkPrelTyConRepName $ cTupleDataConName arity _ -> panic "getCTupleDataConName: impossible" -------------------------------------------------- -- Normal tuples mkTupleDataConUnique :: Boxity -> Arity -> Unique mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- may be used in C labels mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a) mkTupleTyConUnique :: Boxity -> Arity -> Unique mkTupleTyConUnique Boxed a = mkUnique '4' (2*a) mkTupleTyConUnique Unboxed a = mkUnique '5' (2*a) getTupleTyConName :: Boxity -> Int -> Name getTupleTyConName boxity n = case n `divMod` 2 of (arity, 0) -> tyConName $ tupleTyCon boxity arity (arity, 1) -> fromMaybe (panic "getTupleTyConName") $ tyConRepName_maybe $ tupleTyCon boxity arity _ -> panic "getTupleTyConName: impossible" getTupleDataConName :: Boxity -> Int -> Name getTupleDataConName boxity n = case n `divMod` 3 of (arity, 0) -> dataConName $ tupleDataCon boxity arity (arity, 1) -> idName $ dataConWorkId $ tupleDataCon boxity arity (arity, 2) -> fromMaybe (panic "getTupleDataCon") $ tyConRepName_maybe $ promotedTupleDataCon boxity arity _ -> panic "getTupleDataConName: impossible" ghc-lib-parser-8.10.2.20200808/libraries/template-haskell/Language/Haskell/TH.hs0000644000000000000000000000667513713635665024713 0ustar0000000000000000{- | The public face of Template Haskell For other documentation, refer to: -} {-# LANGUAGE Safe #-} module Language.Haskell.TH( -- * The monad and its operations Q, runQ, -- ** Administration: errors, locations and IO reportError, -- :: String -> Q () reportWarning, -- :: String -> Q () report, -- :: Bool -> String -> Q () recover, -- :: Q a -> Q a -> Q a location, -- :: Q Loc Loc(..), runIO, -- :: IO a -> Q a -- ** Querying the compiler -- *** Reify reify, -- :: Name -> Q Info reifyModule, Info(..), ModuleInfo(..), InstanceDec, ParentName, SumAlt, SumArity, Arity, Unlifted, -- *** Language extension lookup Extension(..), extsEnabled, isExtEnabled, -- *** Name lookup lookupTypeName, -- :: String -> Q (Maybe Name) lookupValueName, -- :: String -> Q (Maybe Name) -- *** Fixity lookup reifyFixity, -- *** Type lookup reifyType, -- *** Instance lookup reifyInstances, isInstance, -- *** Roles lookup reifyRoles, -- *** Annotation lookup reifyAnnotations, AnnLookup(..), -- *** Constructor strictness lookup reifyConStrictness, -- * Typed expressions TExp, unType, -- * Names Name, NameSpace, -- Abstract -- ** Constructing names mkName, -- :: String -> Name newName, -- :: String -> Q Name -- ** Deconstructing names nameBase, -- :: Name -> String nameModule, -- :: Name -> Maybe String namePackage, -- :: Name -> Maybe String nameSpace, -- :: Name -> Maybe NameSpace -- ** Built-in names tupleTypeName, tupleDataName, -- Int -> Name unboxedTupleTypeName, unboxedTupleDataName, -- :: Int -> Name unboxedSumTypeName, -- :: SumArity -> Name unboxedSumDataName, -- :: SumAlt -> SumArity -> Name -- * The algebraic data types -- | The lowercase versions (/syntax operators/) of these constructors are -- preferred to these constructors, since they compose better with -- quotations (@[| |]@) and splices (@$( ... )@) -- ** Declarations Dec(..), Con(..), Clause(..), SourceUnpackedness(..), SourceStrictness(..), DecidedStrictness(..), Bang(..), Strict, Foreign(..), Callconv(..), Safety(..), Pragma(..), Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..), FunDep(..), TySynEqn(..), TypeFamilyHead(..), Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, PatSynDir(..), PatSynArgs(..), -- ** Expressions Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..), -- ** Patterns Pat(..), FieldExp, FieldPat, -- ** Types Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..), FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, -- * Library functions module Language.Haskell.TH.Lib, -- * Pretty-printer Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType ) where import Language.Haskell.TH.Syntax as Syntax import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr ghc-lib-parser-8.10.2.20200808/libraries/template-haskell/Language/Haskell/TH/LanguageExtensions.hs0000644000000000000000000000142213713635662030474 0ustar0000000000000000{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.TH.LanguageExtensions -- Copyright : (c) The University of Glasgow 2015 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable -- -- Language extensions known to GHC -- ----------------------------------------------------------------------------- module Language.Haskell.TH.LanguageExtensions ( Extension(..) ) where -- This module exists primarily to avoid inserting a massive list of language -- extensions into the already quite large Haddocks for Language.Haskell.TH import GHC.LanguageExtensions.Type (Extension(..)) ghc-lib-parser-8.10.2.20200808/libraries/template-haskell/Language/Haskell/TH/Lib.hs0000644000000000000000000002340513713635665025407 0ustar0000000000000000{-# 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, DecQ, DecsQ, ConQ, TypeQ, KindQ, TyVarBndrQ, 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, -- ** 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, 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, 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, mdoE, compE, bindS, letS, noBindS, parS, recS, -- *** Types forallT, forallVisT, varT, conT, appT, appKindT, arrowT, infixT, uInfixT, parensT, equalityT, listT, tupleT, unboxedTupleT, unboxedSumT, sigT, litT, wildCardT, promotedT, promotedTupleT, promotedNilT, promotedConsT, implicitParamT, -- **** 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(..), 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, -- **** 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, -- **** Implicit Parameters implicitParamBindD, -- ** Reify thisModule ) where import Language.Haskell.TH.Lib.Internal hiding ( tySynD , dataD , newtypeD , classD , pragRuleD , dataInstD , newtypeInstD , dataFamilyD , openTypeFamilyD , closedTypeFamilyD , tySynEqn , forallC , forallT , sigT , plainTV , kindedTV , starK , constraintK , noSig , kindSig , tyVarSig , derivClause , standaloneDerivWithStrategyD , tupE , unboxedTupE , Role , InjectivityAnn ) import Language.Haskell.TH.Syntax import Control.Monad (liftM2) import Foreign.ForeignPtr import Data.Word import Prelude -- 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 :: 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 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 Nothing bndrs1 lhs1 rhs1 phases dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ] -> DecQ dataInstD ctxt tc tys ksig cons derivs = do ctxt1 <- ctxt ty1 <- foldl appT (conT tc) tys cons1 <- sequence cons derivs1 <- sequence derivs return (DataInstD ctxt1 Nothing ty1 ksig cons1 derivs1) newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> [DerivClauseQ] -> DecQ newtypeInstD ctxt tc tys ksig con derivs = do ctxt1 <- ctxt ty1 <- foldl appT (conT tc) tys con1 <- con derivs1 <- sequence derivs return (NewtypeInstD ctxt1 Nothing ty1 ksig con1 derivs1) 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) tySynEqn :: (Maybe [TyVarBndr]) -> TypeQ -> TypeQ -> TySynEqnQ tySynEqn tvs lhs rhs = do lhs1 <- lhs rhs1 <- rhs return (TySynEqn tvs lhs1 rhs1) forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ forallC ns ctxt con = liftM2 (ForallC ns) ctxt con ------------------------------------------------------------------------------- -- * Type forallT :: [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ forallT tvars ctxt ty = do ctxt1 <- ctxt ty1 <- ty return $ ForallT tvars ctxt1 ty1 sigT :: TypeQ -> Kind -> TypeQ sigT t k = do t' <- t return $ SigT t' k ------------------------------------------------------------------------------- -- * Kind plainTV :: Name -> TyVarBndr plainTV = PlainTV kindedTV :: Name -> Kind -> TyVarBndr kindedTV = KindedTV 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 :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ derivClause mds p = do p' <- cxt p return $ DerivClause mds p' standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ 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 :: [ExpQ] -> ExpQ tupE es = do { es1 <- sequence es; return (TupE $ map Just es1)} unboxedTupE :: [ExpQ] -> ExpQ unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE $ map Just es1)} ghc-lib-parser-8.10.2.20200808/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs0000644000000000000000000006571613713635665027176 0ustar0000000000000000{-# LANGUAGE Safe #-} -- | -- Language.Haskell.TH.Lib.Internal exposes some additional functionality that -- is used internally in GHC's integration with Template Haskell. This is not a -- part of the public API, and as such, there are no API guarantees for this -- module from version to version. -- Why do we have both Language.Haskell.TH.Lib.Internal and -- Language.Haskell.TH.Lib? Ultimately, it's because the functions in the -- former (which are tailored for GHC's use) need different type signatures -- than the ones in the latter. Syncing up the Internal type signatures would -- involve a massive amount of breaking changes, so for the time being, we -- relegate as many changes as we can to just the Internal module, where it -- is safe to break things. module Language.Haskell.TH.Lib.Internal where import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn) import qualified Language.Haskell.TH.Syntax as TH import Control.Monad( liftM, liftM2 ) import Data.Word( Word8 ) import Prelude ---------------------------------------------------------- -- * Type synonyms ---------------------------------------------------------- type InfoQ = Q Info type PatQ = Q Pat type FieldPatQ = Q FieldPat type ExpQ = Q Exp type TExpQ a = Q (TExp a) type DecQ = Q Dec type DecsQ = Q [Dec] type ConQ = Q Con type TypeQ = Q Type type KindQ = Q Kind type TyVarBndrQ = Q TyVarBndr type TyLitQ = Q TyLit type CxtQ = Q Cxt type PredQ = Q Pred type DerivClauseQ = Q DerivClause type MatchQ = Q Match type ClauseQ = Q Clause type BodyQ = Q Body type GuardQ = Q Guard type StmtQ = Q Stmt type RangeQ = Q Range type SourceStrictnessQ = Q SourceStrictness type SourceUnpackednessQ = Q SourceUnpackedness type BangQ = Q Bang type BangTypeQ = Q BangType type VarBangTypeQ = Q VarBangType type StrictTypeQ = Q StrictType type VarStrictTypeQ = Q VarStrictType type FieldExpQ = Q FieldExp type RuleBndrQ = Q RuleBndr type TySynEqnQ = Q TySynEqn type PatSynDirQ = Q PatSynDir type PatSynArgsQ = Q PatSynArgs type FamilyResultSigQ = Q FamilyResultSig type DerivStrategyQ = Q DerivStrategy -- must be defined here for DsMeta to find it type Role = TH.Role type InjectivityAnn = TH.InjectivityAnn ---------------------------------------------------------- -- * Lowercase pattern syntax functions ---------------------------------------------------------- intPrimL :: Integer -> Lit intPrimL = IntPrimL wordPrimL :: Integer -> Lit wordPrimL = WordPrimL floatPrimL :: Rational -> Lit floatPrimL = FloatPrimL doublePrimL :: Rational -> Lit doublePrimL = DoublePrimL integerL :: Integer -> Lit integerL = IntegerL charL :: Char -> Lit charL = CharL charPrimL :: Char -> Lit charPrimL = CharPrimL stringL :: String -> Lit stringL = StringL stringPrimL :: [Word8] -> Lit stringPrimL = StringPrimL bytesPrimL :: Bytes -> Lit bytesPrimL = BytesPrimL rationalL :: Rational -> Lit rationalL = RationalL litP :: Lit -> PatQ litP l = return (LitP l) varP :: Name -> PatQ varP v = return (VarP v) tupP :: [PatQ] -> PatQ tupP ps = do { ps1 <- sequence ps; return (TupP ps1)} unboxedTupP :: [PatQ] -> PatQ unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)} unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) } conP :: Name -> [PatQ] -> PatQ conP n ps = do ps' <- sequence ps return (ConP n ps') infixP :: PatQ -> Name -> PatQ -> PatQ infixP p1 n p2 = do p1' <- p1 p2' <- p2 return (InfixP p1' n p2') uInfixP :: PatQ -> Name -> PatQ -> PatQ uInfixP p1 n p2 = do p1' <- p1 p2' <- p2 return (UInfixP p1' n p2') parensP :: PatQ -> PatQ parensP p = do p' <- p return (ParensP p') tildeP :: PatQ -> PatQ tildeP p = do p' <- p return (TildeP p') bangP :: PatQ -> PatQ bangP p = do p' <- p return (BangP p') asP :: Name -> PatQ -> PatQ asP n p = do p' <- p return (AsP n p') wildP :: PatQ wildP = return WildP recP :: Name -> [FieldPatQ] -> PatQ recP n fps = do fps' <- sequence fps return (RecP n fps') listP :: [PatQ] -> PatQ listP ps = do ps' <- sequence ps return (ListP ps') sigP :: PatQ -> TypeQ -> PatQ sigP p t = do p' <- p t' <- t return (SigP p' t') viewP :: ExpQ -> PatQ -> PatQ viewP e p = do e' <- e p' <- p return (ViewP e' p') fieldPat :: Name -> PatQ -> FieldPatQ fieldPat n p = do p' <- p return (n, p') ------------------------------------------------------------------------------- -- * Stmt bindS :: PatQ -> ExpQ -> StmtQ bindS p e = liftM2 BindS p e letS :: [DecQ] -> StmtQ letS ds = do { ds1 <- sequence ds; return (LetS ds1) } noBindS :: ExpQ -> StmtQ noBindS e = do { e1 <- e; return (NoBindS e1) } parS :: [[StmtQ]] -> StmtQ parS sss = do { sss1 <- mapM sequence sss; return (ParS sss1) } recS :: [StmtQ] -> StmtQ recS ss = do { ss1 <- sequence ss; return (RecS ss1) } ------------------------------------------------------------------------------- -- * Range fromR :: ExpQ -> RangeQ fromR x = do { a <- x; return (FromR a) } fromThenR :: ExpQ -> ExpQ -> RangeQ fromThenR x y = do { a <- x; b <- y; return (FromThenR a b) } fromToR :: ExpQ -> ExpQ -> RangeQ fromToR x y = do { a <- x; b <- y; return (FromToR a b) } fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ fromThenToR x y z = do { a <- x; b <- y; c <- z; return (FromThenToR a b c) } ------------------------------------------------------------------------------- -- * Body normalB :: ExpQ -> BodyQ normalB e = do { e1 <- e; return (NormalB e1) } guardedB :: [Q (Guard,Exp)] -> BodyQ guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') } ------------------------------------------------------------------------------- -- * Guard normalG :: ExpQ -> GuardQ normalG e = do { e1 <- e; return (NormalG e1) } normalGE :: ExpQ -> ExpQ -> Q (Guard, Exp) normalGE g e = do { g1 <- g; e1 <- e; return (NormalG g1, e1) } patG :: [StmtQ] -> GuardQ patG ss = do { ss' <- sequence ss; return (PatG ss') } patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp) patGE ss e = do { ss' <- sequence ss; e' <- e; return (PatG ss', e') } ------------------------------------------------------------------------------- -- * Match and Clause -- | Use with 'caseE' match :: PatQ -> BodyQ -> [DecQ] -> MatchQ match p rhs ds = do { p' <- p; r' <- rhs; ds' <- sequence ds; return (Match p' r' ds') } -- | Use with 'funD' clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ clause ps r ds = do { ps' <- sequence ps; r' <- r; ds' <- sequence ds; return (Clause ps' r' ds') } --------------------------------------------------------------------------- -- * Exp -- | Dynamically binding a variable (unhygenic) dyn :: String -> ExpQ dyn s = return (VarE (mkName s)) varE :: Name -> ExpQ varE s = return (VarE s) conE :: Name -> ExpQ conE s = return (ConE s) litE :: Lit -> ExpQ litE c = return (LitE c) appE :: ExpQ -> ExpQ -> ExpQ appE x y = do { a <- x; b <- y; return (AppE a b)} appTypeE :: ExpQ -> TypeQ -> ExpQ appTypeE x t = do { a <- x; s <- t; return (AppTypeE a s) } parensE :: ExpQ -> ExpQ parensE x = do { x' <- x; return (ParensE x') } uInfixE :: ExpQ -> ExpQ -> ExpQ -> ExpQ uInfixE x s y = do { x' <- x; s' <- s; y' <- y; return (UInfixE x' s' y') } infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y; return (InfixE (Just a) s' (Just b))} infixE Nothing s (Just y) = do { s' <- s; b <- y; return (InfixE Nothing s' (Just b))} infixE (Just x) s Nothing = do { a <- x; s' <- s; return (InfixE (Just a) s' Nothing)} infixE Nothing s Nothing = do { s' <- s; return (InfixE Nothing s' Nothing) } infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ infixApp x y z = infixE (Just x) y (Just z) sectionL :: ExpQ -> ExpQ -> ExpQ sectionL x y = infixE (Just x) y Nothing sectionR :: ExpQ -> ExpQ -> ExpQ sectionR x y = infixE Nothing x (Just y) lamE :: [PatQ] -> ExpQ -> ExpQ lamE ps e = do ps' <- sequence ps e' <- e return (LamE ps' e') -- | Single-arg lambda lam1E :: PatQ -> ExpQ -> ExpQ lam1E p e = lamE [p] e lamCaseE :: [MatchQ] -> ExpQ lamCaseE ms = sequence ms >>= return . LamCaseE tupE :: [Maybe ExpQ] -> ExpQ tupE es = do { es1 <- traverse sequence es; return (TupE es1)} unboxedTupE :: [Maybe ExpQ] -> ExpQ unboxedTupE es = do { es1 <- traverse sequence es; return (UnboxedTupE es1)} unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) } condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)} multiIfE :: [Q (Guard, Exp)] -> ExpQ multiIfE alts = sequence alts >>= return . MultiIfE letE :: [DecQ] -> ExpQ -> ExpQ letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) } caseE :: ExpQ -> [MatchQ] -> ExpQ caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) } doE :: [StmtQ] -> ExpQ doE ss = do { ss1 <- sequence ss; return (DoE ss1) } mdoE :: [StmtQ] -> ExpQ mdoE ss = do { ss1 <- sequence ss; return (MDoE ss1) } compE :: [StmtQ] -> ExpQ compE ss = do { ss1 <- sequence ss; return (CompE ss1) } arithSeqE :: RangeQ -> ExpQ arithSeqE r = do { r' <- r; return (ArithSeqE r') } listE :: [ExpQ] -> ExpQ listE es = do { es1 <- sequence es; return (ListE es1) } sigE :: ExpQ -> TypeQ -> ExpQ sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) } recConE :: Name -> [Q (Name,Exp)] -> ExpQ recConE c fs = do { flds <- sequence fs; return (RecConE c flds) } recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 flds) } stringE :: String -> ExpQ stringE = litE . stringL fieldExp :: Name -> ExpQ -> Q (Name, Exp) fieldExp s e = do { e' <- e; return (s,e') } -- | @staticE x = [| static x |]@ staticE :: ExpQ -> ExpQ staticE = fmap StaticE unboundVarE :: Name -> ExpQ unboundVarE s = return (UnboundVarE s) labelE :: String -> ExpQ labelE s = return (LabelE s) implicitParamVarE :: String -> ExpQ implicitParamVarE n = return (ImplicitParamVarE n) -- ** 'arithSeqE' Shortcuts fromE :: ExpQ -> ExpQ fromE x = do { a <- x; return (ArithSeqE (FromR a)) } fromThenE :: ExpQ -> ExpQ -> ExpQ fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) } fromToE :: ExpQ -> ExpQ -> ExpQ fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) } fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ fromThenToE x y z = do { a <- x; b <- y; c <- z; return (ArithSeqE (FromThenToR a b c)) } ------------------------------------------------------------------------------- -- * Dec valD :: PatQ -> BodyQ -> [DecQ] -> DecQ valD p b ds = do { p' <- p ; ds' <- sequence ds ; b' <- b ; return (ValD p' b' ds') } funD :: Name -> [ClauseQ] -> DecQ funD nm cs = do { cs1 <- sequence cs ; return (FunD nm cs1) } tySynD :: Name -> [TyVarBndrQ] -> TypeQ -> DecQ tySynD tc tvs rhs = do { tvs1 <- sequenceA tvs ; rhs1 <- rhs ; return (TySynD tc tvs1 rhs1) } dataD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> [ConQ] -> [DerivClauseQ] -> DecQ dataD ctxt tc tvs ksig cons derivs = do ctxt1 <- ctxt tvs1 <- sequenceA tvs ksig1 <- sequenceA ksig cons1 <- sequence cons derivs1 <- sequence derivs return (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1) newtypeD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> ConQ -> [DerivClauseQ] -> DecQ newtypeD ctxt tc tvs ksig con derivs = do ctxt1 <- ctxt tvs1 <- sequenceA tvs ksig1 <- sequenceA ksig con1 <- con derivs1 <- sequence derivs return (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1) classD :: CxtQ -> Name -> [TyVarBndrQ] -> [FunDep] -> [DecQ] -> DecQ classD ctxt cls tvs fds decs = do tvs1 <- sequenceA tvs decs1 <- sequenceA decs ctxt1 <- ctxt return $ ClassD ctxt1 cls tvs1 fds decs1 instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ instanceD = instanceWithOverlapD Nothing instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ instanceWithOverlapD o ctxt ty decs = do ctxt1 <- ctxt decs1 <- sequence decs ty1 <- ty return $ InstanceD o ctxt1 ty1 decs1 sigD :: Name -> TypeQ -> DecQ sigD fun ty = liftM (SigD fun) $ ty kiSigD :: Name -> KindQ -> DecQ kiSigD fun ki = liftM (KiSigD fun) $ ki forImpD :: Callconv -> Safety -> String -> Name -> TypeQ -> DecQ forImpD cc s str n ty = do ty' <- ty return $ ForeignD (ImportF cc s str n ty') infixLD :: Int -> Name -> DecQ infixLD prec nm = return (InfixD (Fixity prec InfixL) nm) infixRD :: Int -> Name -> DecQ infixRD prec nm = return (InfixD (Fixity prec InfixR) nm) infixND :: Int -> Name -> DecQ infixND prec nm = return (InfixD (Fixity prec InfixN) nm) pragInlD :: Name -> Inline -> RuleMatch -> Phases -> DecQ pragInlD name inline rm phases = return $ PragmaD $ InlineP name inline rm phases pragSpecD :: Name -> TypeQ -> Phases -> DecQ pragSpecD n ty phases = do ty1 <- ty return $ PragmaD $ SpecialiseP n ty1 Nothing phases pragSpecInlD :: Name -> TypeQ -> Inline -> Phases -> DecQ pragSpecInlD n ty inline phases = do ty1 <- ty return $ PragmaD $ SpecialiseP n ty1 (Just inline) phases pragSpecInstD :: TypeQ -> DecQ pragSpecInstD ty = do ty1 <- ty return $ PragmaD $ SpecialiseInstP ty1 pragRuleD :: String -> Maybe [TyVarBndrQ] -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ pragRuleD n ty_bndrs tm_bndrs lhs rhs phases = do ty_bndrs1 <- traverse sequence ty_bndrs tm_bndrs1 <- sequence tm_bndrs lhs1 <- lhs rhs1 <- rhs return $ PragmaD $ RuleP n ty_bndrs1 tm_bndrs1 lhs1 rhs1 phases pragAnnD :: AnnTarget -> ExpQ -> DecQ pragAnnD target expr = do exp1 <- expr return $ PragmaD $ AnnP target exp1 pragLineD :: Int -> String -> DecQ pragLineD line file = return $ PragmaD $ LineP line file pragCompleteD :: [Name] -> Maybe Name -> DecQ pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty dataInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> [ConQ] -> [DerivClauseQ] -> DecQ dataInstD ctxt mb_bndrs ty ksig cons derivs = do ctxt1 <- ctxt mb_bndrs1 <- traverse sequence mb_bndrs ty1 <- ty ksig1 <- sequenceA ksig cons1 <- sequenceA cons derivs1 <- sequenceA derivs return (DataInstD ctxt1 mb_bndrs1 ty1 ksig1 cons1 derivs1) newtypeInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> ConQ -> [DerivClauseQ] -> DecQ newtypeInstD ctxt mb_bndrs ty ksig con derivs = do ctxt1 <- ctxt mb_bndrs1 <- traverse sequence mb_bndrs ty1 <- ty ksig1 <- sequenceA ksig con1 <- con derivs1 <- sequence derivs return (NewtypeInstD ctxt1 mb_bndrs1 ty1 ksig1 con1 derivs1) tySynInstD :: TySynEqnQ -> DecQ tySynInstD eqn = do eqn1 <- eqn return (TySynInstD eqn1) dataFamilyD :: Name -> [TyVarBndrQ] -> Maybe KindQ -> DecQ dataFamilyD tc tvs kind = do tvs' <- sequenceA tvs kind' <- sequenceA kind return $ DataFamilyD tc tvs' kind' openTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ -> Maybe InjectivityAnn -> DecQ openTypeFamilyD tc tvs res inj = do tvs' <- sequenceA tvs res' <- res return $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj) closedTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ closedTypeFamilyD tc tvs result injectivity eqns = do tvs1 <- sequenceA tvs result1 <- result eqns1 <- sequenceA eqns return (ClosedTypeFamilyD (TypeFamilyHead tc tvs1 result1 injectivity) eqns1) roleAnnotD :: Name -> [Role] -> DecQ roleAnnotD name roles = return $ RoleAnnotD name roles standaloneDerivD :: CxtQ -> TypeQ -> DecQ standaloneDerivD = standaloneDerivWithStrategyD Nothing standaloneDerivWithStrategyD :: Maybe DerivStrategyQ -> CxtQ -> TypeQ -> DecQ standaloneDerivWithStrategyD mdsq ctxtq tyq = do mds <- sequenceA mdsq ctxt <- ctxtq ty <- tyq return $ StandaloneDerivD mds ctxt ty defaultSigD :: Name -> TypeQ -> DecQ defaultSigD n tyq = do ty <- tyq return $ DefaultSigD n ty -- | Pattern synonym declaration patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ patSynD name args dir pat = do args' <- args dir' <- dir pat' <- pat return (PatSynD name args' dir' pat') -- | Pattern synonym type signature patSynSigD :: Name -> TypeQ -> DecQ patSynSigD nm ty = do ty' <- ty return $ PatSynSigD nm ty' -- | Implicit parameter binding declaration. Can only be used in let -- and where clauses which consist entirely of implicit bindings. implicitParamBindD :: String -> ExpQ -> DecQ implicitParamBindD n e = do e' <- e return $ ImplicitParamBindD n e' tySynEqn :: (Maybe [TyVarBndrQ]) -> TypeQ -> TypeQ -> TySynEqnQ tySynEqn mb_bndrs lhs rhs = do mb_bndrs1 <- traverse sequence mb_bndrs lhs1 <- lhs rhs1 <- rhs return (TySynEqn mb_bndrs1 lhs1 rhs1) cxt :: [PredQ] -> CxtQ cxt = sequence derivClause :: Maybe DerivStrategyQ -> [PredQ] -> DerivClauseQ derivClause mds p = do mds' <- sequenceA mds p' <- cxt p return $ DerivClause mds' p' stockStrategy :: DerivStrategyQ stockStrategy = pure StockStrategy anyclassStrategy :: DerivStrategyQ anyclassStrategy = pure AnyclassStrategy newtypeStrategy :: DerivStrategyQ newtypeStrategy = pure NewtypeStrategy viaStrategy :: TypeQ -> DerivStrategyQ viaStrategy = fmap ViaStrategy normalC :: Name -> [BangTypeQ] -> ConQ normalC con strtys = liftM (NormalC con) $ sequence strtys recC :: Name -> [VarBangTypeQ] -> ConQ recC con varstrtys = liftM (RecC con) $ sequence varstrtys infixC :: Q (Bang, Type) -> Name -> Q (Bang, Type) -> ConQ infixC st1 con st2 = do st1' <- st1 st2' <- st2 return $ InfixC st1' con st2' forallC :: [TyVarBndrQ] -> CxtQ -> ConQ -> ConQ forallC ns ctxt con = do ns' <- sequenceA ns ctxt' <- ctxt con' <- con pure $ ForallC ns' ctxt' con' gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty ------------------------------------------------------------------------------- -- * Type forallT :: [TyVarBndrQ] -> CxtQ -> TypeQ -> TypeQ forallT tvars ctxt ty = do tvars1 <- sequenceA tvars ctxt1 <- ctxt ty1 <- ty return $ ForallT tvars1 ctxt1 ty1 forallVisT :: [TyVarBndrQ] -> TypeQ -> TypeQ forallVisT tvars ty = ForallVisT <$> sequenceA tvars <*> ty varT :: Name -> TypeQ varT = return . VarT conT :: Name -> TypeQ conT = return . ConT infixT :: TypeQ -> Name -> TypeQ -> TypeQ infixT t1 n t2 = do t1' <- t1 t2' <- t2 return (InfixT t1' n t2') uInfixT :: TypeQ -> Name -> TypeQ -> TypeQ uInfixT t1 n t2 = do t1' <- t1 t2' <- t2 return (UInfixT t1' n t2') parensT :: TypeQ -> TypeQ parensT t = do t' <- t return (ParensT t') appT :: TypeQ -> TypeQ -> TypeQ appT t1 t2 = do t1' <- t1 t2' <- t2 return $ AppT t1' t2' appKindT :: TypeQ -> KindQ -> TypeQ appKindT ty ki = do ty' <- ty ki' <- ki return $ AppKindT ty' ki' arrowT :: TypeQ arrowT = return ArrowT listT :: TypeQ listT = return ListT litT :: TyLitQ -> TypeQ litT l = fmap LitT l tupleT :: Int -> TypeQ tupleT i = return (TupleT i) unboxedTupleT :: Int -> TypeQ unboxedTupleT i = return (UnboxedTupleT i) unboxedSumT :: SumArity -> TypeQ unboxedSumT arity = return (UnboxedSumT arity) sigT :: TypeQ -> KindQ -> TypeQ sigT t k = do t' <- t k' <- k return $ SigT t' k' equalityT :: TypeQ equalityT = return EqualityT wildCardT :: TypeQ wildCardT = return WildCardT implicitParamT :: String -> TypeQ -> TypeQ implicitParamT n t = do t' <- t return $ ImplicitParamT n t' {-# DEPRECATED classP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please use 'conT' and 'appT'." #-} classP :: Name -> [Q Type] -> Q Pred classP cla tys = do tysl <- sequence tys return (foldl AppT (ConT cla) tysl) {-# DEPRECATED equalP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please see 'equalityT'." #-} equalP :: TypeQ -> TypeQ -> PredQ equalP tleft tright = do tleft1 <- tleft tright1 <- tright eqT <- equalityT return (foldl AppT eqT [tleft1, tright1]) promotedT :: Name -> TypeQ promotedT = return . PromotedT promotedTupleT :: Int -> TypeQ promotedTupleT i = return (PromotedTupleT i) promotedNilT :: TypeQ promotedNilT = return PromotedNilT promotedConsT :: TypeQ promotedConsT = return PromotedConsT noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ noSourceUnpackedness = return NoSourceUnpackedness sourceNoUnpack = return SourceNoUnpack sourceUnpack = return SourceUnpack noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ noSourceStrictness = return NoSourceStrictness sourceLazy = return SourceLazy sourceStrict = return SourceStrict {-# DEPRECATED isStrict ["Use 'bang'. See https://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 :: Q Strict isStrict = bang noSourceUnpackedness sourceStrict notStrict = bang noSourceUnpackedness noSourceStrictness unpacked = bang sourceUnpack sourceStrict bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ bang u s = do u' <- u s' <- s return (Bang u' s') bangType :: BangQ -> TypeQ -> BangTypeQ bangType = liftM2 (,) varBangType :: Name -> BangTypeQ -> VarBangTypeQ varBangType v bt = do (b, t) <- bt return (v, b, t) {-# DEPRECATED strictType "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-} strictType :: Q Strict -> TypeQ -> StrictTypeQ strictType = bangType {-# DEPRECATED varStrictType "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-} varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ varStrictType = varBangType -- * Type Literals numTyLit :: Integer -> TyLitQ numTyLit n = if n >= 0 then return (NumTyLit n) else fail ("Negative type-level number: " ++ show n) strTyLit :: String -> TyLitQ strTyLit s = return (StrTyLit s) ------------------------------------------------------------------------------- -- * Kind plainTV :: Name -> TyVarBndrQ plainTV = pure . PlainTV kindedTV :: Name -> KindQ -> TyVarBndrQ kindedTV n = fmap (KindedTV n) varK :: Name -> Kind varK = VarT conK :: Name -> Kind conK = ConT tupleK :: Int -> Kind tupleK = TupleT arrowK :: Kind arrowK = ArrowT listK :: Kind listK = ListT appK :: Kind -> Kind -> Kind appK = AppT starK :: KindQ starK = pure StarT constraintK :: KindQ constraintK = pure ConstraintT ------------------------------------------------------------------------------- -- * Type family result noSig :: FamilyResultSigQ noSig = pure NoSig kindSig :: KindQ -> FamilyResultSigQ kindSig = fmap KindSig tyVarSig :: TyVarBndrQ -> FamilyResultSigQ tyVarSig = fmap TyVarSig ------------------------------------------------------------------------------- -- * Injectivity annotation injectivityAnn :: Name -> [Name] -> InjectivityAnn injectivityAnn = TH.InjectivityAnn ------------------------------------------------------------------------------- -- * Role nominalR, representationalR, phantomR, inferR :: Role nominalR = NominalR representationalR = RepresentationalR phantomR = PhantomR inferR = InferR ------------------------------------------------------------------------------- -- * Callconv cCall, stdCall, cApi, prim, javaScript :: Callconv cCall = CCall stdCall = StdCall cApi = CApi prim = Prim javaScript = JavaScript ------------------------------------------------------------------------------- -- * Safety unsafe, safe, interruptible :: Safety unsafe = Unsafe safe = Safe interruptible = Interruptible ------------------------------------------------------------------------------- -- * FunDep funDep :: [Name] -> [Name] -> FunDep funDep = FunDep ------------------------------------------------------------------------------- -- * RuleBndr ruleVar :: Name -> RuleBndrQ ruleVar = return . RuleVar typedRuleVar :: Name -> TypeQ -> RuleBndrQ typedRuleVar n ty = ty >>= return . TypedRuleVar n ------------------------------------------------------------------------------- -- * AnnTarget valueAnnotation :: Name -> AnnTarget valueAnnotation = ValueAnnotation typeAnnotation :: Name -> AnnTarget typeAnnotation = TypeAnnotation moduleAnnotation :: AnnTarget moduleAnnotation = ModuleAnnotation ------------------------------------------------------------------------------- -- * Pattern Synonyms (sub constructs) unidir, implBidir :: PatSynDirQ unidir = return Unidir implBidir = return ImplBidir explBidir :: [ClauseQ] -> PatSynDirQ explBidir cls = do cls' <- sequence cls return (ExplBidir cls') prefixPatSyn :: [Name] -> PatSynArgsQ prefixPatSyn args = return $ PrefixPatSyn args recordPatSyn :: [Name] -> PatSynArgsQ recordPatSyn sels = return $ RecordPatSyn sels infixPatSyn :: Name -> Name -> PatSynArgsQ infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2 -------------------------------------------------------------- -- * Useful helper function appsE :: [ExpQ] -> ExpQ appsE [] = error "appsE []" appsE [x] = x appsE (x:y:zs) = appsE ( (appE x y) : zs ) -- | Return the Module at the place of splicing. Can be used as an -- input for 'reifyModule'. thisModule :: Q Module thisModule = do loc <- location return $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc) ghc-lib-parser-8.10.2.20200808/libraries/template-haskell/Language/Haskell/TH/Lib/Map.hs0000644000000000000000000000765513713635662026132 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE Safe #-} -- This is a non-exposed internal module -- -- The code in this module has been ripped from containers-0.5.5.1:Data.Map.Base [1] almost -- verbatimely to avoid a dependency of 'template-haskell' on the containers package. -- -- [1] see https://hackage.haskell.org/package/containers-0.5.5.1 -- -- The original code is BSD-licensed and copyrighted by Daan Leijen, Andriy Palamarchuk, et al. module Language.Haskell.TH.Lib.Map ( Map , empty , insert , Language.Haskell.TH.Lib.Map.lookup ) where import Prelude data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a) | Tip type Size = Int empty :: Map k a empty = Tip {-# INLINE empty #-} singleton :: k -> a -> Map k a singleton k x = Bin 1 k x Tip Tip {-# INLINE singleton #-} size :: Map k a -> Int size Tip = 0 size (Bin sz _ _ _ _) = sz {-# INLINE size #-} lookup :: Ord k => k -> Map k a -> Maybe a lookup = go where go _ Tip = Nothing go !k (Bin _ kx x l r) = case compare k kx of LT -> go k l GT -> go k r EQ -> Just x {-# INLINABLE lookup #-} insert :: Ord k => k -> a -> Map k a -> Map k a insert = go where go :: Ord k => k -> a -> Map k a -> Map k a go !kx x Tip = singleton kx x go !kx x (Bin sz ky y l r) = case compare kx ky of LT -> balanceL ky y (go kx x l) r GT -> balanceR ky y l (go kx x r) EQ -> Bin sz kx x l r {-# INLINABLE insert #-} balanceL :: k -> a -> Map k a -> Map k a -> Map k a balanceL k x l r = case r of Tip -> case l of Tip -> Bin 1 k x Tip Tip (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip) (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip) (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr)) | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip) | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip) (Bin rs _ _ _ _) -> case l of Tip -> Bin (1+rs) k x Tip r (Bin ls lk lx ll lr) | ls > delta*rs -> case (ll, lr) of (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr) | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r) | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r) (_, _) -> error "Failure in Data.Map.balanceL" | otherwise -> Bin (1+ls+rs) k x l r {-# NOINLINE balanceL #-} balanceR :: k -> a -> Map k a -> Map k a -> Map k a balanceR k x l r = case l of Tip -> case r of Tip -> Bin 1 k x Tip Tip (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip) (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _)) | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr) (Bin ls _ _ _ _) -> case r of Tip -> Bin (1+ls) k x l Tip (Bin rs rk rx rl rr) | rs > delta*ls -> case (rl, rr) of (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _) | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr) (_, _) -> error "Failure in Data.Map.balanceR" | otherwise -> Bin (1+ls+rs) k x l r {-# NOINLINE balanceR #-} delta,ratio :: Int delta = 3 ratio = 2 ghc-lib-parser-8.10.2.20200808/libraries/template-haskell/Language/Haskell/TH/Ppr.hs0000644000000000000000000010516713713635665025450 0ustar0000000000000000{-# LANGUAGE Safe #-} -- | contains a prettyprinter for the -- Template Haskell datatypes module Language.Haskell.TH.Ppr where -- All of the exports from this module should -- be "public" functions. The main module TH -- re-exports them all. import Text.PrettyPrint (render) import Language.Haskell.TH.PprLib import Language.Haskell.TH.Syntax import Data.Word ( Word8 ) import Data.Char ( toLower, chr) import GHC.Show ( showMultiLineString ) import GHC.Lexeme( startsVarSym ) import Data.Ratio ( numerator, denominator ) import Prelude hiding ((<>)) nestDepth :: Int nestDepth = 4 type Precedence = Int appPrec, opPrec, unopPrec, sigPrec, noPrec :: Precedence appPrec = 4 -- Argument of a function application opPrec = 3 -- Argument of an infix operator unopPrec = 2 -- Argument of an unresolved infix operator sigPrec = 1 -- Argument of an explicit type signature noPrec = 0 -- Others parensIf :: Bool -> Doc -> Doc parensIf True d = parens d parensIf False d = d ------------------------------ pprint :: Ppr a => a -> String pprint x = render $ to_HPJ_Doc $ ppr x class Ppr a where ppr :: a -> Doc ppr_list :: [a] -> Doc ppr_list = vcat . map ppr instance Ppr a => Ppr [a] where ppr x = ppr_list x ------------------------------ instance Ppr Name where ppr v = pprName v ------------------------------ instance Ppr Info where ppr (TyConI d) = ppr d ppr (ClassI d is) = ppr d $$ vcat (map ppr is) ppr (FamilyI d is) = ppr d $$ vcat (map ppr is) ppr (PrimTyConI name arity is_unlifted) = text "Primitive" <+> (if is_unlifted then text "unlifted" else empty) <+> text "type constructor" <+> quotes (ppr name) <+> parens (text "arity" <+> int arity) ppr (ClassOpI v ty cls) = text "Class op from" <+> ppr cls <> colon <+> ppr_sig v ty ppr (DataConI v ty tc) = text "Constructor from" <+> ppr tc <> colon <+> ppr_sig v ty ppr (PatSynI nm ty) = pprPatSynSig nm ty ppr (TyVarI v ty) = text "Type variable" <+> ppr v <+> equals <+> ppr ty ppr (VarI v ty mb_d) = vcat [ppr_sig v ty, case mb_d of { Nothing -> empty; Just d -> ppr d }] ppr_sig :: Name -> Type -> Doc ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty pprFixity :: Name -> Fixity -> Doc pprFixity _ f | f == defaultFixity = empty pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v where ppr_fix InfixR = text "infixr" ppr_fix InfixL = text "infixl" ppr_fix InfixN = text "infix" -- | Pretty prints a pattern synonym type signature pprPatSynSig :: Name -> PatSynType -> Doc pprPatSynSig nm ty = text "pattern" <+> pprPrefixOcc nm <+> dcolon <+> pprPatSynType ty -- | Pretty prints a pattern synonym's type; follows the usual -- conventions to print a pattern synonym type compactly, yet -- unambiguously. See the note on 'PatSynType' and the section on -- pattern synonyms in the GHC user's guide for more information. pprPatSynType :: PatSynType -> Doc pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty'')) | null exTys, null provs = ppr (ForallT uniTys reqs ty'') | null uniTys, null reqs = noreqs <+> ppr ty' | null reqs = forall uniTys <+> noreqs <+> ppr ty' | otherwise = ppr ty where noreqs = text "() =>" forall tvs = text "forall" <+> (hsep (map ppr tvs)) <+> text "." pprPatSynType ty = ppr ty ------------------------------ instance Ppr Module where ppr (Module pkg m) = text (pkgString pkg) <+> text (modString m) instance Ppr ModuleInfo where ppr (ModuleInfo imps) = text "Module" <+> vcat (map ppr imps) ------------------------------ instance Ppr Exp where ppr = pprExp noPrec pprPrefixOcc :: Name -> Doc -- Print operators with parens around them pprPrefixOcc n = parensIf (isSymOcc n) (ppr n) isSymOcc :: Name -> Bool isSymOcc n = case nameBase n of [] -> True -- Empty name; weird (c:_) -> startsVarSym c -- c.f. OccName.startsVarSym in GHC itself pprInfixExp :: Exp -> Doc pprInfixExp (VarE v) = pprName' Infix v pprInfixExp (ConE v) = pprName' Infix v pprInfixExp (UnboundVarE v) = pprName' Infix v -- This case will only ever be reached in exceptional circumstances. -- For example, when printing an error message in case of a malformed expression. pprInfixExp e = text "`" <> ppr e <> 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 [] e) = pprExp i e -- #13856 pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps) <+> text "->" <+> ppr e pprExp i (LamCaseE ms) = parensIf (i > noPrec) $ text "\\case" $$ nest nestDepth (ppr ms) pprExp i (TupE es) | [Just e] <- es = pprExp i (ConE (tupleDataName 1) `AppE` e) | otherwise = parens (commaSepWith (pprMaybeExp noPrec) es) pprExp _ (UnboxedTupE es) = hashParens (commaSepWith (pprMaybeExp noPrec) es) pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity -- Nesting in Cond is to avoid potential problems in do statements pprExp i (CondE guard true false) = parensIf (i > noPrec) $ sep [text "if" <+> ppr guard, nest 1 $ text "then" <+> ppr true, nest 1 $ text "else" <+> ppr false] pprExp i (MultiIfE alts) = parensIf (i > noPrec) $ vcat $ case alts of [] -> [text "if {}"] (alt : alts') -> text "if" <+> pprGuarded arrow alt : map (nest 3 . pprGuarded arrow) alts' pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_ $$ text " in" <+> ppr e where pprDecs [] = empty pprDecs [d] = ppr d pprDecs ds = braces (semiSep ds) pprExp i (CaseE e ms) = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of" $$ nest nestDepth (ppr ms) pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_ where pprStms [] = empty pprStms [s] = ppr s pprStms ss = braces (semiSep ss) pprExp i (MDoE ss_) = parensIf (i > noPrec) $ text "mdo" <+> pprStms ss_ where pprStms [] = empty pprStms [s] = ppr s pprStms ss = braces (semiSep ss) pprExp _ (CompE []) = text "<>" -- This will probably break with fixity declarations - would need a ';' pprExp _ (CompE ss) = if null ss' -- If there are no statements in a list comprehension besides the last -- one, we simply treat it like a normal list. then text "[" <> ppr s <> text "]" else text "[" <> ppr s <+> bar <+> commaSep ss' <> text "]" where s = last ss ss' = init ss pprExp _ (ArithSeqE d) = ppr d pprExp _ (ListE es) = brackets (commaSep es) pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e <+> dcolon <+> ppr t pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs) pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs) pprExp i (StaticE e) = parensIf (i >= appPrec) $ text "static"<+> pprExp appPrec e pprExp _ (UnboundVarE v) = pprName' Applied v pprExp _ (LabelE s) = text "#" <> text s pprExp _ (ImplicitParamVarE n) = text ('?' : n) pprFields :: [(Name,Exp)] -> Doc pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e) pprMaybeExp :: Precedence -> Maybe Exp -> Doc pprMaybeExp _ Nothing = empty pprMaybeExp i (Just e) = pprExp i e ------------------------------ instance Ppr Stmt where ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e ppr (LetS ds) = text "let" <+> (braces (semiSep ds)) ppr (NoBindS e) = ppr e ppr (ParS sss) = sep $ punctuate bar $ map commaSep sss ppr (RecS ss) = text "rec" <+> (braces (semiSep ss)) ------------------------------ instance Ppr Match where ppr (Match p rhs ds) = pprMatchPat p <+> pprBody False rhs $$ where_clause ds pprMatchPat :: Pat -> Doc -- Everything except pattern signatures bind more tightly than (->) pprMatchPat p@(SigP {}) = parens (ppr p) pprMatchPat p = ppr p ------------------------------ pprGuarded :: Doc -> (Guard, Exp) -> Doc pprGuarded eqDoc (guard, expr) = case guard of NormalG guardExpr -> bar <+> ppr guardExpr <+> eqDoc <+> ppr expr PatG stmts -> bar <+> vcat (punctuate comma $ map ppr stmts) $$ nest nestDepth (eqDoc <+> ppr expr) ------------------------------ pprBody :: Bool -> Body -> Doc pprBody eq body = case body of GuardedB xs -> nest nestDepth $ vcat $ map (pprGuarded eqDoc) xs NormalB e -> eqDoc <+> ppr e where eqDoc | eq = equals | otherwise = arrow ------------------------------ instance Ppr Lit where ppr = pprLit noPrec pprLit :: Precedence -> Lit -> Doc pprLit i (IntPrimL x) = parensIf (i > noPrec && x < 0) (integer x <> char '#') pprLit _ (WordPrimL x) = integer x <> text "##" pprLit i (FloatPrimL x) = parensIf (i > noPrec && x < 0) (float (fromRational x) <> char '#') pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0) (double (fromRational x) <> text "##") pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x) pprLit _ (CharL c) = text (show c) pprLit _ (CharPrimL c) = text (show c) <> char '#' pprLit _ (StringL s) = pprString s pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#' pprLit _ (BytesPrimL {}) = pprString "" 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 i (TupP ps) | [_] <- ps = pprPat i (ConP (tupleDataName 1) ps) | otherwise = parens (commaSep ps) pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps) pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity pprPat i (ConP s ps) = parensIf (i >= appPrec) $ pprName' Applied s <+> sep (map (pprPat appPrec) ps) pprPat _ (ParensP p) = parens $ pprPat noPrec p pprPat i (UInfixP p1 n p2) = parensIf (i > unopPrec) (pprPat unopPrec p1 <+> pprName' Infix n <+> pprPat unopPrec p2) pprPat i (InfixP p1 n p2) = parensIf (i >= opPrec) (pprPat opPrec p1 <+> pprName' Infix n <+> pprPat opPrec p2) pprPat i (TildeP p) = parensIf (i > noPrec) $ char '~' <> pprPat appPrec p pprPat i (BangP p) = parensIf (i > noPrec) $ char '!' <> pprPat appPrec p pprPat i (AsP v p) = parensIf (i > noPrec) $ ppr v <> text "@" <> pprPat appPrec p pprPat _ WildP = text "_" pprPat _ (RecP nm fs) = parens $ ppr nm <+> braces (sep $ punctuate comma $ map (\(s,p) -> ppr s <+> equals <+> ppr p) fs) pprPat _ (ListP ps) = brackets (commaSep ps) pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p ------------------------------ instance Ppr Dec where ppr = ppr_dec True ppr_dec :: Bool -- declaration on the toplevel? -> Dec -> Doc ppr_dec _ (FunD f cs) = vcat $ map (\c -> pprPrefixOcc f <+> ppr c) cs ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r $$ where_clause ds ppr_dec _ (TySynD t xs rhs) = ppr_tySyn empty (Just t) (hsep (map ppr xs)) rhs ppr_dec _ (DataD ctxt t xs ksig cs decs) = ppr_data empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs ppr_dec _ (NewtypeD ctxt t xs ksig c decs) = ppr_newtype empty ctxt (Just t) (sep (map ppr xs)) ksig c decs ppr_dec _ (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds $$ where_clause ds ppr_dec _ (InstanceD o ctxt i ds) = text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i $$ where_clause ds ppr_dec _ (SigD f t) = pprPrefixOcc f <+> dcolon <+> ppr t ppr_dec _ (KiSigD f k) = text "type" <+> pprPrefixOcc f <+> dcolon <+> ppr k ppr_dec _ (ForeignD f) = ppr f ppr_dec _ (InfixD fx n) = pprFixity n fx ppr_dec _ (PragmaD p) = ppr p ppr_dec isTop (DataFamilyD tc tvs kind) = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind where maybeFamily | isTop = text "family" | otherwise = empty maybeKind | (Just k') <- kind = dcolon <+> ppr k' | otherwise = empty ppr_dec isTop (DataInstD ctxt bndrs ty ksig cs decs) = ppr_data (maybeInst <+> ppr_bndrs bndrs) ctxt Nothing (ppr ty) ksig cs decs where maybeInst | isTop = text "instance" | otherwise = empty ppr_dec isTop (NewtypeInstD ctxt bndrs ty ksig c decs) = ppr_newtype (maybeInst <+> ppr_bndrs bndrs) ctxt Nothing (ppr ty) ksig c decs where maybeInst | isTop = text "instance" | otherwise = empty ppr_dec isTop (TySynInstD (TySynEqn mb_bndrs ty rhs)) = ppr_tySyn (maybeInst <+> ppr_bndrs mb_bndrs) Nothing (ppr ty) rhs where maybeInst | isTop = text "instance" | otherwise = empty ppr_dec isTop (OpenTypeFamilyD tfhead) = text "type" <+> maybeFamily <+> ppr_tf_head tfhead where maybeFamily | isTop = text "family" | otherwise = empty ppr_dec _ (ClosedTypeFamilyD tfhead eqns) = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where") nestDepth (vcat (map ppr_eqn eqns)) where ppr_eqn (TySynEqn mb_bndrs lhs rhs) = ppr_bndrs mb_bndrs <+> ppr lhs <+> text "=" <+> ppr rhs ppr_dec _ (RoleAnnotD name roles) = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles) ppr_dec _ (StandaloneDerivD ds cxt ty) = hsep [ text "deriving" , maybe empty ppr_deriv_strategy ds , text "instance" , pprCxt cxt , ppr ty ] ppr_dec _ (DefaultSigD n ty) = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ] ppr_dec _ (PatSynD name args dir pat) = text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS where pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> ppr name <+> ppr a2 | otherwise = ppr name <+> ppr args pprPatRHS | ExplBidir cls <- dir = hang (ppr pat <+> text "where") nestDepth (ppr name <+> ppr cls) | otherwise = ppr pat ppr_dec _ (PatSynSigD name ty) = pprPatSynSig name ty ppr_dec _ (ImplicitParamBindD n e) = hsep [text ('?' : n), text "=", ppr e] ppr_deriv_strategy :: DerivStrategy -> Doc ppr_deriv_strategy ds = case ds of StockStrategy -> text "stock" AnyclassStrategy -> text "anyclass" NewtypeStrategy -> text "newtype" ViaStrategy ty -> text "via" <+> pprParendType ty ppr_overlap :: Overlap -> Doc ppr_overlap o = text $ case o of Overlaps -> "{-# OVERLAPS #-}" Overlappable -> "{-# OVERLAPPABLE #-}" Overlapping -> "{-# OVERLAPPING #-}" Incoherent -> "{-# INCOHERENT #-}" ppr_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc ppr_data maybeInst ctxt t argsDoc ksig cs decs = sep [text "data" <+> maybeInst <+> pprCxt ctxt <+> case t of Just n -> pprName' Applied n <+> argsDoc Nothing -> argsDoc <+> ksigDoc <+> maybeWhere, nest nestDepth (sep (pref $ map ppr cs)), if null decs then empty else nest nestDepth $ vcat $ map ppr_deriv_clause decs] where pref :: [Doc] -> [Doc] pref xs | isGadtDecl = xs pref [] = [] -- No constructors; can't happen in H98 pref (d:ds) = (char '=' <+> d):map (bar <+>) ds maybeWhere :: Doc maybeWhere | isGadtDecl = text "where" | otherwise = empty isGadtDecl :: Bool isGadtDecl = not (null cs) && all isGadtCon cs where isGadtCon (GadtC _ _ _ ) = True isGadtCon (RecGadtC _ _ _) = True isGadtCon (ForallC _ _ x ) = isGadtCon x isGadtCon _ = False ksigDoc = case ksig of Nothing -> empty Just k -> dcolon <+> ppr k ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause] -> Doc ppr_newtype maybeInst ctxt t argsDoc ksig c decs = sep [text "newtype" <+> maybeInst <+> pprCxt ctxt <+> case t of Just n -> ppr n <+> argsDoc Nothing -> argsDoc <+> ksigDoc, nest 2 (char '=' <+> ppr c), if null decs then empty else nest nestDepth $ vcat $ map ppr_deriv_clause decs] where ksigDoc = case ksig of Nothing -> empty Just k -> dcolon <+> ppr k ppr_deriv_clause :: DerivClause -> Doc ppr_deriv_clause (DerivClause ds ctxt) = text "deriving" <+> pp_strat_before <+> ppr_cxt_preds ctxt <+> pp_strat_after where -- @via@ is unique in that in comes /after/ the class being derived, -- so we must special-case it. (pp_strat_before, pp_strat_after) = case ds of Just (via@ViaStrategy{}) -> (empty, ppr_deriv_strategy via) _ -> (maybe empty ppr_deriv_strategy ds, empty) ppr_tySyn :: Doc -> Maybe Name -> Doc -> Type -> Doc ppr_tySyn maybeInst t argsDoc rhs = text "type" <+> maybeInst <+> case t of Just n -> ppr n <+> argsDoc Nothing -> argsDoc <+> text "=" <+> ppr rhs ppr_tf_head :: TypeFamilyHead -> Doc ppr_tf_head (TypeFamilyHead tc tvs res inj) = ppr tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj where maybeInj | (Just inj') <- inj = ppr inj' | otherwise = empty ppr_bndrs :: Maybe [TyVarBndr] -> Doc ppr_bndrs (Just bndrs) = text "forall" <+> sep (map ppr bndrs) <> text "." ppr_bndrs Nothing = empty ------------------------------ instance Ppr FunDep where ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys) ppr_list [] = empty ppr_list xs = bar <+> commaSep xs ------------------------------ instance Ppr FamilyResultSig where ppr NoSig = empty ppr (KindSig k) = dcolon <+> ppr k ppr (TyVarSig bndr) = text "=" <+> ppr bndr ------------------------------ instance Ppr InjectivityAnn where ppr (InjectivityAnn lhs rhs) = bar <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs) ------------------------------ instance Ppr Foreign where ppr (ImportF callconv safety impent as typ) = text "foreign import" <+> showtextl callconv <+> showtextl safety <+> text (show impent) <+> ppr as <+> dcolon <+> ppr typ ppr (ExportF callconv expent as typ) = text "foreign export" <+> showtextl callconv <+> text (show expent) <+> ppr as <+> dcolon <+> ppr typ ------------------------------ instance Ppr Pragma where ppr (InlineP n inline rm phases) = text "{-#" <+> ppr inline <+> ppr rm <+> ppr phases <+> ppr n <+> text "#-}" ppr (SpecialiseP n ty inline phases) = text "{-# SPECIALISE" <+> maybe empty ppr inline <+> ppr phases <+> sep [ ppr n <+> dcolon , nest 2 $ ppr ty ] <+> text "#-}" ppr (SpecialiseInstP inst) = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}" ppr (RuleP n ty_bndrs tm_bndrs lhs rhs phases) = sep [ text "{-# RULES" <+> pprString n <+> ppr phases , nest 4 $ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs <+> ppr lhs , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ] where ppr_ty_forall Nothing = empty ppr_ty_forall (Just bndrs) = text "forall" <+> fsep (map ppr bndrs) <+> char '.' ppr_tm_forall Nothing | null tm_bndrs = empty ppr_tm_forall _ = text "forall" <+> fsep (map ppr tm_bndrs) <+> char '.' ppr (AnnP tgt expr) = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}" where target1 ModuleAnnotation = text "module" target1 (TypeAnnotation t) = text "type" <+> ppr t target1 (ValueAnnotation v) = ppr v ppr (LineP line file) = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}" ppr (CompleteP cls mty) = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map ppr cls) <+> maybe empty (\ty -> dcolon <+> ppr ty) mty ------------------------------ instance Ppr Inline where ppr NoInline = text "NOINLINE" ppr Inline = text "INLINE" ppr Inlinable = text "INLINABLE" ------------------------------ instance Ppr RuleMatch where ppr ConLike = text "CONLIKE" ppr FunLike = empty ------------------------------ instance Ppr Phases where ppr AllPhases = empty ppr (FromPhase i) = brackets $ int i ppr (BeforePhase i) = brackets $ char '~' <> int i ------------------------------ instance Ppr RuleBndr where ppr (RuleVar n) = ppr n ppr (TypedRuleVar n ty) = parens $ ppr n <+> dcolon <+> ppr ty ------------------------------ instance Ppr Clause where ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs $$ where_clause ds ------------------------------ instance Ppr Con where ppr (NormalC c sts) = ppr c <+> sep (map pprBangType sts) ppr (RecC c vsts) = ppr c <+> braces (sep (punctuate comma $ map pprVarBangType vsts)) ppr (InfixC st1 c st2) = pprBangType st1 <+> pprName' Infix c <+> pprBangType st2 ppr (ForallC ns ctxt (GadtC c sts ty)) = commaSepApplied c <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty ppr (ForallC ns ctxt (RecGadtC c vsts ty)) = commaSepApplied c <+> dcolon <+> pprForall ns ctxt <+> pprRecFields vsts ty ppr (ForallC ns ctxt con) = pprForall ns ctxt <+> ppr con ppr (GadtC c sts ty) = commaSepApplied c <+> dcolon <+> pprGadtRHS sts ty ppr (RecGadtC c vsts ty) = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty instance Ppr PatSynDir where ppr Unidir = text "<-" ppr ImplBidir = text "=" ppr (ExplBidir _) = text "<-" -- the ExplBidir's clauses are pretty printed together with the -- entire pattern synonym; so only print the direction here. instance Ppr PatSynArgs where ppr (PrefixPatSyn args) = sep $ map ppr args ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2 ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map ppr sels)) commaSepApplied :: [Name] -> Doc commaSepApplied = commaSepWith (pprName' Applied) pprForall :: [TyVarBndr] -> Cxt -> Doc pprForall = pprForall' ForallInvis pprForallVis :: [TyVarBndr] -> Cxt -> Doc pprForallVis = pprForall' ForallVis pprForall' :: ForallVisFlag -> [TyVarBndr] -> Cxt -> Doc pprForall' fvf 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) <+> separator <+> pprCxt cxt where separator = case fvf of ForallVis -> text "->" ForallInvis -> char '.' pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc pprRecFields vsts ty = braces (sep (punctuate comma $ map pprVarBangType vsts)) <+> arrow <+> ppr ty pprGadtRHS :: [(Strict, Type)] -> Type -> Doc pprGadtRHS [] ty = ppr ty pprGadtRHS sts ty = sep (punctuate (space <> arrow) (map pprBangType sts)) <+> arrow <+> ppr ty ------------------------------ pprVarBangType :: VarBangType -> Doc -- Slight infelicity: with print non-atomic type with parens pprVarBangType (v, bang, t) = ppr v <+> dcolon <+> pprBangType (bang, t) ------------------------------ pprBangType :: BangType -> Doc -- Make sure we print -- -- Con {-# UNPACK #-} a -- -- rather than -- -- Con {-# UNPACK #-}a -- -- when there's no strictness annotation. If there is a strictness annotation, -- it's okay to not put a space between it and the type. pprBangType (bt@(Bang _ NoSourceStrictness), t) = ppr bt <+> pprParendType t pprBangType (bt, t) = ppr bt <> pprParendType t ------------------------------ instance Ppr Bang where ppr (Bang su ss) = ppr su <+> ppr ss ------------------------------ instance Ppr SourceUnpackedness where ppr NoSourceUnpackedness = empty ppr SourceNoUnpack = text "{-# NOUNPACK #-}" ppr SourceUnpack = text "{-# UNPACK #-}" ------------------------------ instance Ppr SourceStrictness where ppr NoSourceStrictness = empty ppr SourceLazy = char '~' ppr SourceStrict = char '!' ------------------------------ instance Ppr DecidedStrictness where ppr DecidedLazy = empty ppr DecidedStrict = char '!' ppr DecidedUnpack = text "{-# UNPACK #-} !" ------------------------------ {-# DEPRECATED pprVarStrictType "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'pprVarBangType' instead." #-} pprVarStrictType :: (Name, Strict, Type) -> Doc pprVarStrictType = pprVarBangType ------------------------------ {-# DEPRECATED pprStrictType "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'pprBangType' instead." #-} pprStrictType :: (Strict, Type) -> Doc pprStrictType = pprBangType ------------------------------ pprParendType :: Type -> Doc pprParendType (VarT v) = pprName' Applied v -- `Applied` is used here instead of `ppr` because of infix names (#13887) pprParendType (ConT c) = pprName' Applied c pprParendType (TupleT 0) = text "()" pprParendType (TupleT 1) = pprParendType (ConT (tupleTypeName 1)) pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma)) pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar pprParendType ArrowT = parens (text "->") pprParendType ListT = text "[]" pprParendType (LitT l) = pprTyLit l pprParendType (PromotedT c) = text "'" <> pprName' Applied c pprParendType (PromotedTupleT 0) = text "'()" pprParendType (PromotedTupleT 1) = pprParendType (PromotedT (tupleDataName 1)) pprParendType (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma)) pprParendType PromotedNilT = text "'[]" pprParendType PromotedConsT = text "'(:)" pprParendType StarT = char '*' pprParendType ConstraintT = text "Constraint" pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k) pprParendType WildCardT = char '_' pprParendType (InfixT x n y) = parens (ppr x <+> pprName' Infix n <+> ppr y) pprParendType t@(UInfixT {}) = parens (pprUInfixT t) pprParendType (ParensT t) = ppr t pprParendType tuple | (TupleT n, args) <- split tuple , length args == n = parens (commaSep args) pprParendType (ImplicitParamT n t)= text ('?':n) <+> text "::" <+> ppr t pprParendType EqualityT = text "(~)" pprParendType t@(ForallT {}) = parens (ppr t) pprParendType t@(ForallVisT {}) = parens (ppr t) pprParendType t@(AppT {}) = parens (ppr t) pprParendType t@(AppKindT {}) = parens (ppr t) pprUInfixT :: Type -> Doc pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y pprUInfixT t = ppr t instance Ppr Type where ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty] ppr (ForallVisT tvars ty) = sep [pprForallVis tvars [], ppr ty] ppr ty = pprTyApp (split ty) -- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind) -- See Note [Pretty-printing kind signatures] instance Ppr TypeArg where ppr (TANormal ty) = ppr ty ppr (TyArg ki) = char '@' <> ppr ki pprParendTypeArg :: TypeArg -> Doc pprParendTypeArg (TANormal ty) = pprParendType ty pprParendTypeArg (TyArg ki) = char '@' <> pprParendType ki {- Note [Pretty-printing kind signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC's parser only recognises a kind signature in a type when there are parens around it. E.g. the parens are required here: f :: (Int :: *) type instance F Int = (Bool :: *) So we always print a SigT with parens (see #10050). -} pprTyApp :: (Type, [TypeArg]) -> Doc pprTyApp (ArrowT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2] pprTyApp (EqualityT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "~", ppr arg2] pprTyApp (ListT, [TANormal arg]) = brackets (ppr arg) pprTyApp (TupleT n, args) | length args == n = if n == 1 then pprTyApp (ConT (tupleTypeName 1), args) else parens (commaSep args) pprTyApp (PromotedTupleT n, args) | length args == n = if n == 1 then pprTyApp (PromotedT (tupleDataName 1), args) else quoteParens (commaSep args) pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendTypeArg args) pprFunArgType :: Type -> Doc -- Should really use a precedence argument -- Everything except forall and (->) binds more tightly than (->) pprFunArgType ty@(ForallT {}) = parens (ppr ty) pprFunArgType ty@(ForallVisT {}) = parens (ppr ty) pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty) pprFunArgType ty@(SigT _ _) = parens (ppr ty) pprFunArgType ty = ppr ty data ForallVisFlag = ForallVis -- forall a -> {...} | ForallInvis -- forall a. {...} deriving Show data TypeArg = TANormal Type | TyArg Kind split :: Type -> (Type, [TypeArg]) -- Split into function and args split t = go t [] where go (AppT t1 t2) args = go t1 (TANormal t2:args) go (AppKindT ty ki) args = go ty (TyArg ki:args) go ty args = (ty, args) pprTyLit :: TyLit -> Doc pprTyLit (NumTyLit n) = integer n pprTyLit (StrTyLit s) = text (show s) instance Ppr TyLit where ppr = pprTyLit ------------------------------ instance Ppr TyVarBndr where ppr (PlainTV nm) = ppr nm ppr (KindedTV nm k) = parens (ppr nm <+> dcolon <+> ppr k) instance Ppr Role where ppr NominalR = text "nominal" ppr RepresentationalR = text "representational" ppr PhantomR = text "phantom" ppr InferR = text "_" ------------------------------ pprCxt :: Cxt -> Doc pprCxt [] = empty pprCxt ts = ppr_cxt_preds ts <+> text "=>" ppr_cxt_preds :: Cxt -> Doc ppr_cxt_preds [] = empty ppr_cxt_preds [t@ImplicitParamT{}] = parens (ppr t) ppr_cxt_preds [t@ForallT{}] = parens (ppr t) ppr_cxt_preds [t] = ppr t ppr_cxt_preds ts = parens (commaSep ts) ------------------------------ instance Ppr Range where ppr = brackets . pprRange where pprRange :: Range -> Doc pprRange (FromR e) = ppr e <> text ".." pprRange (FromThenR e1 e2) = ppr e1 <> text "," <> ppr e2 <> text ".." pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2 pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text "," <> ppr e2 <> text ".." <> ppr e3 ------------------------------ where_clause :: [Dec] -> Doc where_clause [] = empty where_clause ds = nest nestDepth $ text "where" <+> vcat (map (ppr_dec False) ds) showtextl :: Show a => a -> Doc showtextl = text . map toLower . show hashParens :: Doc -> Doc hashParens d = text "(# " <> d <> text " #)" quoteParens :: Doc -> Doc quoteParens d = text "'(" <> d <> text ")" ----------------------------- instance Ppr Loc where ppr (Loc { loc_module = md , loc_package = pkg , loc_start = (start_ln, start_col) , loc_end = (end_ln, end_col) }) = hcat [ text pkg, colon, text md, colon , parens $ int start_ln <> comma <> int start_col , text "-" , parens $ int end_ln <> comma <> int end_col ] -- Takes a list of printable things and prints them separated by commas followed -- by space. commaSep :: Ppr a => [a] -> Doc commaSep = commaSepWith ppr -- Takes a list of things and prints them with the given pretty-printing -- function, separated by commas followed by space. commaSepWith :: (a -> Doc) -> [a] -> Doc commaSepWith pprFun = sep . punctuate comma . map pprFun -- Takes a list of printable things and prints them separated by semicolons -- followed by space. semiSep :: Ppr a => [a] -> Doc semiSep = sep . punctuate semi . map ppr -- 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) -- Text containing the vertical bar character. bar :: Doc bar = char '|' ghc-lib-parser-8.10.2.20200808/libraries/template-haskell/Language/Haskell/TH/PprLib.hs0000644000000000000000000001504513713635662026067 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, 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 (Uniq, Name(..), showName', NameFlavour(..), NameIs(..)) import qualified Text.PrettyPrint as HPJ import Control.Monad (liftM, liftM2, ap) import Language.Haskell.TH.Lib.Map ( Map ) import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty ) import Prelude hiding ((<>)) infixl 6 <> infixl 6 <+> infixl 5 $$, $+$ -- --------------------------------------------------------------------------- -- The interface -- The primitive Doc values instance Show Doc where show d = HPJ.render (to_HPJ_Doc d) isEmpty :: Doc -> PprM Bool; -- ^ Returns 'True' if the document is empty empty :: Doc; -- ^ An empty document semi :: Doc; -- ^ A ';' character comma :: Doc; -- ^ A ',' character colon :: Doc; -- ^ A ':' character dcolon :: Doc; -- ^ A "::" string space :: Doc; -- ^ A space character equals :: Doc; -- ^ A '=' character arrow :: Doc; -- ^ A "->" string lparen :: Doc; -- ^ A '(' character rparen :: Doc; -- ^ A ')' character lbrack :: Doc; -- ^ A '[' character rbrack :: Doc; -- ^ A ']' character lbrace :: Doc; -- ^ A '{' character rbrace :: Doc; -- ^ A '}' character text :: String -> Doc ptext :: String -> Doc char :: Char -> Doc int :: Int -> Doc integer :: Integer -> Doc float :: Float -> Doc double :: Double -> Doc rational :: Rational -> Doc parens :: Doc -> Doc; -- ^ Wrap document in @(...)@ brackets :: Doc -> Doc; -- ^ Wrap document in @[...]@ braces :: Doc -> Doc; -- ^ Wrap document in @{...}@ quotes :: Doc -> Doc; -- ^ Wrap document in @\'...\'@ doubleQuotes :: Doc -> Doc; -- ^ Wrap document in @\"...\"@ -- Combining @Doc@ values (<>) :: Doc -> Doc -> Doc; -- ^Beside hcat :: [Doc] -> Doc; -- ^List version of '<>' (<+>) :: Doc -> Doc -> Doc; -- ^Beside, separated by space hsep :: [Doc] -> Doc; -- ^List version of '<+>' ($$) :: Doc -> Doc -> Doc; -- ^Above; if there is no -- overlap it \"dovetails\" the two ($+$) :: Doc -> Doc -> Doc; -- ^Above, without dovetailing. vcat :: [Doc] -> Doc; -- ^List version of '$$' cat :: [Doc] -> Doc; -- ^ Either hcat or vcat sep :: [Doc] -> Doc; -- ^ Either hsep or vcat fcat :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of cat fsep :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of sep nest :: Int -> Doc -> Doc; -- ^ Nested -- GHC-specific ones. hang :: Doc -> Int -> Doc -> Doc; -- ^ @hang d1 n d2 = sep [d1, nest n d2]@ punctuate :: Doc -> [Doc] -> [Doc] -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ -- --------------------------------------------------------------------------- -- The "implementation" type State = (Map Name Name, Uniq) data PprM a = PprM { runPprM :: State -> (a, State) } pprName :: Name -> Doc pprName = pprName' Alone pprName' :: NameIs -> Name -> Doc pprName' ni n@(Name o (NameU _)) = PprM $ \s@(fm, i) -> let (n', s') = case Map.lookup n fm of Just d -> (d, s) Nothing -> let n'' = Name o (NameU i) in (n'', (Map.insert n n'' fm, i + 1)) in (HPJ.text $ showName' ni n', s') pprName' ni n = text $ showName' ni n {- instance Show Name where show (Name occ (NameU u)) = occString occ ++ "_" ++ show (I# u) show (Name occ NameS) = occString occ show (Name occ (NameG ns m)) = modString m ++ "." ++ occString occ data Name = Name OccName NameFlavour data NameFlavour | NameU Int# -- A unique local name -} to_HPJ_Doc :: Doc -> HPJ.Doc to_HPJ_Doc d = fst $ runPprM d (Map.empty, 0) instance Functor PprM where fmap = liftM instance Applicative PprM where pure x = PprM $ \s -> (x, s) (<*>) = ap instance Monad PprM where m >>= k = PprM $ \s -> let (x, s') = runPprM m s in runPprM (k x) s' type Doc = PprM HPJ.Doc -- The primitive Doc values isEmpty = liftM HPJ.isEmpty empty = return HPJ.empty semi = return HPJ.semi comma = return HPJ.comma colon = return HPJ.colon dcolon = return $ HPJ.text "::" space = return HPJ.space equals = return HPJ.equals arrow = return $ HPJ.text "->" lparen = return HPJ.lparen rparen = return HPJ.rparen lbrack = return HPJ.lbrack rbrack = return HPJ.rbrack lbrace = return HPJ.lbrace rbrace = return HPJ.rbrace text = return . HPJ.text ptext = return . HPJ.ptext char = return . HPJ.char int = return . HPJ.int integer = return . HPJ.integer float = return . HPJ.float double = return . HPJ.double rational = return . HPJ.rational parens = liftM HPJ.parens brackets = liftM HPJ.brackets braces = liftM HPJ.braces quotes = liftM HPJ.quotes doubleQuotes = liftM HPJ.doubleQuotes -- Combining @Doc@ values (<>) = liftM2 (HPJ.<>) hcat = liftM HPJ.hcat . sequence (<+>) = liftM2 (HPJ.<+>) hsep = liftM HPJ.hsep . sequence ($$) = liftM2 (HPJ.$$) ($+$) = liftM2 (HPJ.$+$) vcat = liftM HPJ.vcat . sequence cat = liftM HPJ.cat . sequence sep = liftM HPJ.sep . sequence fcat = liftM HPJ.fcat . sequence fsep = liftM HPJ.fsep . sequence nest n = liftM (HPJ.nest n) hang d1 n d2 = do d1' <- d1 d2' <- d2 return (HPJ.hang d1' n d2') -- punctuate uses the same definition as Text.PrettyPrint punctuate _ [] = [] punctuate p (d:ds) = go d ds where go d' [] = [d'] go d' (e:es) = (d' <> p) : go e es ghc-lib-parser-8.10.2.20200808/libraries/template-haskell/Language/Haskell/TH/Syntax.hs0000644000000000000000000026033513713635665026174 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, DefaultSignatures, RankNTypes, RoleAnnotations, ScopedTypeVariables, MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds, GADTs, UnboxedTuples, UnboxedSums, TypeInType, Trustworthy #-} {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Syntax -- Copyright : (c) The University of Glasgow 2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable -- -- Abstract syntax definitions for Template Haskell. -- ----------------------------------------------------------------------------- module Language.Haskell.TH.Syntax ( module Language.Haskell.TH.Syntax -- * Language extensions , module Language.Haskell.TH.LanguageExtensions , ForeignSrcLang(..) ) where import Data.Data hiding (Fixity(..)) import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO (..)) import System.IO ( hPutStrLn, stderr ) import Data.Char ( isAlpha, isAlphaNum, isUpper, ord ) import Data.Int import Data.List.NonEmpty ( NonEmpty(..) ) import Data.Void ( Void, absurd ) import Data.Word import Data.Ratio import GHC.CString ( unpackCString# ) import GHC.Generics ( Generic ) import GHC.Types ( Int(..), Word(..), Char(..), Double(..), Float(..), TYPE, RuntimeRep(..) ) import GHC.Prim ( Int#, Word#, Char#, Double#, Float#, Addr# ) import GHC.Lexeme ( startsVarSym, startsVarId ) import GHC.ForeignSrcLang.Type import Language.Haskell.TH.LanguageExtensions import Numeric.Natural import Prelude import Foreign.ForeignPtr import qualified Control.Monad.Fail as Fail ----------------------------------------------------- -- -- The Quasi class -- ----------------------------------------------------- class (MonadIO m, Fail.MonadFail m) => Quasi m where qNewName :: String -> m Name -- ^ Fresh names -- Error reporting and recovery qReport :: Bool -> String -> m () -- ^ Report an error (True) or warning (False) -- ...but carry on; use 'fail' to stop qRecover :: m a -- ^ the error handler -> m a -- ^ action which may fail -> m a -- ^ Recover from the monadic 'fail' -- Inspect the type-checker's environment qLookupName :: Bool -> String -> m (Maybe Name) -- True <=> type namespace, False <=> value namespace qReify :: Name -> m Info qReifyFixity :: Name -> m (Maybe Fixity) qReifyType :: Name -> m Type qReifyInstances :: Name -> [Type] -> m [Dec] -- Is (n tys) an instance? -- Returns list of matching instance Decs -- (with empty sub-Decs) -- Works for classes and type functions qReifyRoles :: Name -> m [Role] qReifyAnnotations :: Data a => AnnLookup -> m [a] qReifyModule :: Module -> m ModuleInfo qReifyConStrictness :: Name -> m [DecidedStrictness] qLocation :: m Loc qRunIO :: IO a -> m a qRunIO = liftIO -- ^ Input/output (dangerous) qAddDependentFile :: FilePath -> m () qAddTempFile :: String -> m FilePath qAddTopDecls :: [Dec] -> m () qAddForeignFilePath :: ForeignSrcLang -> String -> m () qAddModFinalizer :: Q () -> m () qAddCorePlugin :: String -> m () qGetQ :: Typeable a => m (Maybe a) qPutQ :: Typeable a => a -> m () qIsExtEnabled :: Extension -> m Bool qExtsEnabled :: m [Extension] ----------------------------------------------------- -- The IO instance of Quasi -- -- This instance is used only when running a Q -- computation in the IO monad, usually just to -- print the result. There is no interesting -- type environment, so reification isn't going to -- work. -- ----------------------------------------------------- instance Quasi IO where qNewName s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x)) ; pure (mkNameU s n) } qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) qLookupName _ _ = badIO "lookupName" qReify _ = badIO "reify" qReifyFixity _ = badIO "reifyFixity" qReifyType _ = badIO "reifyFixity" qReifyInstances _ _ = badIO "reifyInstances" qReifyRoles _ = badIO "reifyRoles" qReifyAnnotations _ = badIO "reifyAnnotations" qReifyModule _ = badIO "reifyModule" qReifyConStrictness _ = badIO "reifyConStrictness" qLocation = badIO "currentLocation" qRecover _ _ = badIO "recover" -- Maybe we could fix this? qAddDependentFile _ = badIO "addDependentFile" qAddTempFile _ = badIO "addTempFile" qAddTopDecls _ = badIO "addTopDecls" qAddForeignFilePath _ _ = badIO "addForeignFilePath" qAddModFinalizer _ = badIO "addModFinalizer" qAddCorePlugin _ = badIO "addCorePlugin" qGetQ = badIO "getQ" qPutQ _ = badIO "putQ" qIsExtEnabled _ = badIO "isExtEnabled" qExtsEnabled = badIO "extsEnabled" badIO :: String -> IO a badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad") ; fail "Template Haskell failure" } -- Global variable to generate unique symbols counter :: IORef Uniq {-# NOINLINE counter #-} counter = unsafePerformIO (newIORef 0) ----------------------------------------------------- -- -- The Q monad -- ----------------------------------------------------- newtype Q a = Q { unQ :: forall m. Quasi m => m a } -- \"Runs\" the 'Q' monad. Normal users of Template Haskell -- should not need this function, as the splice brackets @$( ... )@ -- are the usual way of running a 'Q' computation. -- -- This function is primarily used in GHC internals, and for debugging -- splices by running them in 'IO'. -- -- Note that many functions in 'Q', such as 'reify' and other compiler -- queries, are not supported when running 'Q' in 'IO'; these operations -- simply fail at runtime. Indeed, the only operations guaranteed to succeed -- are 'newName', 'runIO', 'reportError' and 'reportWarning'. runQ :: Quasi m => Q a -> m a runQ (Q m) = m instance Monad Q where Q m >>= k = Q (m >>= \x -> unQ (k x)) (>>) = (*>) #if !MIN_VERSION_base(4,13,0) fail = Fail.fail #endif instance Fail.MonadFail Q where fail s = report True s >> Q (Fail.fail "Q monad failure") instance Functor Q where fmap f (Q x) = Q (fmap f x) instance Applicative Q where pure x = Q (pure x) Q f <*> Q x = Q (f <*> x) Q m *> Q n = Q (m *> n) ----------------------------------------------------- -- -- The TExp type -- ----------------------------------------------------- type role TExp nominal -- See Note [Role of TExp] newtype TExp (a :: TYPE (r :: RuntimeRep)) = TExp { unType :: Exp -- ^ Underlying untyped Template Haskell expression } -- ^ Represents an expression which has type @a@. Built on top of 'Exp', typed -- expressions allow for type-safe splicing via: -- -- - typed quotes, written as @[|| ... ||]@ where @...@ is an expression; if -- that expression has type @a@, then the quotation has type -- @'Q' ('TExp' a)@ -- -- - typed splices inside of typed quotes, written as @$$(...)@ where @...@ -- is an arbitrary expression of type @'Q' ('TExp' a)@ -- -- Traditional expression quotes and splices let us construct ill-typed -- expressions: -- -- >>> fmap ppr $ runQ [| True == $( [| "foo" |] ) |] -- GHC.Types.True GHC.Classes.== "foo" -- >>> GHC.Types.True GHC.Classes.== "foo" -- error: -- • Couldn't match expected type ‘Bool’ with actual type ‘[Char]’ -- • In the second argument of ‘(==)’, namely ‘"foo"’ -- In the expression: True == "foo" -- In an equation for ‘it’: it = True == "foo" -- -- With typed expressions, the type error occurs when /constructing/ the -- Template Haskell expression: -- -- >>> fmap ppr $ runQ [|| True == $$( [|| "foo" ||] ) ||] -- error: -- • Couldn't match type ‘[Char]’ with ‘Bool’ -- Expected type: Q (TExp Bool) -- Actual type: Q (TExp [Char]) -- • In the Template Haskell quotation [|| "foo" ||] -- In the expression: [|| "foo" ||] -- In the Template Haskell splice $$([|| "foo" ||]) -- | Discard the type annotation and produce a plain Template Haskell -- expression -- -- Levity-polymorphic since /template-haskell-2.16.0.0/. unTypeQ :: forall (r :: RuntimeRep) (a :: TYPE r). Q (TExp a) -> Q Exp unTypeQ m = do { TExp e <- m ; return e } -- | Annotate the Template Haskell expression with a type -- -- This is unsafe because GHC cannot check for you that the expression -- really does have the type you claim it has. -- -- Levity-polymorphic since /template-haskell-2.16.0.0/. unsafeTExpCoerce :: forall (r :: RuntimeRep) (a :: TYPE r). 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 (#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) {- | @reifyType nm@ attempts to find the type or kind of @nm@. For example, @reifyType 'not@ returns @Bool -> Bool@, and @reifyType ''Bool@ returns @Type@. This works even if there's no explicit signature and the type or kind is inferred. -} reifyType :: Name -> Q Type reifyType nm = Q (qReifyType nm) {- | @reifyInstances nm tys@ returns a list of visible instances of @nm tys@. That is, if @nm@ is the name of a type class, then all instances of this class at the types @tys@ are returned. Alternatively, if @nm@ is the name of a data family or type family, all instances of this family at the types @tys@ are returned. Note that this is a \"shallow\" test; the declarations returned merely have instance heads which unify with @nm tys@, they need not actually be satisfiable. - @reifyInstances ''Eq [ 'TupleT' 2 \``AppT`\` 'ConT' ''A \``AppT`\` 'ConT' ''B ]@ contains the @instance (Eq a, Eq b) => Eq (a, b)@ regardless of whether @A@ and @B@ themselves implement 'Eq' - @reifyInstances ''Show [ 'VarT' ('mkName' "a") ]@ produces every available instance of 'Eq' There is one edge case: @reifyInstances ''Typeable tys@ currently always produces an empty list (no matter what @tys@ are given). -} reifyInstances :: Name -> [Type] -> Q [InstanceDec] reifyInstances cls tys = Q (qReifyInstances cls tys) {- | @reifyRoles nm@ returns the list of roles associated with the parameters of the tycon @nm@. Fails if @nm@ cannot be found or is not a tycon. The returned list should never contain 'InferR'. -} reifyRoles :: Name -> Q [Role] reifyRoles nm = Q (qReifyRoles nm) -- | @reifyAnnotations target@ returns the list of annotations -- associated with @target@. Only the annotations that are -- appropriately typed is returned. So if you have @Int@ and @String@ -- annotations for the same target, you have to call this function twice. reifyAnnotations :: Data a => AnnLookup -> Q [a] reifyAnnotations an = Q (qReifyAnnotations an) -- | @reifyModule mod@ looks up information about module @mod@. To -- look up the current module, call this function with the return -- value of 'Language.Haskell.TH.Lib.thisModule'. reifyModule :: Module -> Q ModuleInfo reifyModule m = Q (qReifyModule m) -- | @reifyConStrictness nm@ looks up the strictness information for the fields -- of the constructor with the name @nm@. Note that the strictness information -- that 'reifyConStrictness' returns may not correspond to what is written in -- the source code. For example, in the following data declaration: -- -- @ -- data Pair a = Pair a a -- @ -- -- 'reifyConStrictness' would return @['DecidedLazy', DecidedLazy]@ under most -- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the -- @-XStrictData@ language extension was enabled. reifyConStrictness :: Name -> Q [DecidedStrictness] reifyConStrictness n = Q (qReifyConStrictness n) -- | Is the list of instances returned by 'reifyInstances' nonempty? isInstance :: Name -> [Type] -> Q Bool isInstance nm tys = do { decs <- reifyInstances nm tys ; return (not (null decs)) } -- | The location at which this computation is spliced. location :: Q Loc location = Q qLocation -- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad. -- Take care: you are guaranteed the ordering of calls to 'runIO' within -- a single 'Q' computation, but not about the order in which splices are run. -- -- Note: for various murky reasons, stdout and stderr handles are not -- necessarily flushed when the compiler finishes running, so you should -- flush them yourself. runIO :: IO a -> Q a runIO m = Q (qRunIO m) -- | Record external files that runIO is using (dependent upon). -- The compiler can then recognize that it should re-compile the Haskell file -- when an external file changes. -- -- Expects an absolute file path. -- -- Notes: -- -- * ghc -M does not know about these dependencies - it does not execute TH. -- -- * The dependency is based on file content, not a modification time addDependentFile :: FilePath -> Q () addDependentFile fp = Q (qAddDependentFile fp) -- | Obtain a temporary file path with the given suffix. The compiler will -- delete this file after compilation. addTempFile :: String -> Q FilePath addTempFile suffix = Q (qAddTempFile suffix) -- | Add additional top-level declarations. The added declarations will be type -- checked along with the current declaration group. addTopDecls :: [Dec] -> Q () addTopDecls ds = Q (qAddTopDecls ds) -- | addForeignFile :: ForeignSrcLang -> String -> Q () addForeignFile = addForeignSource {-# DEPRECATED addForeignFile "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead" #-} -- deprecated in 8.6 -- | Emit a foreign file which will be compiled and linked to the object for -- the current module. Currently only languages that can be compiled with -- the C compiler are supported, and the flags passed as part of -optc will -- be also applied to the C compiler invocation that will compile them. -- -- Note that for non-C languages (for example C++) @extern "C"@ directives -- must be used to get symbols that we can access from Haskell. -- -- To get better errors, it is recommended to use #line pragmas when -- emitting C files, e.g. -- -- > {-# LANGUAGE CPP #-} -- > ... -- > addForeignSource LangC $ unlines -- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__ -- > , ... -- > ] addForeignSource :: ForeignSrcLang -> String -> Q () addForeignSource lang src = do let suffix = case lang of LangC -> "c" LangCxx -> "cpp" LangObjc -> "m" LangObjcxx -> "mm" LangAsm -> "s" RawObject -> "a" path <- addTempFile suffix runIO $ writeFile path src addForeignFilePath lang path -- | Same as 'addForeignSource', but expects to receive a path pointing to the -- foreign file instead of a 'String' of its contents. Consider using this in -- conjunction with 'addTempFile'. -- -- This is a good alternative to 'addForeignSource' when you are trying to -- directly link in an object file. addForeignFilePath :: ForeignSrcLang -> FilePath -> Q () addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp) -- | Add a finalizer that will run in the Q monad after the current module has -- been type checked. This only makes sense when run within a top-level splice. -- -- The finalizer is given the local type environment at the splice point. Thus -- 'reify' is able to find the local definitions when executed inside the -- finalizer. addModFinalizer :: Q () -> Q () addModFinalizer act = Q (qAddModFinalizer (unQ act)) -- | Adds a core plugin to the compilation pipeline. -- -- @addCorePlugin m@ has almost the same effect as passing @-fplugin=m@ to ghc -- in the command line. The major difference is that the plugin module @m@ -- must not belong to the current package. When TH executes, it is too late -- to tell the compiler that we needed to compile first a plugin module in the -- current package. addCorePlugin :: String -> Q () addCorePlugin plugin = Q (qAddCorePlugin plugin) -- | Get state from the 'Q' monad. Note that the state is local to the -- Haskell module in which the Template Haskell expression is executed. getQ :: Typeable a => Q (Maybe a) getQ = Q qGetQ -- | Replace the state in the 'Q' monad. Note that the state is local to the -- Haskell module in which the Template Haskell expression is executed. putQ :: Typeable a => a -> Q () putQ x = Q (qPutQ x) -- | Determine whether the given language extension is enabled in the 'Q' monad. isExtEnabled :: Extension -> Q Bool isExtEnabled ext = Q (qIsExtEnabled ext) -- | List all enabled language extensions. extsEnabled :: Q [Extension] extsEnabled = Q qExtsEnabled instance MonadIO Q where liftIO = runIO instance Quasi Q where qNewName = newName qReport = report qRecover = recover qReify = reify qReifyFixity = reifyFixity qReifyType = reifyType qReifyInstances = reifyInstances qReifyRoles = reifyRoles qReifyAnnotations = reifyAnnotations qReifyModule = reifyModule qReifyConStrictness = reifyConStrictness qLookupName = lookupName qLocation = location qAddDependentFile = addDependentFile qAddTempFile = addTempFile qAddTopDecls = addTopDecls qAddForeignFilePath = addForeignFilePath qAddModFinalizer = addModFinalizer qAddCorePlugin = addCorePlugin qGetQ = getQ qPutQ = putQ qIsExtEnabled = isExtEnabled qExtsEnabled = extsEnabled ---------------------------------------------------- -- The following operations are used solely in DsMeta when desugaring brackets -- They are not necessary for the user, who can use ordinary return and (>>=) etc returnQ :: a -> Q a returnQ = return bindQ :: Q a -> (a -> Q b) -> Q b bindQ = (>>=) sequenceQ :: [Q a] -> Q [a] sequenceQ = sequence ----------------------------------------------------- -- -- The Lift class -- ----------------------------------------------------- -- | A 'Lift' instance can have any of its values turned into a Template -- Haskell expression. This is needed when a value used within a Template -- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@ or -- @[|| ... ||]@) but not at the top level. As an example: -- -- > add1 :: Int -> Q (TExp Int) -- > add1 x = [|| x + 1 ||] -- -- Template Haskell has no way of knowing what value @x@ will take on at -- splice-time, so it requires the type of @x@ to be an instance of 'Lift'. -- -- A 'Lift' instance must satisfy @$(lift x) ≡ x@ and @$$(liftTyped x) ≡ x@ -- for all @x@, where @$(...)@ and @$$(...)@ are Template Haskell splices. -- It is additionally expected that @'lift' x ≡ 'unTypeQ' ('liftTyped' x)@. -- -- '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 -- -- Levity-polymorphic since /template-haskell-2.16.0.0/. class Lift (t :: TYPE r) where -- | Turn a value into a Template Haskell expression, suitable for use in -- a splice. lift :: t -> Q Exp default lift :: (r ~ 'LiftedRep) => t -> Q Exp lift = unTypeQ . liftTyped -- | Turn a value into a Template Haskell typed expression, suitable for use -- in a typed splice. -- -- @since 2.16.0.0 liftTyped :: t -> Q (TExp t) -- If you add any instances here, consider updating test th/TH_Lift instance Lift Integer where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (IntegerL x)) instance Lift Int where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) -- | @since 2.16.0.0 instance Lift Int# where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (IntPrimL (fromIntegral (I# x)))) instance Lift Int8 where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Int16 where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Int32 where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Int64 where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) -- | @since 2.16.0.0 instance Lift Word# where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (WordPrimL (fromIntegral (W# x)))) instance Lift Word where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Word8 where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Word16 where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Word32 where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Word64 where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Natural where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Integral a => Lift (Ratio a) where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (RationalL (toRational x))) instance Lift Float where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (RationalL (toRational x))) -- | @since 2.16.0.0 instance Lift Float# where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (FloatPrimL (toRational (F# x)))) instance Lift Double where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (RationalL (toRational x))) -- | @since 2.16.0.0 instance Lift Double# where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (DoublePrimL (toRational (D# x)))) instance Lift Char where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (CharL x)) -- | @since 2.16.0.0 instance Lift Char# where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (CharPrimL (C# x))) instance Lift Bool where liftTyped x = unsafeTExpCoerce (lift x) lift True = return (ConE trueName) lift False = return (ConE falseName) -- | Produces an 'Addr#' literal from the NUL-terminated C-string starting at -- the given memory address. -- -- @since 2.16.0.0 instance Lift Addr# where liftTyped x = unsafeTExpCoerce (lift x) lift x = return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x)))) instance Lift a => Lift (Maybe a) where liftTyped x = unsafeTExpCoerce (lift x) lift Nothing = return (ConE nothingName) lift (Just x) = liftM (ConE justName `AppE`) (lift x) instance (Lift a, Lift b) => Lift (Either a b) where liftTyped x = unsafeTExpCoerce (lift x) lift (Left x) = liftM (ConE leftName `AppE`) (lift x) lift (Right y) = liftM (ConE rightName `AppE`) (lift y) instance Lift a => Lift [a] where liftTyped x = unsafeTExpCoerce (lift x) lift xs = do { xs' <- mapM lift xs; return (ListE xs') } liftString :: String -> Q Exp -- Used in TcExpr to short-circuit the lifting for strings liftString s = return (LitE (StringL s)) -- | @since 2.15.0.0 instance Lift a => Lift (NonEmpty a) where liftTyped x = unsafeTExpCoerce (lift x) lift (x :| xs) = do x' <- lift x xs' <- lift xs return (InfixE (Just x') (ConE nonemptyName) (Just xs')) -- | @since 2.15.0.0 instance Lift Void where liftTyped = pure . absurd lift = pure . absurd instance Lift () where liftTyped x = unsafeTExpCoerce (lift x) lift () = return (ConE (tupleDataName 0)) instance (Lift a, Lift b) => Lift (a, b) where liftTyped x = unsafeTExpCoerce (lift x) lift (a, b) = liftM TupE $ sequence $ map (fmap Just) [lift a, lift b] instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where liftTyped x = unsafeTExpCoerce (lift x) lift (a, b, c) = liftM TupE $ sequence $ map (fmap Just) [lift a, lift b, lift c] instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where liftTyped x = unsafeTExpCoerce (lift x) lift (a, b, c, d) = liftM TupE $ sequence $ map (fmap Just) [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 liftTyped x = unsafeTExpCoerce (lift x) lift (a, b, c, d, e) = liftM TupE $ sequence $ map (fmap Just) [ 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 liftTyped x = unsafeTExpCoerce (lift x) lift (a, b, c, d, e, f) = liftM TupE $ sequence $ map (fmap Just) [ 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 liftTyped x = unsafeTExpCoerce (lift x) lift (a, b, c, d, e, f, g) = liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c , lift d, lift e, lift f, lift g ] -- | @since 2.16.0.0 instance Lift (# #) where liftTyped x = unsafeTExpCoerce (lift x) lift (# #) = return (ConE (unboxedTupleTypeName 0)) -- | @since 2.16.0.0 instance (Lift a) => Lift (# a #) where liftTyped x = unsafeTExpCoerce (lift x) lift (# a #) = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a] -- | @since 2.16.0.0 instance (Lift a, Lift b) => Lift (# a, b #) where liftTyped x = unsafeTExpCoerce (lift x) lift (# a, b #) = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a, lift b] -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c) => Lift (# a, b, c #) where liftTyped x = unsafeTExpCoerce (lift x) lift (# a, b, c #) = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a, lift b, lift c] -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d) => Lift (# a, b, c, d #) where liftTyped x = unsafeTExpCoerce (lift x) lift (# a, b, c, d #) = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b , lift c, lift d ] -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d, Lift e) => Lift (# a, b, c, d, e #) where liftTyped x = unsafeTExpCoerce (lift x) lift (# a, b, c, d, e #) = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b , lift c, lift d, lift e ] -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f) => Lift (# a, b, c, d, e, f #) where liftTyped x = unsafeTExpCoerce (lift x) lift (# a, b, c, d, e, f #) = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c , lift d, lift e, lift f ] -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g) => Lift (# a, b, c, d, e, f, g #) where liftTyped x = unsafeTExpCoerce (lift x) lift (# a, b, c, d, e, f, g #) = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c , lift d, lift e, lift f , lift g ] -- | @since 2.16.0.0 instance (Lift a, Lift b) => Lift (# a | b #) where liftTyped x = unsafeTExpCoerce (lift x) lift x = case x of (# y | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 2 (# | y #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 2 -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c) => Lift (# a | b | c #) where liftTyped x = unsafeTExpCoerce (lift x) lift x = case x of (# y | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 3 (# | y | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 3 (# | | y #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 3 -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d) => Lift (# a | b | c | d #) where liftTyped x = unsafeTExpCoerce (lift x) lift x = case x of (# y | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 4 (# | y | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 4 (# | | y | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 4 (# | | | y #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 4 -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d, Lift e) => Lift (# a | b | c | d | e #) where liftTyped x = unsafeTExpCoerce (lift x) lift x = case x of (# y | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 5 (# | y | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 5 (# | | y | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 5 (# | | | y | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 5 (# | | | | y #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 5 -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f) => Lift (# a | b | c | d | e | f #) where liftTyped x = unsafeTExpCoerce (lift x) lift x = case x of (# y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 6 (# | y | | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 6 (# | | y | | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 6 (# | | | y | | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 6 (# | | | | y | #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 6 (# | | | | | y #) -> UnboxedSumE <$> lift y <*> pure 6 <*> pure 6 -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g) => Lift (# a | b | c | d | e | f | g #) where liftTyped x = unsafeTExpCoerce (lift x) lift x = case x of (# y | | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 7 (# | y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 7 (# | | y | | | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 7 (# | | | y | | | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 7 (# | | | | y | | #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 7 (# | | | | | y | #) -> UnboxedSumE <$> lift y <*> pure 6 <*> pure 7 (# | | | | | | y #) -> UnboxedSumE <$> lift y <*> pure 7 <*> pure 7 -- TH has a special form for literal strings, -- which we should take advantage of. -- NB: the lhs of the rule has no args, so that -- the rule will apply to a 'lift' all on its own -- which happens to be the way the type checker -- creates it. {-# RULES "TH:liftString" lift = \s -> return (LitE (StringL s)) #-} trueName, falseName :: Name trueName = mkNameG DataName "ghc-prim" "GHC.Types" "True" falseName = mkNameG DataName "ghc-prim" "GHC.Types" "False" nothingName, justName :: Name nothingName = mkNameG DataName "base" "GHC.Maybe" "Nothing" justName = mkNameG DataName "base" "GHC.Maybe" "Just" leftName, rightName :: Name leftName = mkNameG DataName "base" "Data.Either" "Left" rightName = mkNameG DataName "base" "Data.Either" "Right" nonemptyName :: Name nonemptyName = mkNameG DataName "base" "GHC.Base" ":|" ----------------------------------------------------- -- -- Generic Lift implementations -- ----------------------------------------------------- -- | 'dataToQa' is an internal utility function for constructing generic -- conversion functions from types with 'Data' instances to various -- quasi-quoting representations. See the source of 'dataToExpQ' and -- 'dataToPatQ' for two example usages: @mkCon@, @mkLit@ -- and @appQ@ are overloadable to account for different syntax for -- expressions and patterns; @antiQ@ allows you to override type-specific -- cases, a common usage is just @const Nothing@, which results in -- no overloading. dataToQa :: forall a k q. Data a => (Name -> k) -> (Lit -> Q q) -> (k -> [Q q] -> Q q) -> (forall b . Data b => b -> Maybe (Q q)) -> a -> Q q dataToQa mkCon mkLit appCon antiQ t = case antiQ t of Nothing -> case constrRep constr of AlgConstr _ -> appCon (mkCon funOrConName) conArgs where funOrConName :: Name funOrConName = case showConstr constr of "(:)" -> Name (mkOccName ":") (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Types")) con@"[]" -> Name (mkOccName con) (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Types")) con@('(':_) -> Name (mkOccName con) (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Tuple")) -- Tricky case: see Note [Data for non-algebraic types] fun@(x:_) | startsVarSym x || startsVarId x -> mkNameG_v tyconPkg tyconMod fun con -> mkNameG_d tyconPkg tyconMod con where tycon :: TyCon tycon = (typeRepTyCon . typeOf) t tyconPkg, tyconMod :: String tyconPkg = tyConPackage tycon tyconMod = tyConModule tycon conArgs :: [Q q] conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t IntConstr n -> mkLit $ IntegerL n FloatConstr n -> mkLit $ RationalL n CharConstr c -> mkLit $ CharL c where constr :: Constr constr = toConstr t Just y -> y {- Note [Data for non-algebraic types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Class Data was originally intended for algebraic data types. But it is possible to use it for abstract types too. For example, in package `text` we find instance Data Text where ... toConstr _ = packConstr packConstr :: Constr packConstr = mkConstr textDataType "pack" [] Prefix Here `packConstr` isn't a real data constructor, it's an ordinary function. Two complications * In such a case, we must take care to build the Name using mkNameG_v (for values), not mkNameG_d (for data constructors). See #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". -} -- | '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 #10796. varOrConE s = case nameSpace s of Just VarName -> return (VarE s) Just DataName -> return (ConE s) _ -> fail $ "Can't construct an expression from name " ++ showName s appE x y = do { a <- x; b <- y; return (AppE a b)} litE c = return (LitE c) -- | 'liftData' is a variant of 'lift' in the 'Lift' type class which -- works for any type with a 'Data' instance. liftData :: Data a => a -> Q Exp liftData = dataToExpQ (const Nothing) -- | 'dataToPatQ' converts a value to a 'Q Pat' representation of the same -- value, in the SYB style. It takes a function to handle type-specific cases, -- alternatively, pass @const Nothing@ to get default behavior. dataToPatQ :: Data a => (forall b . Data b => b -> Maybe (Q Pat)) -> a -> Q Pat dataToPatQ = dataToQa id litP conP where litP l = return (LitP l) conP n ps = case nameSpace n of Just DataName -> do ps' <- sequence ps return (ConP n ps') _ -> fail $ "Can't construct a pattern from name " ++ showName n ----------------------------------------------------- -- Names and uniques ----------------------------------------------------- newtype ModName = ModName String -- Module name deriving (Show,Eq,Ord,Data,Generic) newtype PkgName = PkgName String -- package name deriving (Show,Eq,Ord,Data,Generic) -- | Obtained from 'reifyModule' and 'Language.Haskell.TH.Lib.thisModule'. data Module = Module PkgName ModName -- package qualified module name deriving (Show,Eq,Ord,Data,Generic) newtype OccName = OccName String deriving (Show,Eq,Ord,Data,Generic) mkModName :: String -> ModName mkModName s = ModName s modString :: ModName -> String modString (ModName m) = m mkPkgName :: String -> PkgName mkPkgName s = PkgName s pkgString :: PkgName -> String pkgString (PkgName m) = m ----------------------------------------------------- -- OccName ----------------------------------------------------- mkOccName :: String -> OccName mkOccName s = OccName s occString :: OccName -> String occString (OccName occ) = occ ----------------------------------------------------- -- Names ----------------------------------------------------- -- -- For "global" names ('NameG') we need a totally unique name, -- so we must include the name-space of the thing -- -- For unique-numbered things ('NameU'), we've got a unique reference -- anyway, so no need for name space -- -- For dynamically bound thing ('NameS') we probably want them to -- in a context-dependent way, so again we don't want the name -- space. For example: -- -- > let v = mkName "T" in [| data $v = $v |] -- -- Here we use the same Name for both type constructor and data constructor -- -- -- NameL and NameG are bound *outside* the TH syntax tree -- either globally (NameG) or locally (NameL). Ex: -- -- > f x = $(h [| (map, x) |]) -- -- The 'map' will be a NameG, and 'x' wil be a NameL -- -- These Names should never appear in a binding position in a TH syntax tree {- $namecapture #namecapture# Much of 'Name' API is concerned with the problem of /name capture/, which can be seen in the following example. > f expr = [| let x = 0 in $expr |] > ... > g x = $( f [| x |] ) > h y = $( f [| y |] ) A naive desugaring of this would yield: > g x = let x = 0 in x > h y = let x = 0 in y All of a sudden, @g@ and @h@ have different meanings! In this case, we say that the @x@ in the RHS of @g@ has been /captured/ by the binding of @x@ in @f@. What we actually want is for the @x@ in @f@ to be distinct from the @x@ in @g@, so we get the following desugaring: > g x = let x' = 0 in x > h y = let x' = 0 in y which avoids name capture as desired. In the general case, we say that a @Name@ can be captured if the thing it refers to can be changed by adding new declarations. -} {- | An abstract type representing names in the syntax tree. 'Name's can be constructed in several ways, which come with different name-capture guarantees (see "Language.Haskell.TH.Syntax#namecapture" for an explanation of name capture): * the built-in syntax @'f@ and @''T@ can be used to construct names, The expression @'f@ gives a @Name@ which refers to the value @f@ currently in scope, and @''T@ gives a @Name@ which refers to the type @T@ currently in scope. These names can never be captured. * 'lookupValueName' and 'lookupTypeName' are similar to @'f@ and @''T@ respectively, but the @Name@s are looked up at the point where the current splice is being run. These names can never be captured. * 'newName' monadically generates a new name, which can never be captured. * 'mkName' generates a capturable name. Names constructed using @newName@ and @mkName@ may be used in bindings (such as @let x = ...@ or @\x -> ...@), but names constructed using @lookupValueName@, @lookupTypeName@, @'f@, @''T@ may not. -} data Name = Name OccName NameFlavour deriving (Data, Eq, Generic) instance Ord Name where -- check if unique is different before looking at strings (Name o1 f1) `compare` (Name o2 f2) = (f1 `compare` f2) `thenCmp` (o1 `compare` o2) data NameFlavour = NameS -- ^ An unqualified name; dynamically bound | NameQ ModName -- ^ A qualified name; dynamically bound | NameU !Uniq -- ^ A unique local name | NameL !Uniq -- ^ 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 ) -- | @Uniq@ is used by GHC to distinguish names from each other. type Uniq = Integer -- | The name without its module prefix. -- -- ==== __Examples__ -- -- >>> nameBase ''Data.Either.Either -- "Either" -- >>> nameBase (mkName "foo") -- "foo" -- >>> nameBase (mkName "Module.foo") -- "foo" nameBase :: Name -> String nameBase (Name occ _) = occString occ -- | Module prefix of a name, if it exists. -- -- ==== __Examples__ -- -- >>> nameModule ''Data.Either.Either -- Just "Data.Either" -- >>> nameModule (mkName "foo") -- Nothing -- >>> nameModule (mkName "Module.foo") -- Just "Module" nameModule :: Name -> Maybe String nameModule (Name _ (NameQ m)) = Just (modString m) nameModule (Name _ (NameG _ _ m)) = Just (modString m) nameModule _ = Nothing -- | A name's package, if it exists. -- -- ==== __Examples__ -- -- >>> namePackage ''Data.Either.Either -- Just "base" -- >>> namePackage (mkName "foo") -- Nothing -- >>> namePackage (mkName "Module.foo") -- Nothing namePackage :: Name -> Maybe String namePackage (Name _ (NameG _ p _)) = Just (pkgString p) namePackage _ = Nothing -- | Returns whether a name represents an occurrence of a top-level variable -- ('VarName'), data constructor ('DataName'), type constructor, or type class -- ('TcClsName'). If we can't be sure, it returns 'Nothing'. -- -- ==== __Examples__ -- -- >>> nameSpace 'Prelude.id -- Just VarName -- >>> nameSpace (mkName "id") -- Nothing -- only works for top-level variable names -- >>> nameSpace 'Data.Maybe.Just -- Just DataName -- >>> nameSpace ''Data.Maybe.Maybe -- Just TcClsName -- >>> nameSpace ''Data.Ord.Ord -- Just TcClsName nameSpace :: Name -> Maybe NameSpace nameSpace (Name _ (NameG ns _ _)) = Just ns nameSpace _ = Nothing {- | Generate a capturable name. Occurrences of such names will be resolved according to the Haskell scoping rules at the occurrence site. For example: > f = [| pi + $(varE (mkName "pi")) |] > ... > g = let pi = 3 in $f In this case, @g@ is desugared to > g = Prelude.pi + 3 Note that @mkName@ may be used with qualified names: > mkName "Prelude.pi" See also 'Language.Haskell.TH.Lib.dyn' for a useful combinator. The above example could be rewritten using 'Language.Haskell.TH.Lib.dyn' as > f = [| pi + $(dyn "pi") |] -} mkName :: String -> Name -- The string can have a '.', thus "Foo.baz", -- giving a dynamically-bound qualified name, -- in which case we want to generate a NameQ -- -- Parse the string to see if it has a "." in it -- so we know whether to generate a qualified or unqualified name -- It's a bit tricky because we need to parse -- -- > Foo.Baz.x as Qual Foo.Baz x -- -- So we parse it from back to front mkName str = split [] (reverse str) where split occ [] = Name (mkOccName occ) NameS split occ ('.':rev) | not (null occ) , is_rev_mod_name rev = Name (mkOccName occ) (NameQ (mkModName (reverse rev))) -- The 'not (null occ)' guard ensures that -- mkName "&." = Name "&." NameS -- The 'is_rev_mod' guards ensure that -- mkName ".&" = Name ".&" NameS -- mkName "^.." = Name "^.." NameS -- #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 n = mk_tup_name n DataName True tupleTypeName n = mk_tup_name n TcClsName True -- Unboxed tuple data and type constructors -- | Unboxed tuple data constructor unboxedTupleDataName :: Int -> Name -- | Unboxed tuple type constructor unboxedTupleTypeName :: Int -> Name unboxedTupleDataName n = mk_tup_name n DataName False unboxedTupleTypeName n = mk_tup_name n TcClsName False mk_tup_name :: Int -> NameSpace -> Bool -> Name mk_tup_name n space boxed = Name (mkOccName tup_occ) (NameG space (mkPkgName "ghc-prim") tup_mod) where withParens thing | boxed = "(" ++ thing ++ ")" | otherwise = "(#" ++ thing ++ "#)" tup_occ | n == 1 = if boxed then "Unit" else "Unit#" | otherwise = withParens (replicate n_commas ',') n_commas = n - 1 tup_mod = mkModName "GHC.Tuple" -- Unboxed sum data and type constructors -- | Unboxed sum data constructor unboxedSumDataName :: SumAlt -> SumArity -> Name -- | Unboxed sum type constructor unboxedSumTypeName :: SumArity -> Name unboxedSumDataName alt arity | alt > arity = error $ prefix ++ "Index out of bounds." ++ debug_info | alt <= 0 = error $ prefix ++ "Alt must be > 0." ++ debug_info | arity < 2 = error $ prefix ++ "Arity must be >= 2." ++ debug_info | otherwise = Name (mkOccName sum_occ) (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) where prefix = "unboxedSumDataName: " debug_info = " (alt: " ++ show alt ++ ", arity: " ++ show arity ++ ")" -- Synced with the definition of mkSumDataConOcc in TysWiredIn sum_occ = '(' : '#' : bars nbars_before ++ '_' : bars nbars_after ++ "#)" bars i = replicate i '|' nbars_before = alt - 1 nbars_after = arity - alt unboxedSumTypeName arity | arity < 2 = error $ "unboxedSumTypeName: Arity must be >= 2." ++ " (arity: " ++ show arity ++ ")" | otherwise = Name (mkOccName sum_occ) (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) where -- Synced with the definition of mkSumTyConOcc in TysWiredIn sum_occ = '(' : '#' : replicate (arity - 1) '|' ++ "#)" ----------------------------------------------------- -- Locations ----------------------------------------------------- data Loc = Loc { loc_filename :: String , loc_package :: String , loc_module :: String , loc_start :: CharPos , loc_end :: CharPos } deriving( Show, Eq, Ord, Data, Generic ) type CharPos = (Int, Int) -- ^ Line and character position ----------------------------------------------------- -- -- The Info returned by reification -- ----------------------------------------------------- -- | Obtained from 'reify' in the 'Q' Monad. data Info = -- | A class, with a list of its visible instances ClassI Dec [InstanceDec] -- | A class method | ClassOpI Name Type ParentName -- | A \"plain\" type constructor. \"Fancier\" type constructors are returned -- using 'PrimTyConI' or 'FamilyI' as appropriate. At present, this reified -- declaration will never have derived instances attached to it (if you wish -- to check for an instance, see 'reifyInstances'). | TyConI Dec -- | A type or data family, with a list of its visible instances. A closed -- type family is returned with 0 instances. | FamilyI Dec [InstanceDec] -- | A \"primitive\" type constructor, which can't be expressed with a 'Dec'. -- Examples: @(->)@, @Int#@. | PrimTyConI Name Arity Unlifted -- | A data constructor | DataConI Name Type ParentName -- | A pattern synonym | PatSynI Name PatSynType {- | A \"value\" variable (as opposed to a type variable, see 'TyVarI'). The @Maybe Dec@ field contains @Just@ the declaration which defined the variable - including the RHS of the declaration - or else @Nothing@, in the case where the RHS is unavailable to the compiler. At present, this value is /always/ @Nothing@: returning the RHS has not yet been implemented because of lack of interest. -} | VarI Name Type (Maybe Dec) {- | A type variable. The @Type@ field contains the type which underlies the variable. At present, this is always @'VarT' theName@, but future changes may permit refinement of this. -} | TyVarI -- Scoped type variable Name Type -- What it is bound to deriving( Show, Eq, Ord, Data, Generic ) -- | Obtained from 'reifyModule' in the 'Q' Monad. data ModuleInfo = -- | Contains the import list of the module. ModuleInfo [Module] deriving( Show, Eq, Ord, Data, Generic ) {- | In 'ClassOpI' and 'DataConI', name of the parent class or type -} type ParentName = Name -- | In 'UnboxedSumE' and 'UnboxedSumP', the number associated with a -- particular data constructor. 'SumAlt's are one-indexed and should never -- exceed the value of its corresponding 'SumArity'. For example: -- -- * @(\#_|\#)@ has 'SumAlt' 1 (out of a total 'SumArity' of 2) -- -- * @(\#|_\#)@ has 'SumAlt' 2 (out of a total 'SumArity' of 2) type SumAlt = Int -- | In 'UnboxedSumE', 'UnboxedSumT', and 'UnboxedSumP', the total number of -- 'SumAlt's. For example, @(\#|\#)@ has a 'SumArity' of 2. type SumArity = Int -- | In 'PrimTyConI', arity of the type constructor type Arity = Int -- | In 'PrimTyConI', is the type constructor unlifted? type Unlifted = Bool -- | 'InstanceDec' desribes a single instance of a class or type function. -- It is just a 'Dec', but guaranteed to be one of the following: -- -- * 'InstanceD' (with empty @['Dec']@) -- -- * 'DataInstD' or 'NewtypeInstD' (with empty derived @['Name']@) -- -- * 'TySynInstD' type InstanceDec = Dec data Fixity = Fixity Int FixityDirection deriving( Eq, Ord, Show, Data, Generic ) data FixityDirection = InfixL | InfixR | InfixN deriving( Eq, Ord, Show, Data, Generic ) -- | Highest allowed operator precedence for 'Fixity' constructor (answer: 9) maxPrecedence :: Int maxPrecedence = (9::Int) -- | Default fixity: @infixl 9@ defaultFixity :: Fixity defaultFixity = Fixity maxPrecedence InfixL {- Note [Unresolved infix] ~~~~~~~~~~~~~~~~~~~~~~~ -} {- $infix #infix# When implementing antiquotation for quasiquoters, one often wants to parse strings into expressions: > parse :: String -> Maybe Exp But how should we parse @a + b * c@? If we don't know the fixities of @+@ and @*@, we don't know whether to parse it as @a + (b * c)@ or @(a + b) * c@. In cases like this, use 'UInfixE', 'UInfixP', or 'UInfixT', which stand for \"unresolved infix expression/pattern/type\", respectively. When the compiler is given a splice containing a tree of @UInfixE@ applications such as > UInfixE > (UInfixE e1 op1 e2) > op2 > (UInfixE e3 op3 e4) it will look up and the fixities of the relevant operators and reassociate the tree as necessary. * trees will not be reassociated across 'ParensE', 'ParensP', or 'ParensT', which are of use for parsing expressions like > (a + b * c) + d * e * 'InfixE', 'InfixP', and 'InfixT' expressions are never reassociated. * The 'UInfixE' constructor doesn't support sections. Sections such as @(a *)@ have no ambiguity, so 'InfixE' suffices. For longer sections such as @(a + b * c -)@, use an 'InfixE' constructor for the outer-most section, and use 'UInfixE' constructors for all other operators: > InfixE > Just (UInfixE ...a + b * c...) > op > Nothing Sections such as @(a + b +)@ and @((a + b) +)@ should be rendered into 'Exp's differently: > (+ a + b) ---> InfixE Nothing + (Just $ UInfixE a + b) > -- will result in a fixity error if (+) is left-infix > (+ (a + b)) ---> InfixE Nothing + (Just $ ParensE $ UInfixE a + b) > -- no fixity errors * Quoted expressions such as > [| a * b + c |] :: Q Exp > [p| a : b : c |] :: Q Pat > [t| T + T |] :: Q Type will never contain 'UInfixE', 'UInfixP', 'UInfixT', 'InfixT', 'ParensE', 'ParensP', or 'ParensT' constructors. -} ----------------------------------------------------- -- -- The main syntax data types -- ----------------------------------------------------- data Lit = CharL Char | StringL String | IntegerL Integer -- ^ Used for overloaded and non-overloaded -- literals. We don't have a good way to -- represent non-overloaded literals at -- the moment. Maybe that doesn't matter? | RationalL Rational -- Ditto | IntPrimL Integer | WordPrimL Integer | FloatPrimL Rational | DoublePrimL Rational | StringPrimL [Word8] -- ^ A primitive C-style string, type 'Addr#' | BytesPrimL Bytes -- ^ Some raw bytes, 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 -- | Raw bytes embedded into the binary. -- -- Avoid using Bytes constructor directly as it is likely to change in the -- future. Use helpers such as `mkBytes` in Language.Haskell.TH.Lib instead. data Bytes = Bytes { bytesPtr :: ForeignPtr Word8 -- ^ Pointer to the data , bytesOffset :: Word -- ^ Offset from the pointer , bytesSize :: Word -- ^ Number of bytes -- Maybe someday: -- , bytesAlignement :: Word -- ^ Alignement constraint -- , bytesReadOnly :: Bool -- ^ Shall we embed into a read-only -- -- section or not -- , bytesInitialized :: Bool -- ^ False: only use `bytesSize` to allocate -- -- an uninitialized region } deriving (Eq,Ord,Data,Generic,Show) -- | 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 when a Name -- would suffice. Historically, Exp was used to make it easier to -- distinguish between infix constructors and non-constructors. -- This is a bit overkill, since one could just as well call -- `startsConId` or `startsConSym` (from `GHC.Lexeme`) on a Name. -- Unfortunately, changing this design now would involve lots of -- code churn for consumers of the TH API, so we continue to use -- an Exp as the operator and perform an extra check during conversion -- to ensure that the Exp is a constructor or a variable (#16895). | 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 [Maybe Exp] -- ^ @{ (e1,e2) } @ -- -- The 'Maybe' is necessary for handling -- tuple sections. -- -- > (1,) -- -- translates to -- -- > TupE [Just (LitE (IntegerL 1)),Nothing] | UnboxedTupE [Maybe Exp] -- ^ @{ (\# e1,e2 \#) } @ -- -- The 'Maybe' is necessary for handling -- tuple sections. -- -- > (# 'c', #) -- -- translates to -- -- > UnboxedTupE [Just (LitE (CharL 'c')),Nothing] | UnboxedSumE Exp SumAlt SumArity -- ^ @{ (\#|e|\#) }@ | CondE Exp Exp Exp -- ^ @{ if e1 then e2 else e3 }@ | MultiIfE [(Guard, Exp)] -- ^ @{ if | g1 -> e1 | g2 -> e2 }@ | LetE [Dec] Exp -- ^ @{ let { x=e1; y=e2 } in e3 }@ | CaseE Exp [Match] -- ^ @{ case e of m1; m2 }@ | DoE [Stmt] -- ^ @{ do { p <- e1; e2 } }@ | MDoE [Stmt] -- ^ @{ mdo { x <- e1 y; y <- e2 x; } }@ | CompE [Stmt] -- ^ @{ [ (x,y) | x <- xs, y <- ys ] }@ -- -- The result expression of the comprehension is -- the /last/ of the @'Stmt'@s, and should be a 'NoBindS'. -- -- E.g. translation: -- -- > [ f x | x <- xs ] -- -- > CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))] | ArithSeqE Range -- ^ @{ [ 1 ,2 .. 10 ] }@ | ListE [ Exp ] -- ^ @{ [1,2,3] }@ | SigE Exp Type -- ^ @{ e :: t }@ | RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@ | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@ | StaticE Exp -- ^ @{ static e }@ | UnboundVarE Name -- ^ @{ _x }@ -- -- This is used for holes or unresolved -- identifiers in AST quotes. Note that -- it could either have a variable name -- or constructor name. | LabelE String -- ^ @{ #x }@ ( Overloaded label ) | ImplicitParamVarE String -- ^ @{ ?x }@ ( Implicit parameter ) deriving( Show, Eq, Ord, Data, Generic ) type FieldExp = (Name,Exp) -- Omitted: implicit parameters data Body = GuardedB [(Guard,Exp)] -- ^ @f p { | e1 = e2 -- | e3 = e4 } -- where ds@ | NormalB Exp -- ^ @f p { = e } where ds@ deriving( Show, Eq, Ord, Data, Generic ) data Guard = NormalG Exp -- ^ @f x { | odd x } = x@ | PatG [Stmt] -- ^ @f x { | Just y <- x, Just z <- y } = z@ deriving( Show, Eq, Ord, Data, Generic ) data Stmt = BindS Pat Exp -- ^ @p <- e@ | LetS [ Dec ] -- ^ @{ let { x=e1; y=e2 } }@ | NoBindS Exp -- ^ @e@ | ParS [[Stmt]] -- ^ @x <- e1 | s2, s3 | s4@ (in 'CompE') | RecS [Stmt] -- ^ @rec { s1; s2 }@ deriving( Show, Eq, Ord, Data, Generic ) data Range = FromR Exp | FromThenR Exp Exp | FromToR Exp Exp | FromThenToR Exp Exp Exp deriving( Show, Eq, Ord, Data, Generic ) data Dec = FunD Name [Clause] -- ^ @{ f p1 p2 = b where decs }@ | ValD Pat Body [Dec] -- ^ @{ p = b where decs }@ | DataD Cxt Name [TyVarBndr] (Maybe Kind) -- Kind signature (allowed only for GADTs) [Con] [DerivClause] -- ^ @{ data Cxt x => T x = A x | B (T x) -- deriving (Z,W) -- deriving stock Eq }@ | NewtypeD Cxt Name [TyVarBndr] (Maybe Kind) -- Kind signature Con [DerivClause] -- ^ @{ newtype Cxt x => T x = A (B x) -- deriving (Z,W Q) -- deriving stock Eq }@ | TySynD Name [TyVarBndr] Type -- ^ @{ type T x = (x,x) }@ | ClassD Cxt Name [TyVarBndr] [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@ | InstanceD (Maybe Overlap) Cxt Type [Dec] -- ^ @{ instance {\-\# OVERLAPS \#-\} -- Show w => Show [w] where ds }@ | SigD Name Type -- ^ @{ length :: [a] -> Int }@ | KiSigD Name Kind -- ^ @{ type TypeRep :: k -> Type }@ | ForeignD Foreign -- ^ @{ foreign import ... } --{ foreign export ... }@ | InfixD Fixity Name -- ^ @{ infix 3 foo }@ -- | pragmas | PragmaD Pragma -- ^ @{ {\-\# INLINE [1] foo \#-\} }@ -- | data families (may also appear in [Dec] of 'ClassD' and 'InstanceD') | DataFamilyD Name [TyVarBndr] (Maybe Kind) -- ^ @{ data family T a b c :: * }@ | DataInstD Cxt (Maybe [TyVarBndr]) Type (Maybe Kind) -- Kind signature [Con] [DerivClause] -- ^ @{ data instance Cxt x => T [x] -- = A x | B (T x) -- deriving (Z,W) -- deriving stock Eq }@ | NewtypeInstD Cxt (Maybe [TyVarBndr]) Type -- Quantified type vars (Maybe Kind) -- Kind signature Con [DerivClause] -- ^ @{ newtype instance Cxt x => T [x] -- = A (B x) -- deriving (Z,W) -- deriving stock Eq }@ | TySynInstD TySynEqn -- ^ @{ type instance ... }@ -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD') | OpenTypeFamilyD TypeFamilyHead -- ^ @{ type family T a b c = (r :: *) | r -> a b }@ | ClosedTypeFamilyD TypeFamilyHead [TySynEqn] -- ^ @{ type family F a b = (r :: *) | r -> a where ... }@ | RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@ | StandaloneDerivD (Maybe DerivStrategy) Cxt Type -- ^ @{ deriving stock instance Ord a => Ord (Foo a) }@ | DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@ -- | Pattern Synonyms | PatSynD Name PatSynArgs PatSynDir Pat -- ^ @{ pattern P v1 v2 .. vn <- p }@ unidirectional or -- @{ pattern P v1 v2 .. vn = p }@ implicit bidirectional or -- @{ pattern P v1 v2 .. vn <- p -- where P v1 v2 .. vn = e }@ explicit bidirectional -- -- also, besides prefix pattern synonyms, both infix and record -- pattern synonyms are supported. See 'PatSynArgs' for details | PatSynSigD Name PatSynType -- ^ A pattern synonym's type signature. | ImplicitParamBindD String Exp -- ^ @{ ?x = expr }@ -- -- Implicit parameter binding declaration. Can only be used in let -- and where clauses which consist entirely of implicit bindings. deriving( Show, Eq, Ord, Data, Generic ) -- | Varieties of allowed instance overlap. data Overlap = Overlappable -- ^ May be overlapped by more specific instances | Overlapping -- ^ May overlap a more general instance | Overlaps -- ^ Both 'Overlapping' and 'Overlappable' | Incoherent -- ^ Both 'Overlappable' and 'Overlappable', and -- pick an arbitrary one if multiple choices are -- available. deriving( Show, Eq, Ord, Data, Generic ) -- | A single @deriving@ clause at the end of a datatype. data DerivClause = DerivClause (Maybe DerivStrategy) Cxt -- ^ @{ deriving stock (Eq, Ord) }@ deriving( Show, Eq, Ord, Data, Generic ) -- | What the user explicitly requests when deriving an instance. data DerivStrategy = StockStrategy -- ^ A \"standard\" derived instance | AnyclassStrategy -- ^ @-XDeriveAnyClass@ | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ | ViaStrategy Type -- ^ @-XDerivingVia@ deriving( Show, Eq, Ord, Data, Generic ) -- | A pattern synonym's type. Note that a pattern synonym's /fully/ -- specified type has a peculiar shape coming with two forall -- quantifiers and two constraint contexts. For example, consider the -- pattern synonym -- -- > pattern P x1 x2 ... xn = -- -- P's complete type is of the following form -- -- > pattern P :: forall universals. required constraints -- > => forall existentials. provided constraints -- > => t1 -> t2 -> ... -> tn -> t -- -- consisting of four parts: -- -- 1. the (possibly empty lists of) universally quantified type -- variables and required constraints on them. -- 2. the (possibly empty lists of) existentially quantified -- type variables and the provided constraints on them. -- 3. the types @t1@, @t2@, .., @tn@ of @x1@, @x2@, .., @xn@, respectively -- 4. the type @t@ of @\@, mentioning only universals. -- -- Pattern synonym types interact with TH when (a) reifying a pattern -- synonym, (b) pretty printing, or (c) specifying a pattern synonym's -- type signature explicitly: -- -- * Reification always returns a pattern synonym's /fully/ specified -- type in abstract syntax. -- -- * Pretty printing via 'Language.Haskell.TH.Ppr.pprPatSynType' abbreviates -- a pattern synonym's type unambiguously in concrete syntax: The rule of -- thumb is to print initial empty universals and the required -- context as @() =>@, if existentials and a provided context -- follow. If only universals and their required context, but no -- existentials are specified, only the universals and their -- required context are printed. If both or none are specified, so -- both (or none) are printed. -- -- * When specifying a pattern synonym's type explicitly with -- 'PatSynSigD' either one of the universals, the existentials, or -- their contexts may be left empty. -- -- See the GHC user's guide for more information on pattern synonyms -- and their types: -- . type PatSynType = Type -- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'. By -- analogy with "head" for type classes and type class instances as -- defined in /Type classes: an exploration of the design space/, the -- @TypeFamilyHead@ is defined to be the elements of the declaration -- between @type family@ and @where@. data TypeFamilyHead = TypeFamilyHead Name [TyVarBndr] FamilyResultSig (Maybe InjectivityAnn) deriving( Show, Eq, Ord, Data, Generic ) -- | One equation of a type family instance or closed type family. The -- arguments are the left-hand-side type and the right-hand-side result. -- -- For instance, if you had the following type family: -- -- @ -- type family Foo (a :: k) :: k where -- forall k (a :: k). Foo \@k a = a -- @ -- -- The @Foo \@k a = a@ equation would be represented as follows: -- -- @ -- 'TySynEqn' ('Just' ['PlainTV' k, 'KindedTV' a ('VarT' k)]) -- ('AppT' ('AppKindT' ('ConT' ''Foo) ('VarT' k)) ('VarT' a)) -- ('VarT' a) -- @ data TySynEqn = TySynEqn (Maybe [TyVarBndr]) Type Type deriving( Show, Eq, Ord, Data, Generic ) data FunDep = FunDep [Name] [Name] deriving( Show, Eq, Ord, Data, Generic ) data Foreign = ImportF Callconv Safety String Name Type | ExportF Callconv String Name Type deriving( Show, Eq, Ord, Data, Generic ) -- keep Callconv in sync with module ForeignCall in ghc/compiler/prelude/ForeignCall.hs data Callconv = CCall | StdCall | CApi | Prim | JavaScript deriving( Show, Eq, Ord, Data, Generic ) data Safety = Unsafe | Safe | Interruptible deriving( Show, Eq, Ord, Data, Generic ) data Pragma = InlineP Name Inline RuleMatch Phases | SpecialiseP Name Type (Maybe Inline) Phases | SpecialiseInstP Type | RuleP String (Maybe [TyVarBndr]) [RuleBndr] Exp Exp Phases | AnnP AnnTarget Exp | LineP Int String | CompleteP [Name] (Maybe Name) -- ^ @{ {\-\# COMPLETE C_1, ..., C_i [ :: T ] \#-} }@ deriving( Show, Eq, Ord, Data, Generic ) data Inline = NoInline | Inline | Inlinable deriving (Show, Eq, Ord, Data, Generic) data RuleMatch = ConLike | FunLike deriving (Show, Eq, Ord, Data, Generic) data Phases = AllPhases | FromPhase Int | BeforePhase Int deriving (Show, Eq, Ord, Data, Generic) data RuleBndr = RuleVar Name | TypedRuleVar Name Type deriving (Show, Eq, Ord, Data, Generic) data AnnTarget = ModuleAnnotation | TypeAnnotation Name | ValueAnnotation Name deriving (Show, Eq, Ord, Data, Generic) type Cxt = [Pred] -- ^ @(Eq a, Ord b)@ -- | Since the advent of @ConstraintKinds@, constraints are really just types. -- Equality constraints use the 'EqualityT' constructor. Constraints may also -- be tuples of other constraints. type Pred = Type data SourceUnpackedness = NoSourceUnpackedness -- ^ @C a@ | SourceNoUnpack -- ^ @C { {\-\# NOUNPACK \#-\} } a@ | SourceUnpack -- ^ @C { {\-\# UNPACK \#-\} } a@ deriving (Show, Eq, Ord, Data, Generic) data SourceStrictness = NoSourceStrictness -- ^ @C a@ | SourceLazy -- ^ @C {~}a@ | SourceStrict -- ^ @C {!}a@ deriving (Show, Eq, Ord, Data, Generic) -- | Unlike 'SourceStrictness' and 'SourceUnpackedness', 'DecidedStrictness' -- refers to the strictness that the compiler chooses for a data constructor -- field, which may be different from what is written in source code. See -- 'reifyConStrictness' for more information. data DecidedStrictness = DecidedLazy | DecidedStrict | DecidedUnpack deriving (Show, Eq, Ord, Data, Generic) -- | A single data constructor. -- -- The constructors for 'Con' can roughly be divided up into two categories: -- those for constructors with \"vanilla\" syntax ('NormalC', 'RecC', and -- 'InfixC'), and those for constructors with GADT syntax ('GadtC' and -- 'RecGadtC'). The 'ForallC' constructor, which quantifies additional type -- variables and class contexts, can surround either variety of constructor. -- However, the type variables that it quantifies are different depending -- on what constructor syntax is used: -- -- * If a 'ForallC' surrounds a constructor with vanilla syntax, then the -- 'ForallC' will only quantify /existential/ type variables. For example: -- -- @ -- data Foo a = forall b. MkFoo a b -- @ -- -- In @MkFoo@, 'ForallC' will quantify @b@, but not @a@. -- -- * If a 'ForallC' surrounds a constructor with GADT syntax, then the -- 'ForallC' will quantify /all/ type variables used in the constructor. -- For example: -- -- @ -- data Bar a b where -- MkBar :: (a ~ b) => c -> MkBar a b -- @ -- -- In @MkBar@, 'ForallC' will quantify @a@, @b@, and @c@. data Con = NormalC Name [BangType] -- ^ @C Int a@ | RecC Name [VarBangType] -- ^ @C { v :: Int, w :: a }@ | InfixC BangType Name BangType -- ^ @Int :+ a@ | ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@ | GadtC [Name] [BangType] Type -- See Note [GADT return type] -- ^ @C :: a -> b -> T b Int@ | RecGadtC [Name] [VarBangType] Type -- See Note [GADT return type] -- ^ @C :: { v :: Int } -> T b Int@ deriving (Show, Eq, Ord, Data, Generic) -- Note [GADT return type] -- ~~~~~~~~~~~~~~~~~~~~~~~ -- -- The return type of a GADT constructor does not necessarily match the name of -- the data type: -- -- type S = T -- -- data T a where -- MkT :: S Int -- -- -- type S a = T -- -- data T a where -- MkT :: S Char Int -- -- -- type Id a = a -- type S a = T -- -- data T a where -- MkT :: Id (S Char Int) -- -- -- That is why we allow the return type stored by a constructor to be an -- arbitrary type. See also #11341 data Bang = Bang SourceUnpackedness SourceStrictness -- ^ @C { {\-\# UNPACK \#-\} !}a@ deriving (Show, Eq, Ord, Data, Generic) type BangType = (Bang, Type) type VarBangType = (Name, Bang, Type) -- | As of @template-haskell-2.11.0.0@, 'Strict' has been replaced by 'Bang'. type Strict = Bang -- | As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by -- 'BangType'. type StrictType = BangType -- | As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by -- 'VarBangType'. type VarStrictType = VarBangType -- | A pattern synonym's directionality. data PatSynDir = Unidir -- ^ @pattern P x {<-} p@ | ImplBidir -- ^ @pattern P x {=} p@ | ExplBidir [Clause] -- ^ @pattern P x {<-} p where P x = e@ deriving( Show, Eq, Ord, Data, Generic ) -- | A pattern synonym's argument type. data PatSynArgs = PrefixPatSyn [Name] -- ^ @pattern P {x y z} = p@ | InfixPatSyn Name Name -- ^ @pattern {x P y} = p@ | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@ deriving( Show, Eq, Ord, Data, Generic ) data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \. \ => \@ | ForallVisT [TyVarBndr] Type -- ^ @forall \ -> \@ | AppT Type Type -- ^ @T a b@ | AppKindT Type Kind -- ^ @T \@k t@ | SigT Type Kind -- ^ @t :: k@ | VarT Name -- ^ @a@ | ConT Name -- ^ @T@ | PromotedT Name -- ^ @'T@ | InfixT Type Name Type -- ^ @T + T@ | UInfixT Type Name Type -- ^ @T + T@ -- -- See "Language.Haskell.TH.Syntax#infix" | ParensT Type -- ^ @(T)@ -- See Note [Representing concrete syntax in types] | TupleT Int -- ^ @(,), (,,), etc.@ | UnboxedTupleT Int -- ^ @(\#,\#), (\#,,\#), etc.@ | UnboxedSumT SumArity -- ^ @(\#|\#), (\#||\#), etc.@ | ArrowT -- ^ @->@ | EqualityT -- ^ @~@ | ListT -- ^ @[]@ | PromotedTupleT Int -- ^ @'(), '(,), '(,,), etc.@ | PromotedNilT -- ^ @'[]@ | PromotedConsT -- ^ @(':)@ | StarT -- ^ @*@ | ConstraintT -- ^ @Constraint@ | LitT TyLit -- ^ @0,1,2, etc.@ | WildCardT -- ^ @_@ | ImplicitParamT String Type -- ^ @?x :: t@ deriving( Show, Eq, Ord, Data, Generic ) data TyVarBndr = PlainTV Name -- ^ @a@ | KindedTV Name Kind -- ^ @(a :: k)@ deriving( Show, Eq, Ord, Data, Generic ) -- | Type family result signature data FamilyResultSig = NoSig -- ^ no signature | KindSig Kind -- ^ @k@ | TyVarSig TyVarBndr -- ^ @= r, = (r :: k)@ deriving( Show, Eq, Ord, Data, Generic ) -- | Injectivity annotation data InjectivityAnn = InjectivityAnn Name [Name] deriving ( Show, Eq, Ord, Data, Generic ) data TyLit = NumTyLit Integer -- ^ @2@ | StrTyLit String -- ^ @\"Hello\"@ deriving ( Show, Eq, Ord, Data, Generic ) -- | Role annotations data Role = NominalR -- ^ @nominal@ | RepresentationalR -- ^ @representational@ | PhantomR -- ^ @phantom@ | InferR -- ^ @_@ deriving( Show, Eq, Ord, Data, Generic ) -- | Annotation target for reifyAnnotations data AnnLookup = AnnLookupModule Module | AnnLookupName Name deriving( Show, Eq, Ord, Data, Generic ) -- | To avoid duplication between kinds and types, they -- are defined to be the same. Naturally, you would never -- have a type be 'StarT' and you would never have a kind -- be 'SigT', but many of the other constructors are shared. -- Note that the kind @Bool@ is denoted with 'ConT', not -- 'PromotedT'. Similarly, tuple kinds are made with 'TupleT', -- not 'PromotedTupleT'. type Kind = Type {- Note [Representing concrete syntax in types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Haskell has a rich concrete syntax for types, including t1 -> t2, (t1,t2), [t], and so on In TH we represent all of this using AppT, with a distinguished type constructor at the head. So, Type TH representation ----------------------------------------------- t1 -> t2 ArrowT `AppT` t2 `AppT` t2 [t] ListT `AppT` t (t1,t2) TupleT 2 `AppT` t1 `AppT` t2 '(t1,t2) PromotedTupleT 2 `AppT` t1 `AppT` t2 But if the original HsSyn used prefix application, we won't use these special TH constructors. For example [] t ConT "[]" `AppT` t (->) t ConT "->" `AppT` t In this way we can faithfully represent in TH whether the original HsType used concrete syntax or not. The one case that doesn't fit this pattern is that of promoted lists '[ Maybe, IO ] PromotedListT 2 `AppT` t1 `AppT` t2 but it's very smelly because there really is no type constructor corresponding to PromotedListT. So we encode HsExplicitListTy with PromotedConsT and PromotedNilT (which *do* have underlying type constructors): '[ Maybe, IO ] PromotedConsT `AppT` Maybe `AppT` (PromotedConsT `AppT` IO `AppT` PromotedNilT) -} ----------------------------------------------------- -- Internal helper functions ----------------------------------------------------- cmpEq :: Ordering -> Bool cmpEq EQ = True cmpEq _ = False thenCmp :: Ordering -> Ordering -> Ordering thenCmp EQ o2 = o2 thenCmp o1 _ = o1 ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/Lexeme.hs0000644000000000000000000002065713713635744021213 0ustar0000000000000000-- (c) The GHC Team -- -- Functions to evaluate whether or not a string is a valid identifier. -- There is considerable overlap between the logic here and the logic -- in Lexer.x, but sadly there seems to be no way to merge them. module Lexeme ( -- * Lexical characteristics of Haskell names -- | Use these functions to figure what kind of name a 'FastString' -- represents; these functions do /not/ check that the identifier -- is valid. isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym, startsVarSym, startsVarId, startsConSym, startsConId, -- * Validating identifiers -- | These functions (working over plain old 'String's) check -- to make sure that the identifier is valid. okVarOcc, okConOcc, okTcOcc, okVarIdOcc, okVarSymOcc, okConIdOcc, okConSymOcc -- Some of the exports above are not used within GHC, but may -- be of value to GHC API users. ) where import GhcPrelude import FastString import Data.Char import qualified Data.Set as Set import GHC.Lexeme {- ************************************************************************ * * Lexical categories * * ************************************************************************ These functions test strings to see if they fit the lexical categories defined in the Haskell report. Note [Classification of generated names] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some names generated for internal use can show up in debugging output, e.g. when using -ddump-simpl. These generated names start with a $ but should still be pretty-printed using prefix notation. We make sure this is the case in isLexVarSym by only classifying a name as a symbol if all its characters are symbols, not just its first one. -} isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool isLexCon cs = isLexConId cs || isLexConSym cs isLexVar cs = isLexVarId cs || isLexVarSym cs isLexId cs = isLexConId cs || isLexVarId cs isLexSym cs = isLexConSym cs || isLexVarSym cs ------------- isLexConId cs -- Prefix type or data constructors | nullFS cs = False -- e.g. "Foo", "[]", "(,)" | cs == (fsLit "[]") = True | otherwise = startsConId (headFS cs) isLexVarId cs -- Ordinary prefix identifiers | nullFS cs = False -- e.g. "x", "_x" | otherwise = startsVarId (headFS cs) isLexConSym cs -- Infix type or data constructors | nullFS cs = False -- e.g. ":-:", ":", "->" | cs == (fsLit "->") = True | otherwise = startsConSym (headFS cs) isLexVarSym fs -- Infix identifiers e.g. "+" | fs == (fsLit "~R#") = True | otherwise = case (if nullFS fs then [] else unpackFS fs) of [] -> False (c:cs) -> startsVarSym c && all isVarSymChar cs -- See Note [Classification of generated names] {- ************************************************************************ * * Detecting valid names for Template Haskell * * ************************************************************************ -} ---------------------- -- External interface ---------------------- -- | Is this an acceptable variable name? okVarOcc :: String -> Bool okVarOcc str@(c:_) | startsVarId c = okVarIdOcc str | startsVarSym c = okVarSymOcc str okVarOcc _ = False -- | Is this an acceptable constructor name? okConOcc :: String -> Bool okConOcc str@(c:_) | startsConId c = okConIdOcc str | startsConSym c = okConSymOcc str | str == "[]" = True okConOcc _ = False -- | Is this an acceptable type name? okTcOcc :: String -> Bool okTcOcc "[]" = True okTcOcc "->" = True okTcOcc "~" = True okTcOcc str@(c:_) | startsConId c = okConIdOcc str | startsConSym c = okConSymOcc str | startsVarSym c = okVarSymOcc str okTcOcc _ = False -- | Is this an acceptable alphanumeric variable name, assuming it starts -- with an acceptable letter? okVarIdOcc :: String -> Bool okVarIdOcc str = okIdOcc str && -- admit "_" as a valid identifier. Required to support typed -- holes in Template Haskell. See #10267 (str == "_" || not (str `Set.member` reservedIds)) -- | Is this an acceptable symbolic variable name, assuming it starts -- with an acceptable character? okVarSymOcc :: String -> Bool okVarSymOcc str = all okSymChar str && not (str `Set.member` reservedOps) && not (isDashes str) -- | Is this an acceptable alphanumeric constructor name, assuming it -- starts with an acceptable letter? okConIdOcc :: String -> Bool okConIdOcc str = okIdOcc str || is_tuple_name1 True str || -- Is it a boxed tuple... is_tuple_name1 False str || -- ...or an unboxed tuple (#12407)... is_sum_name1 str -- ...or an unboxed sum (#12514)? where -- check for tuple name, starting at the beginning is_tuple_name1 True ('(' : rest) = is_tuple_name2 True rest is_tuple_name1 False ('(' : '#' : rest) = is_tuple_name2 False rest is_tuple_name1 _ _ = False -- check for tuple tail is_tuple_name2 True ")" = True is_tuple_name2 False "#)" = True is_tuple_name2 boxed (',' : rest) = is_tuple_name2 boxed rest is_tuple_name2 boxed (ws : rest) | isSpace ws = is_tuple_name2 boxed rest is_tuple_name2 _ _ = False -- check for sum name, starting at the beginning is_sum_name1 ('(' : '#' : rest) = is_sum_name2 False rest is_sum_name1 _ = False -- check for sum tail, only allowing at most one underscore is_sum_name2 _ "#)" = True is_sum_name2 underscore ('|' : rest) = is_sum_name2 underscore rest is_sum_name2 False ('_' : rest) = is_sum_name2 True rest is_sum_name2 underscore (ws : rest) | isSpace ws = is_sum_name2 underscore rest is_sum_name2 _ _ = False -- | Is this an acceptable symbolic constructor name, assuming it -- starts with an acceptable character? okConSymOcc :: String -> Bool okConSymOcc ":" = True okConSymOcc str = all okSymChar str && not (str `Set.member` reservedOps) ---------------------- -- Internal functions ---------------------- -- | Is this string an acceptable id, possibly with a suffix of hashes, -- but not worrying about case or clashing with reserved words? okIdOcc :: String -> Bool okIdOcc str = let hashes = dropWhile okIdChar str in all (== '#') hashes -- -XMagicHash allows a suffix of hashes -- of course, `all` says "True" to an empty list -- | Is this character acceptable in an identifier (after the first letter)? -- See alexGetByte in Lexer.x okIdChar :: Char -> Bool okIdChar c = case generalCategory c of UppercaseLetter -> True LowercaseLetter -> True TitlecaseLetter -> True ModifierLetter -> True -- See #10196 OtherLetter -> True -- See #1103 NonSpacingMark -> True -- See #7650 DecimalNumber -> True OtherNumber -> True -- See #4373 _ -> c == '\'' || c == '_' -- | All reserved identifiers. Taken from section 2.4 of the 2010 Report. reservedIds :: Set.Set String reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving" , "do", "else", "foreign", "if", "import", "in" , "infix", "infixl", "infixr", "instance", "let" , "module", "newtype", "of", "then", "type", "where" , "_" ] -- | All reserved operators. Taken from section 2.4 of the 2010 Report. reservedOps :: Set.Set String reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->" , "@", "~", "=>" ] -- | Does this string contain only dashes and has at least 2 of them? isDashes :: String -> Bool isDashes ('-' : '-' : rest) = all (== '-') rest isDashes _ = False ghc-lib-parser-8.10.2.20200808/compiler/ghci/LinkerTypes.hs0000644000000000000000000001027513713635745021045 0ustar0000000000000000----------------------------------------------------------------------------- -- -- Types for the Dynamic Linker -- -- (c) The University of Glasgow 2019 -- ----------------------------------------------------------------------------- module LinkerTypes ( DynLinker(..), PersistentLinkerState(..), LinkerUnitId, Linkable(..), Unlinked(..), SptEntry(..) ) where import GhcPrelude ( FilePath, String, show ) import Data.Time ( UTCTime ) import Data.Maybe ( Maybe ) import Control.Concurrent.MVar ( MVar ) import Module ( InstalledUnitId, Module ) import ByteCodeTypes ( ItblEnv, CompiledByteCode ) import Outputable import Var ( Id ) import GHC.Fingerprint.Type ( Fingerprint ) import NameEnv ( NameEnv ) import Name ( Name ) import GHCi.RemoteTypes ( ForeignHValue ) type ClosureEnv = NameEnv (Name, ForeignHValue) newtype DynLinker = DynLinker { dl_mpls :: MVar (Maybe PersistentLinkerState) } data PersistentLinkerState = PersistentLinkerState { -- Current global mapping from Names to their true values closure_env :: ClosureEnv, -- The current global mapping from RdrNames of DataCons to -- info table addresses. -- When a new Unlinked is linked into the running image, or an existing -- module in the image is replaced, the itbl_env must be updated -- appropriately. itbl_env :: !ItblEnv, -- The currently loaded interpreted modules (home package) bcos_loaded :: ![Linkable], -- And the currently-loaded compiled modules (home package) objs_loaded :: ![Linkable], -- The currently-loaded packages; always object code -- Held, as usual, in dependency order; though I am not sure if -- that is really important pkgs_loaded :: ![LinkerUnitId], -- we need to remember the name of previous temporary DLL/.so -- libraries so we can link them (see #10322) temp_sos :: ![(FilePath, String)] } -- TODO: Make this type more precise type LinkerUnitId = InstalledUnitId -- | Information we can use to dynamically link modules into the compiler data Linkable = LM { linkableTime :: UTCTime, -- ^ Time at which this linkable was built -- (i.e. when the bytecodes were produced, -- or the mod date on the files) linkableModule :: Module, -- ^ The linkable module itself linkableUnlinked :: [Unlinked] -- ^ Those files and chunks of code we have yet to link. -- -- INVARIANT: A valid linkable always has at least one 'Unlinked' item. -- If this list is empty, the Linkable represents a fake linkable, which -- is generated in HscNothing mode to avoid recompiling modules. -- -- ToDo: Do items get removed from this list when they get linked? } instance Outputable Linkable where ppr (LM when_made mod unlinkeds) = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) $$ nest 3 (ppr unlinkeds) -- | Objects which have yet to be linked by the compiler data Unlinked = DotO FilePath -- ^ An object file (.o) | DotA FilePath -- ^ Static archive file (.a) | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) | BCOs CompiledByteCode [SptEntry] -- ^ A byte-code object, lives only in memory. Also -- carries some static pointer table entries which -- should be loaded along with the BCOs. -- See Note [Grant plan for static forms] in -- StaticPtrTable. instance Outputable Unlinked where ppr (DotO path) = text "DotO" <+> text path ppr (DotA path) = text "DotA" <+> text path ppr (DotDLL path) = text "DotDLL" <+> text path ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt -- | An entry to be inserted into a module's static pointer table. -- See Note [Grand plan for static forms] in StaticPtrTable. data SptEntry = SptEntry Id Fingerprint instance Outputable SptEntry where ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr ghc-lib-parser-8.10.2.20200808/compiler/utils/ListSetOps.hs0000644000000000000000000001442113713635745021070 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[ListSetOps]{Set-like operations on lists} -} {-# LANGUAGE CPP #-} module ListSetOps ( unionLists, minusList, deleteBys, -- Association lists Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, -- Duplicate handling hasNoDups, removeDups, findDupsEq, equivClasses, -- Indexing getNth ) where #include "GhclibHsVersions.h" import GhcPrelude import Outputable import Util import qualified Data.List as L import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Set as S getNth :: Outputable a => [a] -> Int -> a getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs ) xs !! n deleteBys :: (a -> a -> Bool) -> [a] -> [a] -> [a] -- (deleteBys eq xs ys) returns xs-ys, using the given equality function -- Just like 'Data.List.delete' but with an equality function deleteBys eq xs ys = foldl' (flip (L.deleteBy eq)) xs ys {- ************************************************************************ * * Treating lists as sets Assumes the lists contain no duplicates, but are unordered * * ************************************************************************ -} -- | Assumes that the arguments contain no duplicates unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a] -- We special case some reasonable common patterns. unionLists xs [] = xs unionLists [] ys = ys unionLists [x] ys | isIn "unionLists" x ys = ys | otherwise = x:ys unionLists xs [y] | isIn "unionLists" y xs = xs | otherwise = y:xs unionLists xs ys = WARN(lengthExceeds xs 100 || lengthExceeds ys 100, ppr xs $$ ppr ys) [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys -- | Calculate the set difference of two lists. This is -- /O((m + n) log n)/, where we subtract a list of /n/ elements -- from a list of /m/ elements. -- -- Extremely short cases are handled specially: -- When /m/ or /n/ is 0, this takes /O(1)/ time. When /m/ is 1, -- it takes /O(n)/ time. minusList :: Ord a => [a] -> [a] -> [a] -- There's no point building a set to perform just one lookup, so we handle -- extremely short lists specially. It might actually be better to use -- an O(m*n) algorithm when m is a little longer (perhaps up to 4 or even 5). -- The tipping point will be somewhere in the area of where /m/ and /log n/ -- become comparable, but we probably don't want to work too hard on this. minusList [] _ = [] minusList xs@[x] ys | x `elem` ys = [] | otherwise = xs -- Using an empty set or a singleton would also be silly, so let's not. minusList xs [] = xs minusList xs [y] = filter (/= y) xs -- When each list has at least two elements, we build a set from the -- second argument, allowing us to filter the first argument fairly -- efficiently. minusList xs ys = filter (`S.notMember` yss) xs where yss = S.fromList ys {- ************************************************************************ * * \subsection[Utils-assoc]{Association lists} * * ************************************************************************ Inefficient finite maps based on association lists and equality. -} -- A finite mapping based on equality and association lists type Assoc a b = [(a,b)] assoc :: (Eq a) => String -> Assoc a b -> a -> b assocDefault :: (Eq a) => b -> Assoc a b -> a -> b assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b assocDefaultUsing _ deflt [] _ = deflt assocDefaultUsing eq deflt ((k,v) : rest) key | k `eq` key = v | otherwise = assocDefaultUsing eq deflt rest key assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key assocDefault deflt list key = assocDefaultUsing (==) deflt list key assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key assocMaybe alist key = lookup alist where lookup [] = Nothing lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest {- ************************************************************************ * * \subsection[Utils-dups]{Duplicate-handling} * * ************************************************************************ -} hasNoDups :: (Eq a) => [a] -> Bool hasNoDups xs = f [] xs where f _ [] = True f seen_so_far (x:xs) = if x `is_elem` seen_so_far then False else f (x:seen_so_far) xs is_elem = isIn "hasNoDups" equivClasses :: (a -> a -> Ordering) -- Comparison -> [a] -> [NonEmpty a] equivClasses _ [] = [] equivClasses _ [stuff] = [stuff :| []] equivClasses cmp items = NE.groupBy eq (L.sortBy cmp items) where eq a b = case cmp a b of { EQ -> True; _ -> False } removeDups :: (a -> a -> Ordering) -- Comparison function -> [a] -> ([a], -- List with no duplicates [NonEmpty a]) -- List of duplicate groups. One representative -- from each group appears in the first result removeDups _ [] = ([], []) removeDups _ [x] = ([x],[]) removeDups cmp xs = case L.mapAccumR collect_dups [] (equivClasses cmp xs) of { (dups, xs') -> (xs', dups) } where collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a) collect_dups dups_so_far (x :| []) = (dups_so_far, x) collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x) findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a] findDupsEq _ [] = [] findDupsEq eq (x:xs) | L.null eq_xs = findDupsEq eq xs | otherwise = (x :| eq_xs) : findDupsEq eq neq_xs where (eq_xs, neq_xs) = L.partition (eq x) xs ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/Literal.hs0000644000000000000000000007704313713635744021371 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1998 \section[Literal]{@Literal@: literals} -} {-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} module Literal ( -- * Main data type Literal(..) -- Exported to ParseIface , LitNumType(..) -- ** Creating Literals , mkLitInt, mkLitIntWrap, mkLitIntWrapC , mkLitWord, mkLitWordWrap, mkLitWordWrapC , mkLitInt64, mkLitInt64Wrap , mkLitWord64, mkLitWord64Wrap , mkLitFloat, mkLitDouble , mkLitChar, mkLitString , mkLitInteger, mkLitNatural , mkLitNumber, mkLitNumberWrap -- ** Operations on Literals , literalType , absentLiteralOf , pprLiteral , litNumIsSigned , litNumCheckRange -- ** Predicates on Literals and their contents , litIsDupable, litIsTrivial, litIsLifted , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange , isZeroLit , litFitsInChar , litValue, isLitValue, isLitValue_maybe, mapLitValue -- ** Coercions , word2IntLit, int2WordLit , narrowLit , narrow8IntLit, narrow16IntLit, narrow32IntLit , narrow8WordLit, narrow16WordLit, narrow32WordLit , char2IntLit, int2CharLit , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit ) where #include "GhclibHsVersions.h" import GhcPrelude import TysPrim import PrelNames import Type import TyCon import Outputable import FastString import BasicTypes import Binary import Constants import DynFlags import GHC.Platform import UniqFM import Util import Data.ByteString (ByteString) import Data.Int import Data.Word import Data.Char import Data.Maybe ( isJust ) import Data.Data ( Data ) import Data.Proxy import Numeric ( fromRat ) {- ************************************************************************ * * \subsection{Literals} * * ************************************************************************ -} -- | So-called 'Literal's are one of: -- -- * An unboxed numeric literal or floating-point literal which is presumed -- to be surrounded by appropriate constructors (@Int#@, etc.), so that -- the overall thing makes sense. -- -- We maintain the invariant that the 'Integer' in the 'LitNumber' -- constructor is actually in the (possibly target-dependent) range. -- The mkLit{Int,Word}*Wrap smart constructors ensure this by applying -- the target machine's wrapping semantics. Use these in situations -- where you know the wrapping semantics are correct. -- -- * The literal derived from the label mentioned in a \"foreign label\" -- declaration ('LitLabel') -- -- * A 'LitRubbish' to be used in place of values of 'UnliftedRep' -- (i.e. 'MutVar#') when the the value is never used. -- -- * A character -- * A string -- * The NULL pointer -- data Literal = LitChar Char -- ^ @Char#@ - at least 31 bits. Create with -- 'mkLitChar' | LitNumber !LitNumType !Integer Type -- ^ Any numeric literal that can be -- internally represented with an Integer. -- See Note [Types of LitNumbers] below for the -- Type field. | LitString ByteString -- ^ A string-literal: stored and emitted -- UTF-8 encoded, we'll arrange to decode it -- at runtime. Also emitted with a @\'\\0\'@ -- terminator. Create with 'mkLitString' | LitNullAddr -- ^ The @NULL@ pointer, the only pointer value -- that can be represented as a Literal. Create -- with 'nullAddrLit' | LitRubbish -- ^ A nonsense value, used when an unlifted -- binding is absent and has type -- @forall (a :: 'TYPE' 'UnliftedRep'). a@. -- May be lowered by code-gen to any possible -- value. Also see Note [Rubbish literals] | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat' | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble' | LitLabel FastString (Maybe Int) FunctionOrData -- ^ A label literal. Parameters: -- -- 1) The name of the symbol mentioned in the -- declaration -- -- 2) The size (in bytes) of the arguments -- the label expects. Only applicable with -- @stdcall@ labels. @Just x@ => @\@ will -- be appended to label name when emitting -- assembly. -- -- 3) Flag indicating whether the symbol -- references a function or a data deriving Data -- | Numeric literal type data LitNumType = LitNumInteger -- ^ @Integer@ (see Note [Integer literals]) | LitNumNatural -- ^ @Natural@ (see Note [Natural literals]) | LitNumInt -- ^ @Int#@ - according to target machine | LitNumInt64 -- ^ @Int64#@ - exactly 64 bits | LitNumWord -- ^ @Word#@ - according to target machine | LitNumWord64 -- ^ @Word64#@ - exactly 64 bits deriving (Data,Enum,Eq,Ord) -- | Indicate if a numeric literal type supports negative numbers litNumIsSigned :: LitNumType -> Bool litNumIsSigned nt = case nt of LitNumInteger -> True LitNumNatural -> False LitNumInt -> True LitNumInt64 -> True LitNumWord -> False LitNumWord64 -> False {- Note [Integer literals] ~~~~~~~~~~~~~~~~~~~~~~~ An Integer literal is represented using, well, an Integer, to make it easier to write RULEs for them. They also contain the Integer type, so that e.g. literalType can return the right Type for them. They only get converted into real Core, mkInteger [c1, c2, .., cn] during the CorePrep phase, although TidyPgm looks ahead at what the core will be, so that it can see whether it involves CAFs. When we initally build an Integer literal, notably when deserialising it from an interface file (see the Binary instance below), we don't have convenient access to the mkInteger Id. So we just use an error thunk, and fill in the real Id when we do tcIfaceLit in TcIface. Note [Natural literals] ~~~~~~~~~~~~~~~~~~~~~~~ Similar to Integer literals. Note [String literals] ~~~~~~~~~~~~~~~~~~~~~~ String literals are UTF-8 encoded and stored into ByteStrings in the following ASTs: Haskell, Core, Stg, Cmm. TH can also emit ByteString based string literals with the BytesPrimL constructor (see #14741). It wasn't true before as [Word8] was used in Cmm AST and in TH which was quite bad for performance with large strings (see #16198 and #14741). To include string literals into output objects, the assembler code generator has to embed the UTF-8 encoded binary blob. See Note [Embedding large binary blobs] for more details. -} instance Binary LitNumType where put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp)) get bh = do h <- getByte bh return (toEnum (fromIntegral h)) instance Binary Literal where put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa put_ bh (LitString ab) = do putByte bh 1; put_ bh ab put_ bh (LitNullAddr) = do putByte bh 2 put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai put_ bh (LitLabel aj mb fod) = do putByte bh 5 put_ bh aj put_ bh mb put_ bh fod put_ bh (LitNumber nt i _) = do putByte bh 6 put_ bh nt put_ bh i put_ bh (LitRubbish) = do putByte bh 7 get bh = do h <- getByte bh case h of 0 -> do aa <- get bh return (LitChar aa) 1 -> do ab <- get bh return (LitString ab) 2 -> do return (LitNullAddr) 3 -> do ah <- get bh return (LitFloat ah) 4 -> do ai <- get bh return (LitDouble ai) 5 -> do aj <- get bh mb <- get bh fod <- get bh return (LitLabel aj mb fod) 6 -> do nt <- get bh i <- get bh -- Note [Types of LitNumbers] let t = case nt of LitNumInt -> intPrimTy LitNumInt64 -> int64PrimTy LitNumWord -> wordPrimTy LitNumWord64 -> word64PrimTy -- See Note [Integer literals] LitNumInteger -> panic "Evaluated the place holder for mkInteger" -- and Note [Natural literals] LitNumNatural -> panic "Evaluated the place holder for mkNatural" return (LitNumber nt i t) _ -> do return (LitRubbish) instance Outputable Literal where ppr = pprLiteral id instance Eq Literal where a == b = compare a b == EQ -- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in -- 'TrieMap.CoreMap'. instance Ord Literal where compare = cmpLit {- Construction ~~~~~~~~~~~~ -} {- Note [Word/Int underflow/overflow] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and unsigned integral types): "All arithmetic is performed modulo 2^n, where n is the number of bits in the type." GHC stores Word# and Int# constant values as Integer. Core optimizations such as constant folding must ensure that the Integer value remains in the valid target Word/Int range (see #13172). The following functions are used to ensure this. Note that we *don't* warn the user about overflow. It's not done at runtime either, and compilation of completely harmless things like ((124076834 :: Word32) + (2147483647 :: Word32)) doesn't yield a warning. Instead we simply squash the value into the *target* Int/Word range. -} -- | Wrap a literal number according to its type wrapLitNumber :: DynFlags -> Literal -> Literal wrapLitNumber dflags v@(LitNumber nt i t) = case nt of LitNumInt -> case platformWordSize (targetPlatform dflags) of PW4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t PW8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t LitNumWord -> case platformWordSize (targetPlatform dflags) of PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t LitNumInteger -> v LitNumNatural -> v wrapLitNumber _ x = x -- | Create a numeric 'Literal' of the given type mkLitNumberWrap :: DynFlags -> LitNumType -> Integer -> Type -> Literal mkLitNumberWrap dflags nt i t = wrapLitNumber dflags (LitNumber nt i t) -- | Check that a given number is in the range of a numeric literal litNumCheckRange :: DynFlags -> LitNumType -> Integer -> Bool litNumCheckRange dflags nt i = case nt of LitNumInt -> inIntRange dflags i LitNumWord -> inWordRange dflags i LitNumInt64 -> inInt64Range i LitNumWord64 -> inWord64Range i LitNumNatural -> i >= 0 LitNumInteger -> True -- | Create a numeric 'Literal' of the given type mkLitNumber :: DynFlags -> LitNumType -> Integer -> Type -> Literal mkLitNumber dflags nt i t = ASSERT2(litNumCheckRange dflags nt i, integer i) (LitNumber nt i t) -- | Creates a 'Literal' of type @Int#@ mkLitInt :: DynFlags -> Integer -> Literal mkLitInt dflags x = ASSERT2( inIntRange dflags x, integer x ) (mkLitIntUnchecked x) -- | Creates a 'Literal' of type @Int#@. -- If the argument is out of the (target-dependent) range, it is wrapped. -- See Note [Word/Int underflow/overflow] mkLitIntWrap :: DynFlags -> Integer -> Literal mkLitIntWrap dflags i = wrapLitNumber dflags $ mkLitIntUnchecked i -- | Creates a 'Literal' of type @Int#@ without checking its range. mkLitIntUnchecked :: Integer -> Literal mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy -- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating -- overflow. That is, if the argument is out of the (target-dependent) range -- the argument is wrapped and the overflow flag will be set. -- See Note [Word/Int underflow/overflow] mkLitIntWrapC :: DynFlags -> Integer -> (Literal, Bool) mkLitIntWrapC dflags i = (n, i /= i') where n@(LitNumber _ i' _) = mkLitIntWrap dflags i -- | Creates a 'Literal' of type @Word#@ mkLitWord :: DynFlags -> Integer -> Literal mkLitWord dflags x = ASSERT2( inWordRange dflags x, integer x ) (mkLitWordUnchecked x) -- | Creates a 'Literal' of type @Word#@. -- If the argument is out of the (target-dependent) range, it is wrapped. -- See Note [Word/Int underflow/overflow] mkLitWordWrap :: DynFlags -> Integer -> Literal mkLitWordWrap dflags i = wrapLitNumber dflags $ mkLitWordUnchecked i -- | Creates a 'Literal' of type @Word#@ without checking its range. mkLitWordUnchecked :: Integer -> Literal mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy -- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating -- carry. That is, if the argument is out of the (target-dependent) range -- the argument is wrapped and the carry flag will be set. -- See Note [Word/Int underflow/overflow] mkLitWordWrapC :: DynFlags -> Integer -> (Literal, Bool) mkLitWordWrapC dflags i = (n, i /= i') where n@(LitNumber _ i' _) = mkLitWordWrap dflags i -- | Creates a 'Literal' of type @Int64#@ mkLitInt64 :: Integer -> Literal mkLitInt64 x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x) -- | Creates a 'Literal' of type @Int64#@. -- If the argument is out of the range, it is wrapped. mkLitInt64Wrap :: DynFlags -> Integer -> Literal mkLitInt64Wrap dflags i = wrapLitNumber dflags $ mkLitInt64Unchecked i -- | Creates a 'Literal' of type @Int64#@ without checking its range. mkLitInt64Unchecked :: Integer -> Literal mkLitInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy -- | Creates a 'Literal' of type @Word64#@ mkLitWord64 :: Integer -> Literal mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x) -- | Creates a 'Literal' of type @Word64#@. -- If the argument is out of the range, it is wrapped. mkLitWord64Wrap :: DynFlags -> Integer -> Literal mkLitWord64Wrap dflags i = wrapLitNumber dflags $ mkLitWord64Unchecked i -- | Creates a 'Literal' of type @Word64#@ without checking its range. mkLitWord64Unchecked :: Integer -> Literal mkLitWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy -- | Creates a 'Literal' of type @Float#@ mkLitFloat :: Rational -> Literal mkLitFloat = LitFloat -- | Creates a 'Literal' of type @Double#@ mkLitDouble :: Rational -> Literal mkLitDouble = LitDouble -- | Creates a 'Literal' of type @Char#@ mkLitChar :: Char -> Literal mkLitChar = LitChar -- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to -- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@ mkLitString :: String -> Literal -- stored UTF-8 encoded mkLitString s = LitString (bytesFS $ mkFastString s) mkLitInteger :: Integer -> Type -> Literal mkLitInteger x ty = LitNumber LitNumInteger x ty mkLitNatural :: Integer -> Type -> Literal mkLitNatural x ty = ASSERT2( inNaturalRange x, integer x ) (LitNumber LitNumNatural x ty) inIntRange, inWordRange :: DynFlags -> Integer -> Bool inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags inNaturalRange :: Integer -> Bool inNaturalRange x = x >= 0 inInt64Range, inWord64Range :: Integer -> Bool inInt64Range x = x >= toInteger (minBound :: Int64) && x <= toInteger (maxBound :: Int64) inWord64Range x = x >= toInteger (minBound :: Word64) && x <= toInteger (maxBound :: Word64) inCharRange :: Char -> Bool inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR -- | Tests whether the literal represents a zero of whatever type it is isZeroLit :: Literal -> Bool isZeroLit (LitNumber _ 0 _) = True isZeroLit (LitFloat 0) = True isZeroLit (LitDouble 0) = True isZeroLit _ = False -- | Returns the 'Integer' contained in the 'Literal', for when that makes -- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'. litValue :: Literal -> Integer litValue l = case isLitValue_maybe l of Just x -> x Nothing -> pprPanic "litValue" (ppr l) -- | Returns the 'Integer' contained in the 'Literal', for when that makes -- sense, i.e. for 'Char' and numbers. isLitValue_maybe :: Literal -> Maybe Integer isLitValue_maybe (LitChar c) = Just $ toInteger $ ord c isLitValue_maybe (LitNumber _ i _) = Just i isLitValue_maybe _ = Nothing -- | Apply a function to the 'Integer' contained in the 'Literal', for when that -- makes sense, e.g. for 'Char' and numbers. -- For fixed-size integral literals, the result will be wrapped in accordance -- with the semantics of the target type. -- See Note [Word/Int underflow/overflow] mapLitValue :: DynFlags -> (Integer -> Integer) -> Literal -> Literal mapLitValue _ f (LitChar c) = mkLitChar (fchar c) where fchar = chr . fromInteger . f . toInteger . ord mapLitValue dflags f (LitNumber nt i t) = wrapLitNumber dflags (LitNumber nt (f i) t) mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) -- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char', -- 'Int', 'Word', 'LitInteger' and 'LitNatural'. isLitValue :: Literal -> Bool isLitValue = isJust . isLitValue_maybe {- Coercions ~~~~~~~~~ -} narrow8IntLit, narrow16IntLit, narrow32IntLit, narrow8WordLit, narrow16WordLit, narrow32WordLit, char2IntLit, int2CharLit, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit, float2DoubleLit, double2FloatLit :: Literal -> Literal word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal word2IntLit dflags (LitNumber LitNumWord w _) -- Map Word range [max_int+1, max_word] -- to Int range [min_int , -1] -- Range [0,max_int] has the same representation with both Int and Word | w > tARGET_MAX_INT dflags = mkLitInt dflags (w - tARGET_MAX_WORD dflags - 1) | otherwise = mkLitInt dflags w word2IntLit _ l = pprPanic "word2IntLit" (ppr l) int2WordLit dflags (LitNumber LitNumInt i _) -- Map Int range [min_int , -1] -- to Word range [max_int+1, max_word] -- Range [0,max_int] has the same representation with both Int and Word | i < 0 = mkLitWord dflags (1 + tARGET_MAX_WORD dflags + i) | otherwise = mkLitWord dflags i int2WordLit _ l = pprPanic "int2WordLit" (ppr l) -- | Narrow a literal number (unchecked result range) narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t narrowLit _ l = pprPanic "narrowLit" (ppr l) narrow8IntLit = narrowLit (Proxy :: Proxy Int8) narrow16IntLit = narrowLit (Proxy :: Proxy Int16) narrow32IntLit = narrowLit (Proxy :: Proxy Int32) narrow8WordLit = narrowLit (Proxy :: Proxy Word8) narrow16WordLit = narrowLit (Proxy :: Proxy Word16) narrow32WordLit = narrowLit (Proxy :: Proxy Word32) char2IntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c)) char2IntLit l = pprPanic "char2IntLit" (ppr l) int2CharLit (LitNumber _ i _) = LitChar (chr (fromInteger i)) int2CharLit l = pprPanic "int2CharLit" (ppr l) float2IntLit (LitFloat f) = mkLitIntUnchecked (truncate f) float2IntLit l = pprPanic "float2IntLit" (ppr l) int2FloatLit (LitNumber _ i _) = LitFloat (fromInteger i) int2FloatLit l = pprPanic "int2FloatLit" (ppr l) double2IntLit (LitDouble f) = mkLitIntUnchecked (truncate f) double2IntLit l = pprPanic "double2IntLit" (ppr l) int2DoubleLit (LitNumber _ i _) = LitDouble (fromInteger i) int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l) float2DoubleLit (LitFloat f) = LitDouble f float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l) double2FloatLit (LitDouble d) = LitFloat d double2FloatLit l = pprPanic "double2FloatLit" (ppr l) nullAddrLit :: Literal nullAddrLit = LitNullAddr -- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@. rubbishLit :: Literal rubbishLit = LitRubbish {- Predicates ~~~~~~~~~~ -} -- | True if there is absolutely no penalty to duplicating the literal. -- False principally of strings. -- -- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would -- blow up code sizes. Not only this, it's also unsafe. -- -- Consider a program that wants to traverse a string. One way it might do this -- is to first compute the Addr# pointing to the end of the string, and then, -- starting from the beginning, bump a pointer using eqAddr# to determine the -- end. For instance, -- -- @ -- -- Given pointers to the start and end of a string, count how many zeros -- -- the string contains. -- countZeros :: Addr# -> Addr# -> -> Int -- countZeros start end = go start 0 -- where -- go off n -- | off `addrEq#` end = n -- | otherwise = go (off `plusAddr#` 1) n' -- where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1 -- | otherwise = n -- @ -- -- Consider what happens if we considered strings to be trivial (and therefore -- duplicable) and emitted a call like @countZeros "hello"# ("hello"# -- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same -- string, meaning that an iteration like the above would blow up terribly. -- This is what happened in #12757. -- -- Ultimately the solution here is to make primitive strings a bit more -- structured, ensuring that the compiler can't inline in ways that will break -- user code. One approach to this is described in #8472. litIsTrivial :: Literal -> Bool -- c.f. CoreUtils.exprIsTrivial litIsTrivial (LitString _) = False litIsTrivial (LitNumber nt _ _) = case nt of LitNumInteger -> False LitNumNatural -> False LitNumInt -> True LitNumInt64 -> True LitNumWord -> True LitNumWord64 -> True litIsTrivial _ = True -- | True if code space does not go bad if we duplicate this literal litIsDupable :: DynFlags -> Literal -> Bool -- c.f. CoreUtils.exprIsDupable litIsDupable _ (LitString _) = False litIsDupable dflags (LitNumber nt i _) = case nt of LitNumInteger -> inIntRange dflags i LitNumNatural -> inIntRange dflags i LitNumInt -> True LitNumInt64 -> True LitNumWord -> True LitNumWord64 -> True litIsDupable _ _ = True litFitsInChar :: Literal -> Bool litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound) && i <= toInteger (ord maxBound) litFitsInChar _ = False litIsLifted :: Literal -> Bool litIsLifted (LitNumber nt _ _) = case nt of LitNumInteger -> True LitNumNatural -> True LitNumInt -> False LitNumInt64 -> False LitNumWord -> False LitNumWord64 -> False litIsLifted _ = False {- Types ~~~~~ Note [Types of LitNumbers] ~~~~~~~~~~~~~~~~~~~~~~~~~~ A LitNumber's type is always known from its LitNumType: LitNumInteger -> Integer LitNumNatural -> Natural LitNumInt -> Int# (intPrimTy) LitNumInt64 -> Int64# (int64PrimTy) LitNumWord -> Word# (wordPrimTy) LitNumWord64 -> Word64# (word64PrimTy) The reason why we have a Type field is because Integer and Natural types live outside of GHC (in the libraries), so we have to get the actual Type via lookupTyCon, tcIfaceTyConByName etc. that's too inconvenient in the call sites of literalType, so we do that when creating these literals, and literalType simply reads the field. (But see also Note [Integer literals] and Note [Natural literals]) -} -- | Find the Haskell 'Type' the literal occupies literalType :: Literal -> Type literalType LitNullAddr = addrPrimTy literalType (LitChar _) = charPrimTy literalType (LitString _) = addrPrimTy literalType (LitFloat _) = floatPrimTy literalType (LitDouble _) = doublePrimTy literalType (LitLabel _ _ _) = addrPrimTy literalType (LitNumber _ _ t) = t -- Note [Types of LitNumbers] literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a) where a = alphaTyVarUnliftedRep absentLiteralOf :: TyCon -> Maybe Literal -- Return a literal of the appropriate primitive -- TyCon, to use as a placeholder when it doesn't matter -- Rubbish literals are handled in WwLib, because -- 1. Looking at the TyCon is not enough, we need the actual type -- 2. This would need to return a type application to a literal absentLiteralOf tc = lookupUFM absent_lits (tyConName tc) absent_lits :: UniqFM Literal absent_lits = listToUFM [ (addrPrimTyConKey, LitNullAddr) , (charPrimTyConKey, LitChar 'x') , (intPrimTyConKey, mkLitIntUnchecked 0) , (int64PrimTyConKey, mkLitInt64Unchecked 0) , (wordPrimTyConKey, mkLitWordUnchecked 0) , (word64PrimTyConKey, mkLitWord64Unchecked 0) , (floatPrimTyConKey, LitFloat 0) , (doublePrimTyConKey, LitDouble 0) ] {- Comparison ~~~~~~~~~~ -} cmpLit :: Literal -> Literal -> Ordering cmpLit (LitChar a) (LitChar b) = a `compare` b cmpLit (LitString a) (LitString b) = a `compare` b cmpLit (LitNullAddr) (LitNullAddr) = EQ cmpLit (LitFloat a) (LitFloat b) = a `compare` b cmpLit (LitDouble a) (LitDouble b) = a `compare` b cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `compare` b cmpLit (LitNumber nt1 a _) (LitNumber nt2 b _) | nt1 == nt2 = a `compare` b | otherwise = nt1 `compare` nt2 cmpLit (LitRubbish) (LitRubbish) = EQ cmpLit lit1 lit2 | litTag lit1 < litTag lit2 = LT | otherwise = GT litTag :: Literal -> Int litTag (LitChar _) = 1 litTag (LitString _) = 2 litTag (LitNullAddr) = 3 litTag (LitFloat _) = 4 litTag (LitDouble _) = 5 litTag (LitLabel _ _ _) = 6 litTag (LitNumber {}) = 7 litTag (LitRubbish) = 8 {- Printing ~~~~~~~~ * See Note [Printing of literals in Core] -} pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc pprLiteral _ (LitChar c) = pprPrimChar c pprLiteral _ (LitString s) = pprHsBytes s pprLiteral _ (LitNullAddr) = text "__NULL" pprLiteral _ (LitFloat f) = float (fromRat f) <> primFloatSuffix pprLiteral _ (LitDouble d) = double (fromRat d) <> primDoubleSuffix pprLiteral add_par (LitNumber nt i _) = case nt of LitNumInteger -> pprIntegerVal add_par i LitNumNatural -> pprIntegerVal add_par i LitNumInt -> pprPrimInt i LitNumInt64 -> pprPrimInt64 i LitNumWord -> pprPrimWord i LitNumWord64 -> pprPrimWord64 i pprLiteral add_par (LitLabel l mb fod) = add_par (text "__label" <+> b <+> ppr fod) where b = case mb of Nothing -> pprHsString l Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) pprLiteral _ (LitRubbish) = text "__RUBBISH" pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc -- See Note [Printing of literals in Core]. pprIntegerVal add_par i | i < 0 = add_par (integer i) | otherwise = integer i {- Note [Printing of literals in Core] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The function `add_par` is used to wrap parenthesis around negative integers (`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring an atomic thing (for example function application). Although not all Core literals would be valid Haskell, we are trying to stay as close as possible to Haskell syntax in the printing of Core, to make it easier for a Haskell user to read Core. To that end: * We do print parenthesis around negative `LitInteger`, because we print `LitInteger` using plain number literals (no prefix or suffix), and plain number literals in Haskell require parenthesis in contexts like function application (i.e. `1 - -1` is not valid Haskell). * We don't print parenthesis around other (negative) literals, because they aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's parser). Literal Output Output if context requires an atom (if different) ------- ------- ---------------------- LitChar 'a'# LitString "aaa"# LitNullAddr "__NULL" LitInt -1# LitInt64 -1L# LitWord 1## LitWord64 1L## LitFloat -1.0# LitDouble -1.0## LitInteger -1 (-1) LitLabel "__label" ... ("__label" ...) LitRubbish "__RUBBISH" Note [Rubbish literals] ~~~~~~~~~~~~~~~~~~~~~~~ During worker/wrapper after demand analysis, where an argument is unused (absent) we do the following w/w split (supposing that y is absent): f x y z = e ===> f x y z = $wf x z $wf x z = let y = in e Usually the binding for y is ultimately optimised away, and even if not it should never be evaluated -- but that's the way the w/w split starts off. What is ? * For lifted values can be a call to 'error'. * For primitive types like Int# or Word# we can use any random value of that type. * But what about /unlifted/ but /boxed/ types like MutVar# or Array#? We need a literal value of that type. That is 'LitRubbish'. Since we need a rubbish literal for many boxed, unlifted types, we say that LitRubbish has type LitRubbish :: forall (a :: TYPE UnliftedRep). a So we might see a w/w split like $wf x z = let y :: Array# Int = LitRubbish @(Array# Int) in e Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted heap pointers. Here are the moving parts: * We define LitRubbish as a constructor in Literal.Literal * It is given its polymoprhic type by Literal.literalType * WwLib.mk_absent_let introduces a LitRubbish for absent arguments of boxed, unlifted type. * In CoreToSTG we convert (RubishLit @t) to just (). STG is untyped, so it doesn't matter that it points to a lifted value. The important thing is that it is a heap pointer, which the garbage collector can follow if it encounters it. We considered maintaining LitRubbish in STG, and lowering it in the code genreators, but it seems simpler to do it once and for all in CoreToSTG. In ByteCodeAsm we just lower it as a 0 literal, because it's all boxed and lifted to the host GC anyway. -} ghc-lib-parser-8.10.2.20200808/compiler/utils/Maybes.hs0000644000000000000000000000632713713635745020245 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} module Maybes ( module Data.Maybe, MaybeErr(..), -- Instance of Monad failME, isSuccess, orElse, firstJust, firstJusts, whenIsJust, expectJust, rightToMaybe, -- * MaybeT MaybeT(..), liftMaybeT, tryMaybeT ) where import GhcPrelude import Control.Monad import Control.Monad.Trans.Maybe import Control.Exception (catch, SomeException(..)) import Data.Maybe import Util (HasCallStack) infixr 4 `orElse` {- ************************************************************************ * * \subsection[Maybe type]{The @Maybe@ type} * * ************************************************************************ -} firstJust :: Maybe a -> Maybe a -> Maybe a firstJust a b = firstJusts [a, b] -- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or -- @Nothing@ otherwise. firstJusts :: [Maybe a] -> Maybe a firstJusts = msum expectJust :: HasCallStack => String -> Maybe a -> a {-# INLINE expectJust #-} expectJust _ (Just x) = x expectJust err Nothing = error ("expectJust " ++ err) whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () -- | Flipped version of @fromMaybe@, useful for chaining. orElse :: Maybe a -> a -> a orElse = flip fromMaybe rightToMaybe :: Either a b -> Maybe b rightToMaybe (Left _) = Nothing rightToMaybe (Right x) = Just x {- ************************************************************************ * * \subsection[MaybeT type]{The @MaybeT@ monad transformer} * * ************************************************************************ -} -- We had our own MaybeT in the past. Now we reuse transformer's MaybeT liftMaybeT :: Monad m => m a -> MaybeT m a liftMaybeT act = MaybeT $ Just `liftM` act -- | Try performing an 'IO' action, failing on error. tryMaybeT :: IO a -> MaybeT IO a tryMaybeT action = MaybeT $ catch (Just `fmap` action) handler where handler (SomeException _) = return Nothing {- ************************************************************************ * * \subsection[MaybeErr type]{The @MaybeErr@ type} * * ************************************************************************ -} data MaybeErr err val = Succeeded val | Failed err deriving (Functor) instance Applicative (MaybeErr err) where pure = Succeeded (<*>) = ap instance Monad (MaybeErr err) where Succeeded v >>= k = k v Failed e >>= _ = Failed e isSuccess :: MaybeErr err val -> Bool isSuccess (Succeeded {}) = True isSuccess (Failed {}) = False failME :: err -> MaybeErr err val failME e = Failed e ghc-lib-parser-8.10.2.20200808/compiler/coreSyn/MkCore.hs0000644000000000000000000011234313713635744020462 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Handy functions for creating much Core syntax module MkCore ( -- * Constructing normal syntax mkCoreLet, mkCoreLets, mkCoreApp, mkCoreApps, mkCoreConApps, mkCoreLams, mkWildCase, mkIfThenElse, mkWildValBinder, mkWildEvBinder, mkSingleAltCase, sortQuantVars, castBottomExpr, -- * Constructing boxed literals mkWordExpr, mkWordExprWord, mkIntExpr, mkIntExprInt, mkIntegerExpr, mkNaturalExpr, mkFloatExpr, mkDoubleExpr, mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith, -- * Floats FloatBind(..), wrapFloat, wrapFloats, floatBindings, -- * Constructing small tuples mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup, mkCoreTupBoxity, unitExpr, -- * Constructing big tuples mkBigCoreVarTup, mkBigCoreVarTup1, mkBigCoreVarTupTy, mkBigCoreTupTy, mkBigCoreTup, -- * Deconstructing small tuples mkSmallTupleSelector, mkSmallTupleCase, -- * Deconstructing big tuples mkTupleSelector, mkTupleSelector1, mkTupleCase, -- * Constructing list expressions mkNilExpr, mkConsExpr, mkListExpr, mkFoldrExpr, mkBuildExpr, -- * Constructing Maybe expressions mkNothingExpr, mkJustExpr, -- * Error Ids mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds, rEC_CON_ERROR_ID, rUNTIME_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID, tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID ) where #include "GhclibHsVersions.h" import GhcPrelude import Id import Var ( EvVar, setTyVarUnique ) import CoreSyn import CoreUtils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec ) import Literal import HscTypes import TysWiredIn import PrelNames import GHC.Hs.Utils ( mkChunkified, chunkify ) import Type import Coercion ( isCoVar ) import TysPrim import DataCon ( DataCon, dataConWorkId ) import IdInfo import Demand import Name hiding ( varName ) import Outputable import FastString import UniqSupply import BasicTypes import Util import DynFlags import Data.List import Data.Char ( ord ) import Control.Monad.Fail as MonadFail ( MonadFail ) infixl 4 `mkCoreApp`, `mkCoreApps` {- ************************************************************************ * * \subsection{Basic CoreSyn construction} * * ************************************************************************ -} sortQuantVars :: [Var] -> [Var] -- Sort the variables, putting type and covars first, in scoped order, -- and then other Ids -- It is a deterministic sort, meaining it doesn't look at the values of -- Uniques. For explanation why it's important See Note [Unique Determinism] -- in Unique. sortQuantVars vs = sorted_tcvs ++ ids where (tcvs, ids) = partition (isTyVar <||> isCoVar) vs sorted_tcvs = scopedSort tcvs -- | Bind a binding group over an expression, using a @let@ or @case@ as -- appropriate (see "CoreSyn#let_app_invariant") mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr mkCoreLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant] = bindNonRec bndr rhs body mkCoreLet bind body = Let bind body -- | Create a lambda where the given expression has a number of variables -- bound over it. The leftmost binder is that bound by the outermost -- lambda in the result mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr mkCoreLams = mkLams -- | Bind a list of binding groups over an expression. The leftmost binding -- group becomes the outermost group in the resulting expression mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr mkCoreLets binds body = foldr mkCoreLet body binds -- | Construct an expression which represents the application of a number of -- expressions to that of a data constructor expression. The leftmost expression -- in the list is applied first mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args -- | Construct an expression which represents the application of a number of -- expressions to another. The leftmost expression in the list is applied first -- Respects the let/app invariant by building a case expression where necessary -- See CoreSyn Note [CoreSyn let/app invariant] mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr mkCoreApps fun args = fst $ foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args where doc_string = ppr fun_ty $$ ppr fun $$ ppr args fun_ty = exprType fun -- | Construct an expression which represents the application of one expression -- to the other -- Respects the let/app invariant by building a case expression where necessary -- See CoreSyn Note [CoreSyn let/app invariant] mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr mkCoreApp s fun arg = fst $ mkCoreAppTyped s (fun, exprType fun) arg -- | Construct an expression which represents the application of one expression -- paired with its type to an argument. The result is paired with its type. This -- function is not exported and used in the definition of 'mkCoreApp' and -- 'mkCoreApps'. -- Respects the let/app invariant by building a case expression where necessary -- See CoreSyn Note [CoreSyn let/app invariant] mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type) mkCoreAppTyped _ (fun, fun_ty) (Type ty) = (App fun (Type ty), piResultTy fun_ty ty) mkCoreAppTyped _ (fun, fun_ty) (Coercion co) = (App fun (Coercion co), funResultTy fun_ty) mkCoreAppTyped d (fun, fun_ty) arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d ) (mkValApp fun arg arg_ty res_ty, res_ty) where (arg_ty, res_ty) = splitFunTy fun_ty mkValApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr -- Build an application (e1 e2), -- or a strict binding (case e2 of x -> e1 x) -- using the latter when necessary to respect the let/app invariant -- See Note [CoreSyn let/app invariant] mkValApp fun arg arg_ty res_ty | not (needsCaseBinding arg_ty arg) = App fun arg -- The vastly common case | otherwise = mkStrictApp fun arg arg_ty res_ty {- ********************************************************************* * * Building case expressions * * ********************************************************************* -} mkWildEvBinder :: PredType -> EvVar mkWildEvBinder pred = mkWildValBinder pred -- | Make a /wildcard binder/. This is typically used when you need a binder -- that you expect to use only at a *binding* site. Do not use it at -- occurrence sites because it has a single, fixed unique, and it's very -- easy to get into difficulties with shadowing. That's why it is used so little. -- See Note [WildCard binders] in SimplEnv mkWildValBinder :: Type -> Id mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr -- Make a case expression whose case binder is unused -- The alts and res_ty should not have any occurrences of WildId mkWildCase scrut scrut_ty res_ty alts = Case scrut (mkWildValBinder scrut_ty) res_ty alts mkStrictApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr -- Build a strict application (case e2 of x -> e1 x) mkStrictApp fun arg arg_ty res_ty = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))] -- mkDefaultCase looks attractive here, and would be sound. -- But it uses (exprType alt_rhs) to compute the result type, -- whereas here we already know that the result type is res_ty where arg_id = mkWildValBinder arg_ty -- Lots of shadowing, but it doesn't matter, -- because 'fun' and 'res_ty' should not have a free wild-id -- -- This is Dangerous. But this is the only place we play this -- game, mkStrictApp returns an expression that does not have -- a free wild-id. So the only way 'fun' could get a free wild-id -- would be if you take apart this case expression (or some other -- expression that uses mkWildValBinder, of which there are not -- many), and pass a fragment of it as the fun part of a 'mkStrictApp'. mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr mkIfThenElse guard then_expr else_expr -- Not going to be refining, so okay to take the type of the "then" clause = mkWildCase guard boolTy (exprType then_expr) [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! (DataAlt trueDataCon, [], then_expr) ] castBottomExpr :: CoreExpr -> Type -> CoreExpr -- (castBottomExpr e ty), assuming that 'e' diverges, -- return an expression of type 'ty' -- See Note [Empty case alternatives] in CoreSyn castBottomExpr e res_ty | e_ty `eqType` res_ty = e | otherwise = Case e (mkWildValBinder e_ty) res_ty [] where e_ty = exprType e {- ************************************************************************ * * \subsection{Making literals} * * ************************************************************************ -} -- | Create a 'CoreExpr' which will evaluate to the given @Int@ mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int mkIntExpr dflags i = mkCoreConApps intDataCon [mkIntLit dflags i] -- | Create a 'CoreExpr' which will evaluate to the given @Int@ mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int mkIntExprInt dflags i = mkCoreConApps intDataCon [mkIntLitInt dflags i] -- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value mkWordExpr :: DynFlags -> Integer -> CoreExpr mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w] -- | Create a 'CoreExpr' which will evaluate to the given @Word@ mkWordExprWord :: DynFlags -> Word -> CoreExpr mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w] -- | Create a 'CoreExpr' which will evaluate to the given @Integer@ mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer mkIntegerExpr i = do t <- lookupTyCon integerTyConName return (Lit (mkLitInteger i (mkTyConTy t))) -- | Create a 'CoreExpr' which will evaluate to the given @Natural@ mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr mkNaturalExpr i = do t <- lookupTyCon naturalTyConName return (Lit (mkLitNatural i (mkTyConTy t))) -- | Create a 'CoreExpr' which will evaluate to the given @Float@ mkFloatExpr :: Float -> CoreExpr mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f] -- | Create a 'CoreExpr' which will evaluate to the given @Double@ mkDoubleExpr :: Double -> CoreExpr mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d] -- | Create a 'CoreExpr' which will evaluate to the given @Char@ mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c] -- | Create a 'CoreExpr' which will evaluate to the given @String@ mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String -- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@ mkStringExprFS :: MonadThings m => FastString -> m CoreExpr -- Result :: String mkStringExpr str = mkStringExprFS (mkFastString str) mkStringExprFS = mkStringExprFSWith lookupId mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr mkStringExprFSWith lookupM str | nullFS str = return (mkNilExpr charTy) | all safeChar chars = do unpack_id <- lookupM unpackCStringName return (App (Var unpack_id) lit) | otherwise = do unpack_utf8_id <- lookupM unpackCStringUtf8Name return (App (Var unpack_utf8_id) lit) where chars = unpackFS str safeChar c = ord c >= 1 && ord c <= 0x7F lit = Lit (LitString (bytesFS str)) {- ************************************************************************ * * \subsection{Tuple constructors} * * ************************************************************************ -} {- Creating tuples and their types for Core expressions @mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@. * If it has only one element, it is the identity function. * If there are more elements than a big tuple can have, it nests the tuples. Note [Flattening one-tuples] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This family of functions creates a tuple of variables/expressions/types. mkCoreTup [e1,e2,e3] = (e1,e2,e3) What if there is just one variable/expression/type in the argument? We could do one of two things: * Flatten it out, so that mkCoreTup [e1] = e1 * Build a one-tuple (see Note [One-tuples] in TysWiredIn) mkCoreTup1 [e1] = Unit e1 We use a suffix "1" to indicate this. Usually we want the former, but occasionally the latter. NB: The logic in tupleDataCon knows about () and Unit and (,), etc. Note [Don't flatten tuples from HsSyn] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we get an explicit 1-tuple from HsSyn somehow (likely: Template Haskell), we should treat it really as a 1-tuple, without flattening. Note that a 1-tuple and a flattened value have different performance and laziness characteristics, so should just do what we're asked. This arose from discussions in #16881. One-tuples that arise internally depend on the circumstance; often flattening is a good idea. Decisions are made on a case-by-case basis. -} -- | Build the type of a small tuple that holds the specified variables -- One-tuples are flattened; see Note [Flattening one-tuples] mkCoreVarTupTy :: [Id] -> Type mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) -- | Build a small tuple holding the specified expressions -- One-tuples are flattened; see Note [Flattening one-tuples] mkCoreTup :: [CoreExpr] -> CoreExpr mkCoreTup [c] = c mkCoreTup cs = mkCoreTup1 cs -- non-1-tuples are uniform -- | Build a small tuple holding the specified expressions -- One-tuples are *not* flattened; see Note [Flattening one-tuples] -- See also Note [Don't flatten tuples from HsSyn] mkCoreTup1 :: [CoreExpr] -> CoreExpr mkCoreTup1 cs = mkCoreConApps (tupleDataCon Boxed (length cs)) (map (Type . exprType) cs ++ cs) -- | Build a small unboxed tuple holding the specified expressions, -- with the given types. The types must be the types of the expressions. -- Do not include the RuntimeRep specifiers; this function calculates them -- for you. -- Does /not/ flatten one-tuples; see Note [Flattening one-tuples] mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr mkCoreUbxTup tys exps = ASSERT( tys `equalLength` exps) mkCoreConApps (tupleDataCon Unboxed (length tys)) (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps) -- | Make a core tuple of the given boxity; don't flatten 1-tuples mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr mkCoreTupBoxity Boxed exps = mkCoreTup1 exps mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps -- | Build a big tuple holding the specified variables -- One-tuples are flattened; see Note [Flattening one-tuples] mkBigCoreVarTup :: [Id] -> CoreExpr mkBigCoreVarTup ids = mkBigCoreTup (map Var ids) mkBigCoreVarTup1 :: [Id] -> CoreExpr -- Same as mkBigCoreVarTup, but one-tuples are NOT flattened -- see Note [Flattening one-tuples] mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1) [Type (idType id), Var id] mkBigCoreVarTup1 ids = mkBigCoreTup (map Var ids) -- | Build the type of a big tuple that holds the specified variables -- One-tuples are flattened; see Note [Flattening one-tuples] mkBigCoreVarTupTy :: [Id] -> Type mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids) -- | Build a big tuple holding the specified expressions -- One-tuples are flattened; see Note [Flattening one-tuples] mkBigCoreTup :: [CoreExpr] -> CoreExpr mkBigCoreTup = mkChunkified mkCoreTup -- | Build the type of a big tuple that holds the specified type of thing -- One-tuples are flattened; see Note [Flattening one-tuples] mkBigCoreTupTy :: [Type] -> Type mkBigCoreTupTy = mkChunkified mkBoxedTupleTy -- | The unit expression unitExpr :: CoreExpr unitExpr = Var unitDataConId {- ************************************************************************ * * \subsection{Tuple destructors} * * ************************************************************************ -} -- | Builds a selector which scrutises the given -- expression and extracts the one name from the list given. -- If you want the no-shadowing rule to apply, the caller -- is responsible for making sure that none of these names -- are in scope. -- -- If there is just one 'Id' in the tuple, then the selector is -- just the identity. -- -- If necessary, we pattern match on a \"big\" tuple. mkTupleSelector, mkTupleSelector1 :: [Id] -- ^ The 'Id's to pattern match the tuple against -> Id -- ^ The 'Id' to select -> Id -- ^ A variable of the same type as the scrutinee -> CoreExpr -- ^ Scrutinee -> CoreExpr -- ^ Selector expression -- mkTupleSelector [a,b,c,d] b v e -- = case e of v { -- (p,q) -> case p of p { -- (a,b) -> b }} -- We use 'tpl' vars for the p,q, since shadowing does not matter. -- -- In fact, it's more convenient to generate it innermost first, getting -- -- case (case e of v -- (p,q) -> p) of p -- (a,b) -> b mkTupleSelector vars the_var scrut_var scrut = mk_tup_sel (chunkify vars) the_var where mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $ mk_tup_sel (chunkify tpl_vs) tpl_v where tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s] tpl_vs = mkTemplateLocals tpl_tys [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s, the_var `elem` gp ] -- ^ 'mkTupleSelector1' is like 'mkTupleSelector' -- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) mkTupleSelector1 vars the_var scrut_var scrut | [_] <- vars = mkSmallTupleSelector1 vars the_var scrut_var scrut | otherwise = mkTupleSelector vars the_var scrut_var scrut -- | Like 'mkTupleSelector' but for tuples that are guaranteed -- never to be \"big\". -- -- > mkSmallTupleSelector [x] x v e = [| e |] -- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |] mkSmallTupleSelector, mkSmallTupleSelector1 :: [Id] -- The tuple args -> Id -- The selected one -> Id -- A variable of the same type as the scrutinee -> CoreExpr -- Scrutinee -> CoreExpr mkSmallTupleSelector [var] should_be_the_same_var _ scrut = ASSERT(var == should_be_the_same_var) scrut -- Special case for 1-tuples mkSmallTupleSelector vars the_var scrut_var scrut = mkSmallTupleSelector1 vars the_var scrut_var scrut -- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector' -- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) mkSmallTupleSelector1 vars the_var scrut_var scrut = ASSERT( notNull vars ) Case scrut scrut_var (idType the_var) [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)] -- | A generalization of 'mkTupleSelector', allowing the body -- of the case to be an arbitrary expression. -- -- To avoid shadowing, we use uniques to invent new variables. -- -- If necessary we pattern match on a \"big\" tuple. mkTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables -> [Id] -- ^ The tuple identifiers to pattern match on -> CoreExpr -- ^ Body of the case -> Id -- ^ A variable of the same type as the scrutinee -> CoreExpr -- ^ Scrutinee -> CoreExpr -- ToDo: eliminate cases where none of the variables are needed. -- -- mkTupleCase uniqs [a,b,c,d] body v e -- = case e of v { (p,q) -> -- case p of p { (a,b) -> -- case q of q { (c,d) -> -- body }}} mkTupleCase uniqs vars body scrut_var scrut = mk_tuple_case uniqs (chunkify vars) body where -- This is the case where don't need any nesting mk_tuple_case _ [vars] body = mkSmallTupleCase vars body scrut_var scrut -- This is the case where we must make nest tuples at least once mk_tuple_case us vars_s body = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s in mk_tuple_case us' (chunkify vars') body' one_tuple_case chunk_vars (us, vs, body) = let (uniq, us') = takeUniqFromSupply us scrut_var = mkSysLocal (fsLit "ds") uniq (mkBoxedTupleTy (map idType chunk_vars)) body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) in (us', scrut_var:vs, body') -- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed -- not to need nesting. mkSmallTupleCase :: [Id] -- ^ The tuple args -> CoreExpr -- ^ Body of the case -> Id -- ^ A variable of the same type as the scrutinee -> CoreExpr -- ^ Scrutinee -> CoreExpr mkSmallTupleCase [var] body _scrut_var scrut = bindNonRec var scrut body mkSmallTupleCase vars body scrut_var scrut -- One branch no refinement? = Case scrut scrut_var (exprType body) [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)] {- ************************************************************************ * * Floats * * ************************************************************************ -} data FloatBind = FloatLet CoreBind | FloatCase CoreExpr Id AltCon [Var] -- case e of y { C ys -> ... } -- See Note [Floating single-alternative cases] in SetLevels instance Outputable FloatBind where ppr (FloatLet b) = text "LET" <+> ppr b ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b) 2 (ppr c <+> ppr bs) wrapFloat :: FloatBind -> CoreExpr -> CoreExpr wrapFloat (FloatLet defns) body = Let defns body wrapFloat (FloatCase e b con bs) body = mkSingleAltCase e b con bs body -- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn] -- u = let b1 in let b2 in … in let bn in u@ wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr wrapFloats floats expr = foldr wrapFloat expr floats bindBindings :: CoreBind -> [Var] bindBindings (NonRec b _) = [b] bindBindings (Rec bnds) = map fst bnds floatBindings :: FloatBind -> [Var] floatBindings (FloatLet bnd) = bindBindings bnd floatBindings (FloatCase _ b _ bs) = b:bs {- ************************************************************************ * * \subsection{Common list manipulation expressions} * * ************************************************************************ Call the constructor Ids when building explicit lists, so that they interact well with rules. -} -- | Makes a list @[]@ for lists of the specified type mkNilExpr :: Type -> CoreExpr mkNilExpr ty = mkCoreConApps nilDataCon [Type ty] -- | Makes a list @(:)@ for lists of the specified type mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl] -- | Make a list containing the given expressions, where the list has the given type mkListExpr :: Type -> [CoreExpr] -> CoreExpr mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs -- | Make a fully applied 'foldr' expression mkFoldrExpr :: MonadThings m => Type -- ^ Element type of the list -> Type -- ^ Fold result type -> CoreExpr -- ^ "Cons" function expression for the fold -> CoreExpr -- ^ "Nil" expression for the fold -> CoreExpr -- ^ List expression being folded acress -> m CoreExpr mkFoldrExpr elt_ty result_ty c n list = do foldr_id <- lookupId foldrName return (Var foldr_id `App` Type elt_ty `App` Type result_ty `App` c `App` n `App` list) -- | Make a 'build' expression applied to a locally-bound worker function mkBuildExpr :: (MonadFail.MonadFail m, MonadThings m, MonadUnique m) => Type -- ^ Type of list elements to be built -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's -- of the binders for the build worker function, returns -- the body of that worker -> m CoreExpr mkBuildExpr elt_ty mk_build_inside = do [n_tyvar] <- newTyVars [alphaTyVar] let n_ty = mkTyVarTy n_tyvar c_ty = mkVisFunTys [elt_ty, n_ty] n_ty [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty] build_inside <- mk_build_inside (c, c_ty) (n, n_ty) build_id <- lookupId buildName return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside where newTyVars tyvar_tmpls = do uniqs <- getUniquesM return (zipWith setTyVarUnique tyvar_tmpls uniqs) {- ************************************************************************ * * Manipulating Maybe data type * * ************************************************************************ -} -- | Makes a Nothing for the specified type mkNothingExpr :: Type -> CoreExpr mkNothingExpr ty = mkConApp nothingDataCon [Type ty] -- | Makes a Just from a value of the specified type mkJustExpr :: Type -> CoreExpr -> CoreExpr mkJustExpr ty val = mkConApp justDataCon [Type ty, val] {- ************************************************************************ * * Error expressions * * ************************************************************************ -} mkRuntimeErrorApp :: Id -- Should be of type (forall a. Addr# -> a) -- where Addr# points to a UTF8 encoded string -> Type -- The type to instantiate 'a' -> String -- The string to print -> CoreExpr mkRuntimeErrorApp err_id res_ty err_msg = mkApps (Var err_id) [ Type (getRuntimeRep res_ty) , Type res_ty, err_string ] where err_string = Lit (mkLitString err_msg) mkImpossibleExpr :: Type -> CoreExpr mkImpossibleExpr res_ty = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative" {- ************************************************************************ * * Error Ids * * ************************************************************************ GHC randomly injects these into the code. @patError@ is just a version of @error@ for pattern-matching failures. It knows various ``codes'' which expand to longer strings---this saves space! @absentErr@ is a thing we put in for ``absent'' arguments. They jolly well shouldn't be yanked on, but if one is, then you will get a friendly message from @absentErr@ (rather than a totally random crash). @parError@ is a special version of @error@ which the compiler does not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ templates, but we don't ever expect to generate code for it. -} errorIds :: [Id] errorIds = [ rUNTIME_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID, tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284 ] recSelErrorName, runtimeErrorName, absentErrorName :: Name recConErrorName, patErrorName :: Name nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name typeErrorName :: Name absentSumFieldErrorName :: Name recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID absentSumFieldErrorName = err_nm "absentSumFieldError" absentSumFieldErrorIdKey aBSENT_SUM_FIELD_ERROR_ID runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID noMethodBindingErrorName = err_nm "noMethodBindingError" noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError" nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID err_nm :: String -> Unique -> Id -> Name err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName pAT_ERROR_ID = mkRuntimeErrorId patErrorName nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName -- Note [aBSENT_SUM_FIELD_ERROR_ID] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Absent argument error for unused unboxed sum fields are different than absent -- error used in dummy worker functions (see `mkAbsentErrorApp`): -- -- - `absentSumFieldError` can't take arguments because it's used in unarise for -- unused pointer fields in unboxed sums, and applying an argument would -- require allocating a thunk. -- -- - `absentSumFieldError` can't be CAFFY because that would mean making some -- non-CAFFY definitions that use unboxed sums CAFFY in unarise. -- -- To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in -- RtsStartup.c and mark it as non-CAFFY here. -- -- Getting this wrong causes hard-to-debug runtime issues, see #15038. -- -- TODO: Remove stable pointer hack after fixing #9718. -- However, we should still be careful about not making things CAFFY just -- because they use unboxed sums. Unboxed objects are supposed to be -- efficient, and none of the other unboxed literals make things CAFFY. aBSENT_SUM_FIELD_ERROR_ID = mkVanillaGlobalWithInfo absentSumFieldErrorName (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botRes `setArityInfo` 0 `setCafInfo` NoCafRefs) -- #15038 mkRuntimeErrorId :: Name -> Id -- Error function -- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a -- with arity: 1 -- which diverges after being given one argument -- The Addr# is expected to be the address of -- a UTF8-encoded error string mkRuntimeErrorId name = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info where bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig `setArityInfo` 1 -- Make arity and strictness agree -- Do *not* mark them as NoCafRefs, because they can indeed have -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, -- which has some CAFs -- In due course we may arrange that these error-y things are -- regarded by the GC as permanently live, in which case we -- can give them NoCaf info. As it is, any function that calls -- any pc_bottoming_Id will itself have CafRefs, which bloats -- SRTs. strict_sig = mkClosedStrictSig [evalDmd] botRes runtimeErrorTy :: Type -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a -- See Note [Error and friends have an "open-tyvar" forall] runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] (mkVisFunTy addrPrimTy openAlphaTy) {- Note [Error and friends have an "open-tyvar" forall] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'error' and 'undefined' have types error :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a Notice the runtime-representation polymorphism. This ensures that "error" can be instantiated at unboxed as well as boxed types. This is OK because it never returns, so the return type is irrelevant. ************************************************************************ * * aBSENT_ERROR_ID * * ************************************************************************ Note [aBSENT_ERROR_ID] ~~~~~~~~~~~~~~~~~~~~~~ We use aBSENT_ERROR_ID to build dummy values in workers. E.g. f x = (case x of (a,b) -> b) + 1::Int The demand analyser figures ot that only the second component of x is used, and does a w/w split thus f x = case x of (a,b) -> $wf b $wf b = let a = absentError "blah" x = (a,b) in After some simplification, the (absentError "blah") thunk goes away. ------ Tricky wrinkle ------- #14285 had, roughly data T a = MkT a !a {-# INLINABLE f #-} f x = case x of MkT a b -> g (MkT b a) It turned out that g didn't use the second component, and hence f doesn't use the first. But the stable-unfolding for f looks like \x. case x of MkT a b -> g ($WMkT b a) where $WMkT is the wrapper for MkT that evaluates its arguments. We apply the same w/w split to this unfolding (see Note [Worker-wrapper for INLINEABLE functions] in WorkWrap) so the template ends up like \b. let a = absentError "blah" x = MkT a b in case x of MkT a b -> g ($WMkT b a) After doing case-of-known-constructor, and expanding $WMkT we get \b -> g (case absentError "blah" of a -> MkT b a) Yikes! That bogusly appears to evaluate the absentError! This is extremely tiresome. Another way to think of this is that, in Core, it is an invariant that a strict data contructor, like MkT, must be applied only to an argument in HNF. So (absentError "blah") had better be non-bottom. So the "solution" is to add a special case for absentError to exprIsHNFlike. This allows Simplify.rebuildCase, in the Note [Case to let transformation] branch, to convert the case on absentError into a let. We also make absentError *not* be diverging, unlike the other error-ids, so that we can be sure not to remove the case branches before converting the case to a let. If, by some bug or bizarre happenstance, we ever call absentError, we should throw an exception. This should never happen, of course, but we definitely can't return anything. e.g. if somehow we had case absentError "foo" of Nothing -> ... Just x -> ... then if we return, the case expression will select a field and continue. Seg fault city. Better to throw an exception. (Even though we've said it is in HNF :-) It might seem a bit surprising that seq on absentError is simply erased absentError "foo" `seq` x ==> x but that should be okay; since there's no pattern match we can't really be relying on anything from it. -} aBSENT_ERROR_ID = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info where absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy addrPrimTy alphaTy) -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for -- lifted-type things; see Note [Absent errors] in WwLib arity_info = vanillaIdInfo `setArityInfo` 1 -- NB: no bottoming strictness info, unlike other error-ids. -- See Note [aBSENT_ERROR_ID] mkAbsentErrorApp :: Type -- The type to instantiate 'a' -> String -- The string to print -> CoreExpr mkAbsentErrorApp res_ty err_msg = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ] where err_string = Lit (mkLitString err_msg) ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/MkId.hs0000644000000000000000000020350613713635744020614 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1998 This module contains definitions for the IdInfo for things that have a standard form, namely: - data constructors - record selectors - method and superclass selectors - primitive operations -} {-# LANGUAGE CPP #-} module MkId ( mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, mkPrimOpId, mkFCallId, unwrapNewTypeBody, wrapFamInstBody, DataConBoxer(..), mkDataConRep, mkDataConWorkId, -- And some particular Ids; see below for why they are wired in wiredInIds, ghcPrimIds, unsafeCoerceName, unsafeCoerceId, realWorldPrimId, voidPrimId, voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, coercionTokenId, magicDictId, coerceId, proxyHashId, noinlineId, noinlineIdName, coerceName, -- Re-export error Ids module PrelRules ) where #include "GhclibHsVersions.h" import GhcPrelude import Rules import TysPrim import TysWiredIn import PrelRules import Type import FamInstEnv import Coercion import TcType import MkCore import CoreUtils ( mkCast, mkDefaultCase ) import CoreUnfold import Literal import TyCon import Class import NameSet import Name import PrimOp import ForeignCall import DataCon import Id import IdInfo import Demand import CoreSyn import Unique import UniqSupply import PrelNames import BasicTypes hiding ( SuccessFlag(..) ) import Util import Pair import DynFlags import Outputable import FastString import ListSetOps import Var (VarBndr(Bndr)) import qualified GHC.LanguageExtensions as LangExt import Data.Maybe ( maybeToList ) {- ************************************************************************ * * \subsection{Wired in Ids} * * ************************************************************************ Note [Wired-in Ids] ~~~~~~~~~~~~~~~~~~~ A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId') rather than by looking it up its name in some environment or fetching it from an interface file. There are several reasons why an Id might appear in the wiredInIds: * ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)] * magicIds: see Note [magicIds] * errorIds, defined in coreSyn/MkCore.hs. These error functions (e.g. rUNTIME_ERROR_ID) are wired in because the desugarer generates code that mentions them directly In all cases except ghcPrimIds, there is a definition site in a library module, which may be called (e.g. in higher order situations); but the wired-in version means that the details are never read from that module's interface file; instead, the full definition is right here. Note [ghcPrimIds (aka pseudoops)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The ghcPrimIds * Are exported from GHC.Prim * Can't be defined in Haskell, and hence no Haskell binding site, but have perfectly reasonable unfoldings in Core * Either have a CompulsoryUnfolding (hence always inlined), or of an EvaldUnfolding and void representation (e.g. void#) * Are (or should be) defined in primops.txt.pp as 'pseudoop' Reason: that's how we generate documentation for them Note [magicIds] ~~~~~~~~~~~~~~~ The magicIds * Are exported from GHC.Magic * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs). This definition at least generates Haddock documentation for them. * May or may not have a CompulsoryUnfolding. * But have some special behaviour that can't be done via an unfolding from an interface file -} wiredInIds :: [Id] wiredInIds = magicIds ++ ghcPrimIds ++ errorIds -- Defined in MkCore magicIds :: [Id] -- See Note [magicIds] magicIds = [lazyId, oneShotId, noinlineId] ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] ghcPrimIds = [ realWorldPrimId , voidPrimId , unsafeCoerceId , nullAddrId , seqId , magicDictId , coerceId , proxyHashId ] {- ************************************************************************ * * \subsection{Data constructors} * * ************************************************************************ The wrapper for a constructor is an ordinary top-level binding that evaluates any strict args, unboxes any args that are going to be flattened, and calls the worker. We're going to build a constructor that looks like: data (Data a, C b) => T a b = T1 !a !Int b T1 = /\ a b -> \d1::Data a, d2::C b -> \p q r -> case p of { p -> case q of { q -> Con T1 [a,b] [p,q,r]}} Notice that * d2 is thrown away --- a context in a data decl is used to make sure one *could* construct dictionaries at the site the constructor is used, but the dictionary isn't actually used. * We have to check that we can construct Data dictionaries for the types a and Int. Once we've done that we can throw d1 away too. * We use (case p of q -> ...) to evaluate p, rather than "seq" because all that matters is that the arguments are evaluated. "seq" is very careful to preserve evaluation order, which we don't need to be here. You might think that we could simply give constructors some strictness info, like PrimOps, and let CoreToStg do the let-to-case transformation. But we don't do that because in the case of primops and functions strictness is a *property* not a *requirement*. In the case of constructors we need to do something active to evaluate the argument. Making an explicit case expression allows the simplifier to eliminate it in the (common) case where the constructor arg is already evaluated. Note [Wrappers for data instance tycons] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the case of data instances, the wrapper also applies the coercion turning the representation type into the family instance type to cast the result of the wrapper. For example, consider the declarations data family Map k :: * -> * data instance Map (a, b) v = MapPair (Map a (Pair b v)) The tycon to which the datacon MapPair belongs gets a unique internal name of the form :R123Map, and we call it the representation tycon. In contrast, Map is the family tycon (accessible via tyConFamInst_maybe). A coercion allows you to move between representation and family type. It is accessible from :R123Map via tyConFamilyCoercion_maybe and has kind Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} The wrapper and worker of MapPair get the types -- Wrapper $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v) -- Worker MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v This coercion is conditionally applied by wrapFamInstBody. It's a bit more complicated if the data instance is a GADT as well! data instance T [a] where T1 :: forall b. b -> T [Maybe b] Hence we translate to -- Wrapper $WT1 :: forall b. b -> T [Maybe b] $WT1 b v = T1 (Maybe b) b (Maybe b) v `cast` sym (Co7T (Maybe b)) -- Worker T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c -- Coercion from family type to representation type Co7T a :: T [a] ~ :R7T a Newtype instances through an additional wrinkle into the mix. Consider the following example (adapted from #15318, comment:2): data family T a newtype instance T [a] = MkT [a] Within the newtype instance, there are three distinct types at play: 1. The newtype's underlying type, [a]. 2. The instance's representation type, TList a (where TList is the representation tycon). 3. The family type, T [a]. We need two coercions in order to cast from (1) to (3): (a) A newtype coercion axiom: axiom coTList a :: TList a ~ [a] (Where TList is the representation tycon of the newtype instance.) (b) A data family instance coercion axiom: axiom coT a :: T [a] ~ TList a When we translate the newtype instance to Core, we obtain: -- Wrapper $WMkT :: forall a. [a] -> T [a] $WMkT a x = MkT a x |> Sym (coT a) -- Worker MkT :: forall a. [a] -> TList [a] MkT a x = x |> Sym (coTList a) Unlike for data instances, the worker for a newtype instance is actually an executable function which expands to a cast, but otherwise, the general strategy is essentially the same as for data instances. Also note that we have a wrapper, which is unusual for a newtype, but we make GHC produce one anyway for symmetry with the way data instances are handled. Note [Newtype datacons] ~~~~~~~~~~~~~~~~~~~~~~~ The "data constructor" for a newtype should always be vanilla. At one point this wasn't true, because the newtype arising from class C a => D a looked like newtype T:D a = D:D (C a) so the data constructor for T:C had a single argument, namely the predicate (C a). But now we treat that as an ordinary argument, not part of the theta-type, so all is well. Note [Newtype workers] ~~~~~~~~~~~~~~~~~~~~~~ A newtype does not really have a worker. Instead, newtype constructors just unfold into a cast. But we need *something* for, say, MkAge to refer to. So, we do this: * The Id used as the newtype worker will have a compulsory unfolding to a cast. See Note [Compulsory newtype unfolding] * This Id is labeled as a DataConWrapId. We don't want to use a DataConWorkId, as those have special treatment in the back end. * There is no top-level binding, because the compulsory unfolding means that it will be inlined (to a cast) at every call site. We probably should have a NewtypeWorkId, but these Ids disappear as soon as we desugar anyway, so it seems a step too far. Note [Compulsory newtype unfolding] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Newtype wrappers, just like workers, have compulsory unfoldings. This is needed so that two optimizations involving newtypes have the same effect whether a wrapper is present or not: (1) Case-of-known constructor. See Note [beta-reduction in exprIsConApp_maybe]. (2) Matching against the map/coerce RULE. Suppose we have the RULE {-# RULE "map/coerce" map coerce = ... #-} As described in Note [Getting the map/coerce RULE to work], the occurrence of 'coerce' is transformed into: {-# RULE "map/coerce" forall (c :: T1 ~R# T2). map ((\v -> v) `cast` c) = ... #-} We'd like 'map Age' to match the LHS. For this to happen, Age must be unfolded, otherwise we'll be stuck. This is tested in T16208. It also allows for the posssibility of levity polymorphic newtypes with wrappers (with -XUnliftedNewtypes): newtype N (a :: TYPE r) = MkN a With -XUnliftedNewtypes, this is allowed -- even though MkN is levity- polymorphic. It's OK because MkN evaporates in the compiled code, becoming just a cast. That is, it has a compulsory unfolding. As long as its argument is not levity-polymorphic (which it can't be, according to Note [Levity polymorphism invariants] in CoreSyn), and it's saturated, no levity-polymorphic code ends up in the code generator. The saturation condition is effectively checked by Note [Detecting forced eta expansion] in DsExpr. However, if we make a *wrapper* for a newtype, we get into trouble. The saturation condition is no longer checked (because hasNoBinding returns False) and indeed we generate a forbidden levity-polymorphic binding. The solution is simple, though: just make the newtype wrappers as ephemeral as the newtype workers. In other words, give the wrappers compulsory unfoldings and no bindings. The compulsory unfolding is given in wrap_unf in mkDataConRep, and the lack of a binding happens in TidyPgm.getTyConImplicitBinds, where we say that a newtype has no implicit bindings. ************************************************************************ * * \subsection{Dictionary selectors} * * ************************************************************************ Selecting a field for a dictionary. If there is just one field, then there's nothing to do. Dictionary selectors may get nested forall-types. Thus: class Foo a where op :: forall b. Ord b => a -> b -> b Then the top-level type for op is op :: forall a. Foo a => forall b. Ord b => a -> b -> b -} mkDictSelId :: Name -- Name of one of the *value* selectors -- (dictionary superclass or method) -> Class -> Id mkDictSelId name clas = mkGlobalId (ClassOpId clas) name sel_ty info where tycon = classTyCon clas sel_names = map idName (classAllSelIds clas) new_tycon = isNewTyCon tycon [data_con] = tyConDataCons tycon tyvars = dataConUserTyVarBinders data_con n_ty_args = length tyvars arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name sel_ty = mkForAllTys tyvars $ mkInvisFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ getNth arg_tys val_index base_info = noCafIdInfo `setArityInfo` 1 `setStrictnessInfo` strict_sig `setLevityInfoWithType` sel_ty info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkInlineUnfoldingWithArity 1 (mkDictSelRhs clas val_index) -- See Note [Single-method classes] in TcInstDcls -- for why alwaysInlinePragma | otherwise = base_info `setRuleInfo` mkRuleInfo [rule] -- Add a magic BuiltinRule, but no unfolding -- so that the rule is always available to fire. -- See Note [ClassOp/DFun selection] in TcInstDcls -- This is the built-in rule that goes -- op (dfT d1 d2) ---> opT d1 d2 rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` occNameFS (getOccName name) , ru_fn = name , ru_nargs = n_ty_args + 1 , ru_try = dictSelRule val_index n_ty_args } -- The strictness signature is of the form U(AAAVAAAA) -> T -- where the V depends on which item we are selecting -- It's worth giving one, so that absence info etc is generated -- even if the selector isn't inlined strict_sig = mkClosedStrictSig [arg_dmd] topRes arg_dmd | new_tycon = evalDmd | otherwise = mkManyUsedDmd $ mkProdDmd [ if name == sel_name then evalDmd else absDmd | sel_name <- sel_names ] mkDictSelRhs :: Class -> Int -- 0-indexed selector among (superclasses ++ methods) -> CoreExpr mkDictSelRhs clas val_index = mkLams tyvars (Lam dict_id rhs_body) where tycon = classTyCon clas new_tycon = isNewTyCon tycon [data_con] = tyConDataCons tycon tyvars = dataConUnivTyVars data_con arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses the_arg_id = getNth arg_ids val_index pred = mkClassPred clas (mkTyVarTys tyvars) dict_id = mkTemplateLocal 1 pred arg_ids = mkTemplateLocalsNum 2 arg_tys rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) (Var dict_id) | otherwise = mkSingleAltCase (Var dict_id) dict_id (DataAlt data_con) arg_ids (varToCoreExpr the_arg_id) -- varToCoreExpr needed for equality superclass selectors -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } dictSelRule :: Int -> Arity -> RuleFun -- Tries to persuade the argument to look like a constructor -- application, using exprIsConApp_maybe, and then selects -- from it -- sel_i t1..tk (D t1..tk op1 ... opm) = opi -- dictSelRule val_index n_ty_args _ id_unf _ args | (dict_arg : _) <- drop n_ty_args args , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe id_unf dict_arg = Just (wrapFloats floats $ getNth con_args val_index) | otherwise = Nothing {- ************************************************************************ * * Data constructors * * ************************************************************************ -} mkDataConWorkId :: Name -> DataCon -> Id mkDataConWorkId wkr_name data_con | isNewTyCon tycon = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info -- See Note [Newtype workers] | otherwise = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info where tycon = dataConTyCon data_con -- The representation TyCon wkr_ty = dataConRepType data_con ----------- Workers for data types -------------- alg_wkr_info = noCafIdInfo `setArityInfo` wkr_arity `setStrictnessInfo` wkr_sig `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 `setLevityInfoWithType` wkr_ty -- NB: unboxed tuples have workers, so we can't use -- setNeverLevPoly wkr_arity = dataConRepArity data_con wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con) -- Note [Data-con worker strictness] -- Notice that we do *not* say the worker Id is strict -- even if the data constructor is declared strict -- e.g. data T = MkT !(Int,Int) -- Why? Because the *wrapper* $WMkT is strict (and its unfolding has -- case expressions that do the evals) but the *worker* MkT itself is -- not. If we pretend it is strict then when we see -- case x of y -> MkT y -- the simplifier thinks that y is "sure to be evaluated" (because -- the worker MkT is strict) and drops the case. No, the workerId -- MkT is not strict. -- -- However, the worker does have StrictnessMarks. When the simplifier -- sees a pattern -- case e of MkT x -> ... -- it uses the dataConRepStrictness of MkT to mark x as evaluated; -- but that's fine... dataConRepStrictness comes from the data con -- not from the worker Id. ----------- Workers for newtypes -------------- univ_tvs = dataConUnivTyVars data_con arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo `setArityInfo` 1 -- Arity 1 `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` newtype_unf `setLevityInfoWithType` wkr_ty id_arg1 = mkTemplateLocal 1 (head arg_tys) res_ty_args = mkTyCoVarTys univ_tvs newtype_unf = ASSERT2( isVanillaDataCon data_con && isSingleton arg_tys , ppr data_con ) -- Note [Newtype datacons] mkCompulsoryUnfolding $ mkLams univ_tvs $ Lam id_arg1 $ wrapNewTypeBody tycon res_ty_args (Var id_arg1) dataConCPR :: DataCon -> DmdResult dataConCPR con | isDataTyCon tycon -- Real data types only; that is, -- not unboxed tuples or newtypes , null (dataConExTyCoVars con) -- No existentials , wkr_arity > 0 , wkr_arity <= mAX_CPR_SIZE = if is_prod then vanillaCprProdRes (dataConRepArity con) else cprSumRes (dataConTag con) | otherwise = topRes where is_prod = isProductTyCon tycon tycon = dataConTyCon con wkr_arity = dataConRepArity con mAX_CPR_SIZE :: Arity mAX_CPR_SIZE = 10 -- We do not treat very big tuples as CPR-ish: -- a) for a start we get into trouble because there aren't -- "enough" unboxed tuple types (a tiresome restriction, -- but hard to fix), -- b) more importantly, big unboxed tuples get returned mainly -- on the stack, and are often then allocated in the heap -- by the caller. So doing CPR for them may in fact make -- things worse. {- ------------------------------------------------- -- Data constructor representation -- -- This is where we decide how to wrap/unwrap the -- constructor fields -- -------------------------------------------------- -} type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) -- Unbox: bind rep vars by decomposing src var data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr)) -- Box: build src arg using these rep vars -- | Data Constructor Boxer newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind])) -- Bind these src-level vars, returning the -- rep-level vars to bind in the pattern {- Note [Inline partially-applied constructor wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We allow the wrapper to inline when partially applied to avoid boxing values unnecessarily. For example, consider data Foo a = Foo !Int a instance Traversable Foo where traverse f (Foo i a) = Foo i <$> f a This desugars to traverse f foo = case foo of Foo i# a -> let i = I# i# in map ($WFoo i) (f a) If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`. But if we inline the wrapper, we get map (\a. case i of I# i# a -> Foo i# a) (f a) and now case-of-known-constructor eliminates the redundant allocation. -} mkDataConRep :: DynFlags -> FamInstEnvs -> Name -> Maybe [HsImplBang] -- See Note [Bangs on imported data constructors] -> DataCon -> UniqSM DataConRep mkDataConRep dflags fam_envs wrap_name mb_bangs data_con | not wrapper_reqd = return NoDataConRep | otherwise = do { wrap_args <- mapM newLocal wrap_arg_tys ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) initial_wrap_app ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info wrap_info = noCafIdInfo `setArityInfo` wrap_arity -- It's important to specify the arity, so that partial -- applications are treated as values `setInlinePragInfo` wrap_prag `setUnfoldingInfo` wrap_unf `setStrictnessInfo` wrap_sig -- We need to get the CAF info right here because TidyPgm -- does not tidy the IdInfo of implicit bindings (like the wrapper) -- so it not make sure that the CAF info is sane `setLevityInfoWithType` wrap_ty wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con) wrap_arg_dmds = replicate (length theta) topDmd ++ map mk_dmd arg_ibangs -- Don't forget the dictionary arguments when building -- the strictness signature (#14290). mk_dmd str | isBanged str = evalDmd | otherwise = topDmd wrap_prag = alwaysInlinePragma `setInlinePragmaActivation` activeDuringFinal -- See Note [Activation for data constructor wrappers] -- The wrapper will usually be inlined (see wrap_unf), so its -- strictness and CPR info is usually irrelevant. But this is -- not always the case; GHC may choose not to inline it. In -- particular, the wrapper constructor is not inlined inside -- an INLINE rhs or when it is not applied to any arguments. -- See Note [Inline partially-applied constructor wrappers] -- Passing Nothing here allows the wrapper to inline when -- unsaturated. wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs -- See Note [Compulsory newtype unfolding] | otherwise = mkInlineUnfolding wrap_rhs wrap_rhs = mkLams wrap_tvs $ mkLams wrap_args $ wrapFamInstBody tycon res_ty_args $ wrap_body ; return (DCR { dcr_wrap_id = wrap_id , dcr_boxer = mk_boxer boxers , dcr_arg_tys = rep_tys , dcr_stricts = rep_strs -- For newtypes, dcr_bangs is always [HsLazy]. -- See Note [HsImplBangs for newtypes]. , dcr_bangs = arg_ibangs }) } where (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) = dataConFullSig data_con wrap_tvs = dataConUserTyVars data_con res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs tycon = dataConTyCon data_con -- The representation TyCon (not family) wrap_ty = dataConUserType data_con ev_tys = eqSpecPreds eq_spec ++ theta all_arg_tys = ev_tys ++ orig_arg_tys ev_ibangs = map (const HsLazy) ev_tys orig_bangs = dataConSrcBangs data_con wrap_arg_tys = theta ++ orig_arg_tys wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys -- The wrap_args are the arguments *other than* the eq_spec -- Because we are going to apply the eq_spec args manually in the -- wrapper new_tycon = isNewTyCon tycon arg_ibangs | new_tycon = ASSERT( isSingleton orig_arg_tys ) [HsLazy] -- See Note [HsImplBangs for newtypes] | otherwise = case mb_bangs of Nothing -> zipWith (dataConSrcToImplBang dflags fam_envs) orig_arg_tys orig_bangs Just bangs -> bangs (rep_tys_w_strs, wrappers) = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs)) (unboxers, boxers) = unzip wrappers (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) wrapper_reqd = (not new_tycon -- (Most) newtypes have only a worker, with the exception -- of some newtypes written with GADT syntax. See below. && (any isBanged (ev_ibangs ++ arg_ibangs) -- Some forcing/unboxing (includes eq_spec) || (not $ null eq_spec))) -- GADT || isFamInstTyCon tycon -- Cast result || dataConUserTyVarsArePermuted data_con -- If the data type was written with GADT syntax and -- orders the type variables differently from what the -- worker expects, it needs a data con wrapper to reorder -- the type variables. -- See Note [Data con wrappers and GADT syntax]. initial_wrap_app = Var (dataConWorkId data_con) `mkTyApps` res_ty_args `mkVarApps` ex_tvs `mkCoApps` map (mkReflCo Nominal . eqSpecType) eq_spec mk_boxer :: [Boxer] -> DataConBoxer mk_boxer boxers = DCB (\ ty_args src_vars -> do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars subst1 = zipTvSubst univ_tvs ty_args subst2 = extendTCvSubstList subst1 ex_tvs (mkTyCoVarTys ex_vars) ; (rep_ids, binds) <- go subst2 boxers term_vars ; return (ex_vars ++ rep_ids, binds) } ) go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], []) go subst (UnitBox : boxers) (src_var : src_vars) = do { (rep_ids2, binds) <- go subst boxers src_vars ; return (src_var : rep_ids2, binds) } go subst (Boxer boxer : boxers) (src_var : src_vars) = do { (rep_ids1, arg) <- boxer subst ; (rep_ids2, binds) <- go subst boxers src_vars ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) } go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con) mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr mk_rep_app [] con_app = return con_app mk_rep_app ((wrap_arg, unboxer) : prs) con_app = do { (rep_ids, unbox_fn) <- unboxer wrap_arg ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids) ; return (unbox_fn expr) } {- Note [Activation for data constructor wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Activation on a data constructor wrapper allows it to inline only in Phase 0. This way rules have a chance to fire if they mention a data constructor on the left RULE "foo" f (K a b) = ... Since the LHS of rules are simplified with InitialPhase, we won't inline the wrapper on the LHS either. On the other hand, this means that exprIsConApp_maybe must be able to deal with wrappers so that case-of-constructor is not delayed; see Note [exprIsConApp_maybe on data constructors with wrappers] for details. It used to activate in phases 2 (afterInitial) and later, but it makes it awkward to write a RULE[1] with a constructor on the left: it would work if a constructor has no wrapper, but whether a constructor has a wrapper depends, for instance, on the order of type argument of that constructors. Therefore changing the order of type argument could make previously working RULEs fail. See also https://gitlab.haskell.org/ghc/ghc/issues/15840 . Note [Bangs on imported data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs from imported modules. - Nothing <=> use HsSrcBangs - Just bangs <=> use HsImplBangs For imported types we can't work it all out from the HsSrcBangs, because we want to be very sure to follow what the original module (where the data type was declared) decided, and that depends on what flags were enabled when it was compiled. So we record the decisions in the interface file. The HsImplBangs passed are in 1-1 correspondence with the dataConOrigArgTys of the DataCon. Note [Data con wrappers and unlifted types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T = MkT !Int# We certainly do not want to make a wrapper $WMkT x = case x of y { DEFAULT -> MkT y } For a start, it's still to generate a no-op. But worse, since wrappers are currently injected at TidyCore, we don't even optimise it away! So the stupid case expression stays there. This actually happened for the Integer data type (see #1600 comment:66)! Note [Data con wrappers and GADT syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider these two very similar data types: data T1 a b = MkT1 b data T2 a b where MkT2 :: forall b a. b -> T2 a b Despite their similar appearance, T2 will have a data con wrapper but T1 will not. What sets them apart? The types of their constructors, which are: MkT1 :: forall a b. b -> T1 a b MkT2 :: forall b a. b -> T2 a b MkT2's use of GADT syntax allows it to permute the order in which `a` and `b` would normally appear. See Note [DataCon user type variable binders] in DataCon for further discussion on this topic. The worker data cons for T1 and T2, however, both have types such that `a` is expected to come before `b` as arguments. Because MkT2 permutes this order, it needs a data con wrapper to swizzle around the type variables to be in the order the worker expects. A somewhat surprising consequence of this is that *newtypes* can have data con wrappers! After all, a newtype can also be written with GADT syntax: newtype T3 a b where MkT3 :: forall b a. b -> T3 a b Again, this needs a wrapper data con to reorder the type variables. It does mean that this newtype constructor requires another level of indirection when being called, but the inliner should make swift work of that. Note [HsImplBangs for newtypes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Most of the time, we use the dataConSrctoImplBang function to decide what strictness/unpackedness to use for the fields of a data type constructor. But there is an exception to this rule: newtype constructors. You might not think that newtypes would pose a challenge, since newtypes are seemingly forbidden from having strictness annotations in the first place. But consider this (from #16141): {-# LANGUAGE StrictData #-} {-# OPTIONS_GHC -O #-} newtype T a b where MkT :: forall b a. Int -> T a b Because StrictData (plus optimization) is enabled, invoking dataConSrcToImplBang would sneak in and unpack the field of type Int to Int#! This would be disastrous, since the wrapper for `MkT` uses a coercion involving Int, not Int#. Bottom line: dataConSrcToImplBang should never be invoked for newtypes. In the case of a newtype constructor, we simply hardcode its dcr_bangs field to [HsLazy]. -} ------------------------- newLocal :: Type -> UniqSM Var newLocal ty = do { uniq <- getUniqueM ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) } -- | Unpack/Strictness decisions from source module. -- -- This function should only ever be invoked for data constructor fields, and -- never on the field of a newtype constructor. -- See @Note [HsImplBangs for newtypes]@. dataConSrcToImplBang :: DynFlags -> FamInstEnvs -> Type -> HsSrcBang -> HsImplBang dataConSrcToImplBang dflags fam_envs arg_ty (HsSrcBang ann unpk NoSrcStrict) | xopt LangExt.StrictData dflags -- StrictData => strict field = dataConSrcToImplBang dflags fam_envs arg_ty (HsSrcBang ann unpk SrcStrict) | otherwise -- no StrictData => lazy field = HsLazy dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy) = HsLazy dataConSrcToImplBang dflags fam_envs arg_ty (HsSrcBang _ unpk_prag SrcStrict) | isUnliftedType arg_ty = HsLazy -- For !Int#, say, use HsLazy -- See Note [Data con wrappers and unlifted types] | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas -- Don't unpack if we aren't optimising; rather arbitrarily, -- we use -fomit-iface-pragmas as the indication , let mb_co = topNormaliseType_maybe fam_envs arg_ty -- Unwrap type families and newtypes arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty } , isUnpackableType dflags fam_envs arg_ty' , (rep_tys, _) <- dataConArgUnpack arg_ty' , case unpk_prag of NoSrcUnpack -> gopt Opt_UnboxStrictFields dflags || (gopt Opt_UnboxSmallStrictFields dflags && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields] srcUnpack -> isSrcUnpacked srcUnpack = case mb_co of Nothing -> HsUnpack Nothing Just (co,_) -> HsUnpack (Just co) | otherwise -- Record the strict-but-no-unpack decision = HsStrict -- | Wrappers/Workers and representation following Unpack/Strictness -- decisions dataConArgRep :: Type -> HsImplBang -> ([(Type,StrictnessMark)] -- Rep types ,(Unboxer,Boxer)) dataConArgRep arg_ty HsLazy = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) dataConArgRep arg_ty HsStrict = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) dataConArgRep arg_ty (HsUnpack Nothing) | (rep_tys, wrappers) <- dataConArgUnpack arg_ty = (rep_tys, wrappers) dataConArgRep _ (HsUnpack (Just co)) | let co_rep_ty = pSnd (coercionKind co) , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty = (rep_tys, wrapCo co co_rep_ty wrappers) ------------------------- wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer) wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty = (unboxer, boxer) where unboxer arg_id = do { rep_id <- newLocal rep_ty ; (rep_ids, rep_fn) <- unbox_rep rep_id ; let co_bind = NonRec rep_id (Var arg_id `Cast` co) ; return (rep_ids, Let co_bind . rep_fn) } boxer = Boxer $ \ subst -> do { (rep_ids, rep_expr) <- case box_rep of UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty) ; return ([rep_id], Var rep_id) } Boxer boxer -> boxer subst ; let sco = substCoUnchecked subst co ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } ------------------------ seqUnboxer :: Unboxer seqUnboxer v = return ([v], mkDefaultCase (Var v) v) unitUnboxer :: Unboxer unitUnboxer v = return ([v], \e -> e) unitBoxer :: Boxer unitBoxer = UnitBox ------------------------- dataConArgUnpack :: Type -> ( [(Type, StrictnessMark)] -- Rep types , (Unboxer, Boxer) ) dataConArgUnpack arg_ty | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty , Just con <- tyConSingleAlgDataCon_maybe tc -- NB: check for an *algebraic* data type -- A recursive newtype might mean that -- 'arg_ty' is a newtype , let rep_tys = dataConInstArgTys con tc_args = ASSERT( null (dataConExTyCoVars con) ) -- Note [Unpacking GADTs and existentials] ( rep_tys `zip` dataConRepStrictness con ,( \ arg_id -> do { rep_ids <- mapM newLocal rep_tys ; let unbox_fn body = mkSingleAltCase (Var arg_id) arg_id (DataAlt con) rep_ids body ; return (rep_ids, unbox_fn) } , Boxer $ \ subst -> do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys ; return (rep_ids, Var (dataConWorkId con) `mkTyApps` (substTysUnchecked subst tc_args) `mkVarApps` rep_ids ) } ) ) | otherwise = pprPanic "dataConArgUnpack" (ppr arg_ty) -- An interface file specified Unpacked, but we couldn't unpack it isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool -- True if we can unpack the UNPACK the argument type -- See Note [Recursive unboxing] -- We look "deeply" inside rather than relying on the DataCons -- we encounter on the way, because otherwise we might well -- end up relying on ourselves! isUnpackableType dflags fam_envs ty | Just data_con <- unpackable_type ty = ok_con_args emptyNameSet data_con | otherwise = False where ok_con_args dcs con | dc_name `elemNameSet` dcs = False | otherwise = all (ok_arg dcs') (dataConOrigArgTys con `zip` dataConSrcBangs con) -- NB: dataConSrcBangs gives the *user* request; -- We'd get a black hole if we used dataConImplBangs where dc_name = getName con dcs' = dcs `extendNameSet` dc_name ok_arg dcs (ty, bang) = not (attempt_unpack bang) || ok_ty dcs norm_ty where norm_ty = topNormaliseType fam_envs ty ok_ty dcs ty | Just data_con <- unpackable_type ty = ok_con_args dcs data_con | otherwise = True -- NB True here, in contrast to False at top level attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict) = xopt LangExt.StrictData dflags attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict) = True attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict) = True -- Be conservative attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict) = xopt LangExt.StrictData dflags -- Be conservative attempt_unpack _ = False unpackable_type :: Type -> Maybe DataCon -- Works just on a single level unpackable_type ty | Just (tc, _) <- splitTyConApp_maybe ty , Just data_con <- tyConSingleAlgDataCon_maybe tc , null (dataConExTyCoVars data_con) -- See Note [Unpacking GADTs and existentials] = Just data_con | otherwise = Nothing {- Note [Unpacking GADTs and existentials] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There is nothing stopping us unpacking a data type with equality components, like data Equal a b where Equal :: Equal a a And it'd be fine to unpack a product type with existential components too, but that would require a bit more plumbing, so currently we don't. So for now we require: null (dataConExTyCoVars data_con) See #14978 Note [Unpack one-wide fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The flag UnboxSmallStrictFields ensures that any field that can (safely) be unboxed to a word-sized unboxed field, should be so unboxed. For example: data A = A Int# newtype B = B A data C = C !B data D = D !C data E = E !() data F = F !D data G = G !F !F All of these should have an Int# as their representation, except G which should have two Int#s. However data T = T !(S Int) data S = S !a Here we can represent T with an Int#. Note [Recursive unboxing] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data R = MkR {-# UNPACK #-} !S Int data S = MkS {-# UNPACK #-} !Int The representation arguments of MkR are the *representation* arguments of S (plus Int); the rep args of MkS are Int#. This is all fine. But be careful not to try to unbox this! data T = MkT {-# UNPACK #-} !T Int Because then we'd get an infinite number of arguments. Here is a more complicated case: data S = MkS {-# UNPACK #-} !T Int data T = MkT {-# UNPACK #-} !S Int Each of S and T must decide independently whether to unpack and they had better not both say yes. So they must both say no. Also behave conservatively when there is no UNPACK pragma data T = MkS !T Int with -funbox-strict-fields or -funbox-small-strict-fields we need to behave as if there was an UNPACK pragma there. But it's the *argument* type that matters. This is fine: data S = MkS S !Int because Int is non-recursive. ************************************************************************ * * Wrapping and unwrapping newtypes and type families * * ************************************************************************ -} wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -- The wrapper for the data constructor for a newtype looks like this: -- newtype T a = MkT (a,Int) -- MkT :: forall a. (a,Int) -> T a -- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a) -- where CoT is the coercion TyCon associated with the newtype -- -- The call (wrapNewTypeBody T [a] e) returns the -- body of the wrapper, namely -- e `cast` (CoT [a]) -- -- If a coercion constructor is provided in the newtype, then we use -- it, otherwise the wrap/unwrap are both no-ops wrapNewTypeBody tycon args result_expr = ASSERT( isNewTyCon tycon ) mkCast result_expr (mkSymCo co) where co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [] -- When unwrapping, we do *not* apply any family coercion, because this will -- be done via a CoPat by the type checker. We have to do it this way as -- computing the right type arguments for the coercion requires more than just -- a spliting operation (cf, TcPat.tcConPat). unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapNewTypeBody tycon args result_expr = ASSERT( isNewTyCon tycon ) mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []) -- If the type constructor is a representation type of a data instance, wrap -- the expression into a cast adjusting the expression type, which is an -- instance of the representation type, to the corresponding instance of the -- family instance type. -- See Note [Wrappers for data instance tycons] wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr wrapFamInstBody tycon args body | Just co_con <- tyConFamilyCoercion_maybe tycon = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args [])) | otherwise = body {- ************************************************************************ * * \subsection{Primitive operations} * * ************************************************************************ -} mkPrimOpId :: PrimOp -> Id mkPrimOpId prim_op = id where (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op ty = mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty) name = mkWiredInName gHC_PRIM (primOpOcc prim_op) (mkPrimOpIdUnique (primOpTag prim_op)) (AnId id) UserSyntax id = mkGlobalId (PrimOpId prim_op) name ty info info = noCafIdInfo `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) `setArityInfo` arity `setStrictnessInfo` strict_sig `setInlinePragInfo` neverInlinePragma `setLevityInfoWithType` res_ty -- We give PrimOps a NOINLINE pragma so that we don't -- get silly warnings from Desugar.dsRule (the inline_shadows_rule -- test) about a RULE conflicting with a possible inlining -- cf #7287 -- For each ccall we manufacture a separate CCallOpId, giving it -- a fresh unique, a type that is correct for this particular ccall, -- and a CCall structure that gives the correct details about calling -- convention etc. -- -- The *name* of this Id is a local name whose OccName gives the full -- details of the ccall, type and all. This means that the interface -- file reader can reconstruct a suitable Id mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id mkFCallId dflags uniq fcall ty = ASSERT( noFreeVarsOfType ty ) -- A CCallOpId should have no free type variables; -- when doing substitutions won't substitute over it mkGlobalId (FCallId fcall) name ty info where occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty)) -- The "occurrence name" of a ccall is the full info about the -- ccall; it is encoded, but may have embedded spaces etc! name = mkFCallName uniq occ_str info = noCafIdInfo `setArityInfo` arity `setStrictnessInfo` strict_sig `setLevityInfoWithType` ty (bndrs, _) = tcSplitPiTys ty arity = count isAnonTyCoBinder bndrs strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes -- the call does not claim to be strict in its arguments, since they -- may be lifted (foreign import prim) and the called code doesn't -- necessarily force them. See #11076. {- ************************************************************************ * * \subsection{DictFuns and default methods} * * ************************************************************************ Note [Dict funs and default methods] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Dict funs and default methods are *not* ImplicitIds. Their definition involves user-written code, so we can't figure out their strictness etc based on fixed info, as we can for constructors and record selectors (say). NB: See also Note [Exported LocalIds] in Id -} mkDictFunId :: Name -- Name to use for the dict fun; -> [TyVar] -> ThetaType -> Class -> [Type] -> Id -- Implements the DFun Superclass Invariant (see TcInstDcls) -- See Note [Dict funs and default methods] mkDictFunId dfun_name tvs theta clas tys = mkExportedLocalId (DFunId is_nt) dfun_name dfun_ty where is_nt = isNewTyCon (classTyCon clas) dfun_ty = mkDictFunTy tvs theta clas tys mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type mkDictFunTy tvs theta clas tys = mkSpecSigmaTy tvs theta (mkClassPred clas tys) {- ************************************************************************ * * \subsection{Un-definable} * * ************************************************************************ These Ids can't be defined in Haskell. They could be defined in unfoldings in the wired-in GHC.Prim interface file, but we'd have to ensure that they were definitely, definitely inlined, because there is no curried identifier for them. That's what mkCompulsoryUnfolding does. If we had a way to get a compulsory unfolding from an interface file, we could do that, but we don't right now. unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that just gets expanded into a type coercion wherever it occurs. Hence we add it as a built-in Id with an unfolding here. The type variables we use here are "open" type variables: this means they can unify with both unlifted and lifted types. Hence we provide another gun with which to shoot yourself in the foot. -} unsafeCoerceName, nullAddrName, seqName, realWorldName, voidPrimIdName, coercionTokenName, magicDictName, coerceName, proxyName :: Name unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId voidPrimIdName = mkWiredInIdName gHC_PRIM (fsLit "void#") voidPrimIdKey voidPrimId coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId lazyIdName, oneShotName, noinlineIdName :: Name lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId ------------------------------------------------ proxyHashId :: Id proxyHashId = pcMiscPrelId proxyName ty (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] `setNeverLevPoly` ty ) where -- proxy# :: forall {k} (a:k). Proxy# k a -- -- The visibility of the `k` binder is Inferred to match the type of the -- Proxy data constructor (#16293). [kv,tv] = mkTemplateKiTyVars [liftedTypeKind] id kv_ty = mkTyVarTy kv tv_ty = mkTyVarTy tv ty = mkInvForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty ------------------------------------------------ unsafeCoerceId :: Id unsafeCoerceId = pcMiscPrelId unsafeCoerceName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding rhs -- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) -- (a :: TYPE r1) (b :: TYPE r2). -- a -> b bndrs = mkTemplateKiTyVars [runtimeRepTy, runtimeRepTy] (\ks -> map tYPE ks) [_, _, a, b] = mkTyVarTys bndrs ty = mkSpecForAllTys bndrs (mkVisFunTy a b) [x] = mkTemplateLocals [a] rhs = mkLams (bndrs ++ [x]) $ Cast (Var x) (mkUnsafeCo Representational a b) ------------------------------------------------ nullAddrId :: Id -- nullAddr# :: Addr# -- The reason it is here is because we don't provide -- a way to write this literal in Haskell. nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) `setNeverLevPoly` addrPrimTy ------------------------------------------------ seqId :: Id -- See Note [seqId magic] seqId = pcMiscPrelId seqName ty info where info = noCafIdInfo `setInlinePragInfo` inline_prag `setUnfoldingInfo` mkCompulsoryUnfolding rhs inline_prag = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter NoSourceText 0 -- Make 'seq' not inline-always, so that simpleOptExpr -- (see CoreSubst.simple_app) won't inline 'seq' on the -- LHS of rules. That way we can have rules for 'seq'; -- see Note [seqId magic] -- seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b ty = mkInvForAllTy runtimeRep2TyVar $ mkSpecForAllTys [alphaTyVar, openBetaTyVar] $ mkVisFunTy alphaTy (mkVisFunTy openBetaTy openBetaTy) [x,y] = mkTemplateLocals [alphaTy, openBetaTy] rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $ Case (Var x) x openBetaTy [(DEFAULT, [], Var y)] ------------------------------------------------ lazyId :: Id -- See Note [lazyId magic] lazyId = pcMiscPrelId lazyIdName ty info where info = noCafIdInfo `setNeverLevPoly` ty ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) noinlineId :: Id -- See Note [noinlineId magic] noinlineId = pcMiscPrelId noinlineIdName ty info where info = noCafIdInfo `setNeverLevPoly` ty ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) oneShotId :: Id -- See Note [The oneShot function] oneShotId = pcMiscPrelId oneShotName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding rhs ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar , openAlphaTyVar, openBetaTyVar ] (mkVisFunTy fun_ty fun_ty) fun_ty = mkVisFunTy openAlphaTy openBetaTy [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] x' = setOneShotLambda x -- Here is the magic bit! rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar , openAlphaTyVar, openBetaTyVar , body, x'] $ Var body `App` Var x -------------------------------------------------------------------------------- magicDictId :: Id -- See Note [magicDictId magic] magicDictId = pcMiscPrelId magicDictName ty info where info = noCafIdInfo `setInlinePragInfo` neverInlinePragma `setNeverLevPoly` ty ty = mkSpecForAllTys [alphaTyVar] alphaTy -------------------------------------------------------------------------------- coerceId :: Id coerceId = pcMiscPrelId coerceName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding rhs eqRTy = mkTyConApp coercibleTyCon [ tYPE r , a, b ] eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ] ty = mkForAllTys [ Bndr rv Inferred , Bndr av Specified , Bndr bv Specified ] $ mkInvisFunTy eqRTy $ mkVisFunTy a b bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy (\r -> [tYPE r, tYPE r]) [r, a, b] = mkTyVarTys bndrs [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy] rhs = mkLams (bndrs ++ [eqR, x]) $ mkWildCase (Var eqR) eqRTy b $ [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))] {- Note [Unsafe coerce magic] ~~~~~~~~~~~~~~~~~~~~~~~~~~ We define a *primitive* GHC.Prim.unsafeCoerce# and then in the base library we define the ordinary function Unsafe.Coerce.unsafeCoerce :: forall (a:*) (b:*). a -> b unsafeCoerce x = unsafeCoerce# x Notice that unsafeCoerce has a civilized (albeit still dangerous) polymorphic type, whose type args have kind *. So you can't use it on unboxed values (unsafeCoerce 3#). In contrast unsafeCoerce# is even more dangerous because you *can* use it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a: TYPE r1) (b: TYPE r2). a -> b Note [seqId magic] ~~~~~~~~~~~~~~~~~~ 'GHC.Prim.seq' is special in several ways. a) Its fixity is set in LoadIface.ghcPrimIface b) It has quite a bit of desugaring magic. See DsUtils.hs Note [Desugaring seq (1)] and (2) and (3) c) There is some special rule handing: Note [User-defined RULES for seq] Historical note: In TcExpr we used to need a special typing rule for 'seq', to handle calls whose second argument had an unboxed type, e.g. x `seq` 3# However, with levity polymorphism we can now give seq the type seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b which handles this case without special treatment in the typechecker. Note [User-defined RULES for seq] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Roman found situations where he had case (f n) of _ -> e where he knew that f (which was strict in n) would terminate if n did. Notice that the result of (f n) is discarded. So it makes sense to transform to case n of _ -> e Rather than attempt some general analysis to support this, I've added enough support that you can do this using a rewrite rule: RULE "f/seq" forall n. seq (f n) = seq n You write that rule. When GHC sees a case expression that discards its result, it mentally transforms it to a call to 'seq' and looks for a RULE. (This is done in Simplify.trySeqRules.) As usual, the correctness of the rule is up to you. VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2. If we wrote RULE "f/seq" forall n e. seq (f n) e = seq n e with rule arity 2, then two bad things would happen: - The magical desugaring done in Note [seqId magic] item (b) for saturated application of 'seq' would turn the LHS into a case expression! - The code in Simplify.rebuildCase would need to actually supply the value argument, which turns out to be awkward. See also: Note [User-defined RULES for seq] in Simplify. Note [lazyId magic] ~~~~~~~~~~~~~~~~~~~ lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) 'lazy' is used to make sure that a sub-expression, and its free variables, are truly used call-by-need, with no code motion. Key examples: * pseq: pseq a b = a `seq` lazy b We want to make sure that the free vars of 'b' are not evaluated before 'a', even though the expression is plainly strict in 'b'. * catch: catch a b = catch# (lazy a) b Again, it's clear that 'a' will be evaluated strictly (and indeed applied to a state token) but we want to make sure that any exceptions arising from the evaluation of 'a' are caught by the catch (see #11555). Implementing 'lazy' is a bit tricky: * It must not have a strictness signature: by being a built-in Id, all the info about lazyId comes from here, not from GHC.Base.hi. This is important, because the strictness analyser will spot it as strict! * It must not have an unfolding: it gets "inlined" by a HACK in CorePrep. It's very important to do this inlining *after* unfoldings are exposed in the interface file. Otherwise, the unfolding for (say) pseq in the interface file will not mention 'lazy', so if we inline 'pseq' we'll totally miss the very thing that 'lazy' was there for in the first place. See #3259 for a real world example. * Suppose CorePrep sees (catch# (lazy e) b). At all costs we must avoid using call by value here: case e of r -> catch# r b Avoiding that is the whole point of 'lazy'. So in CorePrep (which generate the 'case' expression for a call-by-value call) we must spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let' instead. * lazyId is defined in GHC.Base, so we don't *have* to inline it. If it appears un-applied, we'll end up just calling it. Note [noinlineId magic] ~~~~~~~~~~~~~~~~~~~~~~~ noinline :: forall a. a -> a 'noinline' is used to make sure that a function f is never inlined, e.g., as in 'noinline f x'. Ordinarily, the identity function with NOINLINE could be used to achieve this effect; however, this has the unfortunate result of leaving a (useless) call to noinline at runtime. So we have a little bit of magic to optimize away 'noinline' after we are done running the simplifier. 'noinline' needs to be wired-in because it gets inserted automatically when we serialize an expression to the interface format. See Note [Inlining and hs-boot files] in ToIface Note that noinline as currently implemented can hide some simplifications since it hides strictness from the demand analyser. Specifically, the demand analyser will treat 'noinline f x' as lazy in 'x', even if the demand signature of 'f' specifies that it is strict in its argument. We considered fixing this this by adding a special case to the demand analyser to address #16588. However, the special case seemed like a large and expensive hammer to address a rare case and consequently we rather opted to use a more minimal solution. Note [The oneShot function] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the context of making left-folds fuse somewhat okish (see ticket #7994 and Note [Left folds via right fold]) it was determined that it would be useful if library authors could explicitly tell the compiler that a certain lambda is called at most once. The oneShot function allows that. 'oneShot' is levity-polymorphic, i.e. the type variables can refer to unlifted types as well (#10744); e.g. oneShot (\x:Int# -> x +# 1#) Like most magic functions it has a compulsory unfolding, so there is no need for a real definition somewhere. We have one in GHC.Magic for the convenience of putting the documentation there. It uses `setOneShotLambda` on the lambda's binder. That is the whole magic: A typical call looks like oneShot (\y. e) after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get (\f \x[oneshot]. f x) (\y. e) --> \x[oneshot]. ((\y.e) x) --> \x[oneshot] e[x/y] which is what we want. It is only effective if the one-shot info survives as long as possible; in particular it must make it into the interface in unfoldings. See Note [Preserve OneShotInfo] in CoreTidy. Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot. Note [magicDictId magic] ~~~~~~~~~~~~~~~~~~~~~~~~~ The identifier `magicDict` is just a place-holder, which is used to implement a primitive that we cannot define in Haskell but we can write in Core. It is declared with a place-holder type: magicDict :: forall a. a The intention is that the identifier will be used in a very specific way, to create dictionaries for classes with a single method. Consider a class like this: class C a where f :: T a We are going to use `magicDict`, in conjunction with a built-in Prelude rule, to cast values of type `T a` into dictionaries for `C a`. To do this, we define a function like this in the library: data WrapC a b = WrapC (C a => Proxy a -> b) withT :: (C a => Proxy a -> b) -> T a -> Proxy a -> b withT f x y = magicDict (WrapC f) x y The purpose of `WrapC` is to avoid having `f` instantiated. Also, it avoids impredicativity, because `magicDict`'s type cannot be instantiated with a forall. The field of `WrapC` contains a `Proxy` parameter which is used to link the type of the constraint, `C a`, with the type of the `Wrap` value being made. Next, we add a built-in Prelude rule (see prelude/PrelRules.hs), which will replace the RHS of this definition with the appropriate definition in Core. The rewrite rule works as follows: magicDict @t (wrap @a @b f) x y ----> f (x `cast` co a) y The `co` coercion is the newtype-coercion extracted from the type-class. The type class is obtain by looking at the type of wrap. ------------------------------------------------------------- @realWorld#@ used to be a magic literal, \tr{void#}. If things get nasty as-is, change it back to a literal (@Literal@). voidArgId is a Local Id used simply as an argument in functions where we just want an arg to avoid having a thunk of unlifted type. E.g. x = \ void :: Void# -> (# p, q #) This comes up in strictness analysis Note [evaldUnfoldings] ~~~~~~~~~~~~~~~~~~~~~~ The evaldUnfolding makes it look that some primitive value is evaluated, which in turn makes Simplify.interestingArg return True, which in turn makes INLINE things applied to said value likely to be inlined. -} realWorldPrimId :: Id -- :: State# RealWorld realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] `setOneShotInfo` stateHackOneShot `setNeverLevPoly` realWorldStatePrimTy) voidPrimId :: Id -- Global constant :: Void# voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] `setNeverLevPoly` voidPrimTy) voidArgId :: Id -- Local lambda-bound :: Void# voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy coercionTokenId :: Id -- :: () ~ () coercionTokenId -- See Note [Coercion tokens] in CoreToStg.hs = pcMiscPrelId coercionTokenName (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy]) noCafIdInfo pcMiscPrelId :: Name -> Type -> IdInfo -> Id pcMiscPrelId name ty info = mkVanillaGlobalWithInfo name ty info -- We lie and say the thing is imported; otherwise, we get into -- a mess with dependency analysis; e.g., core2stg may heave in -- random calls to GHCbase.unpackPS__. If GHCbase is the module -- being compiled, then it's just a matter of luck if the definition -- will be in "the right place" to be in scope. ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/Module.hs0000644000000000000000000014020513713635744021211 0ustar0000000000000000{- (c) The University of Glasgow, 2004-2006 Module ~~~~~~~~~~ Simply the name of a module, represented as a FastString. These are Uniquable, hence we can build Maps with Modules as the keys. -} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiParamTypeClasses #-} module Module ( -- * The ModuleName type ModuleName, pprModuleName, moduleNameFS, moduleNameString, moduleNameSlashes, moduleNameColons, moduleStableString, moduleFreeHoles, moduleIsDefinite, mkModuleName, mkModuleNameFS, stableModuleNameCmp, -- * The UnitId type ComponentId(..), UnitId(..), unitIdFS, unitIdKey, IndefUnitId(..), IndefModule(..), indefUnitIdToUnitId, indefModuleToModule, InstalledUnitId(..), toInstalledUnitId, ShHoleSubst, unitIdIsDefinite, unitIdString, unitIdFreeHoles, newUnitId, newIndefUnitId, newSimpleUnitId, hashUnitId, fsToUnitId, stringToUnitId, stableUnitIdCmp, -- * HOLE renaming renameHoleUnitId, renameHoleModule, renameHoleUnitId', renameHoleModule', -- * Generalization splitModuleInsts, splitUnitIdInsts, generalizeIndefUnitId, generalizeIndefModule, -- * Parsers parseModuleName, parseUnitId, parseComponentId, parseModuleId, parseModSubst, -- * Wired-in UnitIds -- $wired_in_packages primUnitId, integerUnitId, baseUnitId, rtsUnitId, thUnitId, mainUnitId, thisGhcUnitId, isHoleModule, interactiveUnitId, isInteractiveModule, wiredInUnitIds, -- * The Module type Module(Module), moduleUnitId, moduleName, pprModule, mkModule, mkHoleModule, stableModuleCmp, HasModule(..), ContainsModule(..), -- * Installed unit ids and modules InstalledModule(..), InstalledModuleEnv, installedModuleEq, installedUnitIdEq, installedUnitIdString, fsToInstalledUnitId, componentIdToInstalledUnitId, stringToInstalledUnitId, emptyInstalledModuleEnv, lookupInstalledModuleEnv, extendInstalledModuleEnv, filterInstalledModuleEnv, delInstalledModuleEnv, DefUnitId(..), -- * The ModuleLocation type ModLocation(..), addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn, addBootSuffixLocnOut, -- * Module mappings ModuleEnv, elemModuleEnv, extendModuleEnv, extendModuleEnvList, extendModuleEnvList_C, plusModuleEnv_C, delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv, lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv, moduleEnvKeys, moduleEnvElts, moduleEnvToList, unitModuleEnv, isEmptyModuleEnv, extendModuleEnvWith, filterModuleEnv, -- * ModuleName mappings ModuleNameEnv, DModuleNameEnv, -- * Sets of Modules ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, extendModuleSetList, delModuleSet, elemModuleSet, intersectModuleSet, minusModuleSet, unionModuleSet, unitModuleSet ) where import GhcPrelude import Outputable import Unique import UniqFM import UniqDFM import UniqDSet import FastString import Binary import Util import Data.List (sortBy, sort) import Data.Ord import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..)) import Fingerprint import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS.Char8 import Encoding import qualified Text.ParserCombinators.ReadP as Parse import Text.ParserCombinators.ReadP (ReadP, (<++)) import Data.Char (isAlphaNum) import Control.DeepSeq import Data.Coerce import Data.Data import Data.Function import Data.Map (Map) import Data.Set (Set) import qualified Data.Map as Map import qualified Data.Set as Set import qualified FiniteMap as Map import System.FilePath import {-# SOURCE #-} DynFlags (DynFlags) import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap, displayInstalledUnitId) -- Note [The identifier lexicon] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Unit IDs, installed package IDs, ABI hashes, package names, -- versions, there are a *lot* of different identifiers for closely -- related things. What do they all mean? Here's what. (See also -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/packages/concepts ) -- -- THE IMPORTANT ONES -- -- ComponentId: An opaque identifier provided by Cabal, which should -- uniquely identify such things as the package name, the package -- version, the name of the component, the hash of the source code -- tarball, the selected Cabal flags, GHC flags, direct dependencies of -- the component. These are very similar to InstalledPackageId, but -- an 'InstalledPackageId' implies that it identifies a package, while -- a package may install multiple components with different -- 'ComponentId's. -- - Same as Distribution.Package.ComponentId -- -- UnitId/InstalledUnitId: A ComponentId + a mapping from hole names -- (ModuleName) to Modules. This is how the compiler identifies instantiated -- components, and also is the main identifier by which GHC identifies things. -- - When Backpack is not being used, UnitId = ComponentId. -- this means a useful fiction for end-users is that there are -- only ever ComponentIds, and some ComponentIds happen to have -- more information (UnitIds). -- - Same as Language.Haskell.TH.Syntax:PkgName, see -- https://gitlab.haskell.org/ghc/ghc/issues/10279 -- - The same as PackageKey in GHC 7.10 (we renamed it because -- they don't necessarily identify packages anymore.) -- - Same as -this-package-key/-package-name flags -- - An InstalledUnitId corresponds to an actual package which -- we have installed on disk. It could be definite or indefinite, -- but if it's indefinite, it has nothing instantiated (we -- never install partially instantiated units.) -- -- Module/InstalledModule: A UnitId/InstalledUnitId + ModuleName. This is how -- the compiler identifies modules (e.g. a Name is a Module + OccName) -- - Same as Language.Haskell.TH.Syntax:Module -- -- THE LESS IMPORTANT ONES -- -- PackageName: The "name" field in a Cabal file, something like "lens". -- - Same as Distribution.Package.PackageName -- - DIFFERENT FROM Language.Haskell.TH.Syntax:PkgName, see -- https://gitlab.haskell.org/ghc/ghc/issues/10279 -- - DIFFERENT FROM -package-name flag -- - DIFFERENT FROM the 'name' field in an installed package -- information. This field could more accurately be described -- as a munged package name: when it's for the main library -- it is the same as the package name, but if it's an internal -- library it's a munged combination of the package name and -- the component name. -- -- LEGACY ONES -- -- InstalledPackageId: This is what we used to call ComponentId. -- It's a still pretty useful concept for packages that have only -- one library; in that case the logical InstalledPackageId = -- ComponentId. Also, the Cabal nix-local-build continues to -- compute an InstalledPackageId which is then forcibly used -- for all components in a package. This means that if a dependency -- from one component in a package changes, the InstalledPackageId -- changes: you don't get as fine-grained dependency tracking, -- but it means your builds are hermetic. Eventually, Cabal will -- deal completely in components and we can get rid of this. -- -- PackageKey: This is what we used to call UnitId. We ditched -- "Package" from the name when we realized that you might want to -- assign different "PackageKeys" to components from the same package. -- (For a brief, non-released period of time, we also called these -- UnitKeys). {- ************************************************************************ * * \subsection{Module locations} * * ************************************************************************ -} -- | Module Location -- -- Where a module lives on the file system: the actual locations -- of the .hs, .hi and .o files, if we have them data ModLocation = ModLocation { ml_hs_file :: Maybe FilePath, -- The source file, if we have one. Package modules -- probably don't have source files. ml_hi_file :: FilePath, -- Where the .hi file is, whether or not it exists -- yet. Always of form foo.hi, even if there is an -- hi-boot file (we add the -boot suffix later) ml_obj_file :: FilePath, -- Where the .o file is, whether or not it exists yet. -- (might not exist either because the module hasn't -- been compiled yet, or because it is part of a -- package with a .a file) ml_hie_file :: FilePath } deriving Show instance Outputable ModLocation where ppr = text . show {- For a module in another package, the hs_file and obj_file components of ModLocation are undefined. The locations specified by a ModLocation may or may not correspond to actual files yet: for example, even if the object file doesn't exist, the ModLocation still contains the path to where the object file will reside if/when it is created. -} addBootSuffix :: FilePath -> FilePath -- ^ Add the @-boot@ suffix to .hs, .hi and .o files addBootSuffix path = path ++ "-boot" addBootSuffix_maybe :: Bool -> FilePath -> FilePath -- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@ addBootSuffix_maybe is_boot path | is_boot = addBootSuffix path | otherwise = path addBootSuffixLocn :: ModLocation -> ModLocation -- ^ Add the @-boot@ suffix to all file paths associated with the module addBootSuffixLocn locn = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) , ml_hi_file = addBootSuffix (ml_hi_file locn) , ml_obj_file = addBootSuffix (ml_obj_file locn) , ml_hie_file = addBootSuffix (ml_hie_file locn) } addBootSuffixLocnOut :: ModLocation -> ModLocation -- ^ Add the @-boot@ suffix to all output file paths associated with the -- module, not including the input file itself addBootSuffixLocnOut locn = locn { ml_hi_file = addBootSuffix (ml_hi_file locn) , ml_obj_file = addBootSuffix (ml_obj_file locn) , ml_hie_file = addBootSuffix (ml_hie_file locn) } {- ************************************************************************ * * \subsection{The name of a module} * * ************************************************************************ -} -- | A ModuleName is essentially a simple string, e.g. @Data.List@. newtype ModuleName = ModuleName FastString instance Uniquable ModuleName where getUnique (ModuleName nm) = getUnique nm instance Eq ModuleName where nm1 == nm2 = getUnique nm1 == getUnique nm2 instance Ord ModuleName where nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2 instance Outputable ModuleName where ppr = pprModuleName instance Binary ModuleName where put_ bh (ModuleName fs) = put_ bh fs get bh = do fs <- get bh; return (ModuleName fs) instance BinaryStringRep ModuleName where fromStringRep = mkModuleNameFS . mkFastStringByteString toStringRep = bytesFS . moduleNameFS instance Data ModuleName where -- don't traverse? toConstr _ = abstractConstr "ModuleName" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "ModuleName" instance NFData ModuleName where rnf x = x `seq` () stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering -- ^ Compares module names lexically, rather than by their 'Unique's stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2 pprModuleName :: ModuleName -> SDoc pprModuleName (ModuleName nm) = getPprStyle $ \ sty -> if codeStyle sty then ztext (zEncodeFS nm) else ftext nm moduleNameFS :: ModuleName -> FastString moduleNameFS (ModuleName mod) = mod moduleNameString :: ModuleName -> String moduleNameString (ModuleName mod) = unpackFS mod -- | Get a string representation of a 'Module' that's unique and stable -- across recompilations. -- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal" moduleStableString :: Module -> String moduleStableString Module{..} = "$" ++ unitIdString moduleUnitId ++ "$" ++ moduleNameString moduleName mkModuleName :: String -> ModuleName mkModuleName s = ModuleName (mkFastString s) mkModuleNameFS :: FastString -> ModuleName mkModuleNameFS s = ModuleName s -- |Returns the string version of the module name, with dots replaced by slashes. -- moduleNameSlashes :: ModuleName -> String moduleNameSlashes = dots_to_slashes . moduleNameString where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) -- |Returns the string version of the module name, with dots replaced by colons. -- moduleNameColons :: ModuleName -> String moduleNameColons = dots_to_colons . moduleNameString where dots_to_colons = map (\c -> if c == '.' then ':' else c) {- ************************************************************************ * * \subsection{A fully qualified module} * * ************************************************************************ -} -- | A Module is a pair of a 'UnitId' and a 'ModuleName'. -- -- Module variables (i.e. @@) which can be instantiated to a -- specific module at some later point in time are represented -- with 'moduleUnitId' set to 'holeUnitId' (this allows us to -- avoid having to make 'moduleUnitId' a partial operation.) -- data Module = Module { moduleUnitId :: !UnitId, -- pkg-1.0 moduleName :: !ModuleName -- A.B.C } deriving (Eq, Ord) -- | Calculate the free holes of a 'Module'. If this set is non-empty, -- this module was defined in an indefinite library that had required -- signatures. -- -- If a module has free holes, that means that substitutions can operate on it; -- if it has no free holes, substituting over a module has no effect. moduleFreeHoles :: Module -> UniqDSet ModuleName moduleFreeHoles m | isHoleModule m = unitUniqDSet (moduleName m) | otherwise = unitIdFreeHoles (moduleUnitId m) -- | A 'Module' is definite if it has no free holes. moduleIsDefinite :: Module -> Bool moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles -- | Create a module variable at some 'ModuleName'. -- See Note [Representation of module/name variables] mkHoleModule :: ModuleName -> Module mkHoleModule = mkModule holeUnitId instance Uniquable Module where getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n) instance Outputable Module where ppr = pprModule instance Binary Module where put_ bh (Module p n) = put_ bh p >> put_ bh n get bh = do p <- get bh; n <- get bh; return (Module p n) instance Data Module where -- don't traverse? toConstr _ = abstractConstr "Module" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Module" instance NFData Module where rnf x = x `seq` () -- | This gives a stable ordering, as opposed to the Ord instance which -- gives an ordering based on the 'Unique's of the components, which may -- not be stable from run to run of the compiler. stableModuleCmp :: Module -> Module -> Ordering stableModuleCmp (Module p1 n1) (Module p2 n2) = (p1 `stableUnitIdCmp` p2) `thenCmp` (n1 `stableModuleNameCmp` n2) mkModule :: UnitId -> ModuleName -> Module mkModule = Module pprModule :: Module -> SDoc pprModule mod@(Module p n) = getPprStyle doc where doc sty | codeStyle sty = (if p == mainUnitId then empty -- never qualify the main package in code else ztext (zEncodeFS (unitIdFS p)) <> char '_') <> pprModuleName n | qualModule sty mod = if isHoleModule mod then angleBrackets (pprModuleName n) else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n | otherwise = pprModuleName n class ContainsModule t where extractModule :: t -> Module class HasModule m where getModule :: m Module instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where fromDbModule (DbModule uid mod_name) = mkModule uid mod_name fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name fromDbUnitId (DbUnitId cid insts) = newUnitId cid insts fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid) -- GHC never writes to the database, so it's not needed toDbModule = error "toDbModule: not implemented" toDbUnitId = error "toDbUnitId: not implemented" {- ************************************************************************ * * \subsection{ComponentId} * * ************************************************************************ -} -- | A 'ComponentId' consists of the package name, package version, component -- ID, the transitive dependencies of the component, and other information to -- uniquely identify the source code and build configuration of a component. -- -- This used to be known as an 'InstalledPackageId', but a package can contain -- multiple components and a 'ComponentId' uniquely identifies a component -- within a package. When a package only has one component, the 'ComponentId' -- coincides with the 'InstalledPackageId' newtype ComponentId = ComponentId FastString deriving (Eq, Ord) instance BinaryStringRep ComponentId where fromStringRep = ComponentId . mkFastStringByteString toStringRep (ComponentId s) = bytesFS s instance Uniquable ComponentId where getUnique (ComponentId n) = getUnique n instance Outputable ComponentId where ppr cid@(ComponentId fs) = getPprStyle $ \sty -> sdocWithDynFlags $ \dflags -> case componentIdString dflags cid of Just str | not (debugStyle sty) -> text str _ -> ftext fs {- ************************************************************************ * * \subsection{UnitId} * * ************************************************************************ -} -- | A unit identifier identifies a (possibly partially) instantiated -- library. It is primarily used as part of 'Module', which in turn -- is used in 'Name', which is used to give names to entities when -- typechecking. -- -- There are two possible forms for a 'UnitId'. It can be a -- 'DefiniteUnitId', in which case we just have a string that uniquely -- identifies some fully compiled, installed library we have on disk. -- However, when we are typechecking a library with missing holes, -- we may need to instantiate a library on the fly (in which case -- we don't have any on-disk representation.) In that case, you -- have an 'IndefiniteUnitId', which explicitly records the -- instantiation, so that we can substitute over it. data UnitId = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId | DefiniteUnitId {-# UNPACK #-} !DefUnitId unitIdFS :: UnitId -> FastString unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x unitIdKey :: UnitId -> Unique unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x -- | A unit identifier which identifies an indefinite -- library (with holes) that has been *on-the-fly* instantiated -- with a substitution 'indefUnitIdInsts'. In fact, an indefinite -- unit identifier could have no holes, but we haven't gotten -- around to compiling the actual library yet. -- -- An indefinite unit identifier pretty-prints to something like -- @p[H=,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the -- brackets enclose the module substitution). data IndefUnitId = IndefUnitId { -- | A private, uniquely identifying representation of -- a UnitId. This string is completely private to GHC -- and is just used to get a unique; in particular, we don't use it for -- symbols (indefinite libraries are not compiled). indefUnitIdFS :: FastString, -- | Cached unique of 'unitIdFS'. indefUnitIdKey :: Unique, -- | The component identity of the indefinite library that -- is being instantiated. indefUnitIdComponentId :: !ComponentId, -- | The sorted (by 'ModuleName') instantiations of this library. indefUnitIdInsts :: ![(ModuleName, Module)], -- | A cache of the free module variables of 'unitIdInsts'. -- This lets us efficiently tell if a 'UnitId' has been -- fully instantiated (free module variables are empty) -- and whether or not a substitution can have any effect. indefUnitIdFreeHoles :: UniqDSet ModuleName } instance Eq IndefUnitId where u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2 instance Ord IndefUnitId where u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2 instance Binary IndefUnitId where put_ bh indef = do put_ bh (indefUnitIdComponentId indef) put_ bh (indefUnitIdInsts indef) get bh = do cid <- get bh insts <- get bh let fs = hashUnitId cid insts return IndefUnitId { indefUnitIdComponentId = cid, indefUnitIdInsts = insts, indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), indefUnitIdFS = fs, indefUnitIdKey = getUnique fs } -- | Create a new 'IndefUnitId' given an explicit module substitution. newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId newIndefUnitId cid insts = IndefUnitId { indefUnitIdComponentId = cid, indefUnitIdInsts = sorted_insts, indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), indefUnitIdFS = fs, indefUnitIdKey = getUnique fs } where fs = hashUnitId cid sorted_insts sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts -- | Injects an 'IndefUnitId' (indefinite library which -- was on-the-fly instantiated) to a 'UnitId' (either -- an indefinite or definite library). indefUnitIdToUnitId :: DynFlags -> IndefUnitId -> UnitId indefUnitIdToUnitId dflags iuid = -- NB: suppose that we want to compare the indefinite -- unit id p[H=impl:H] against p+abcd (where p+abcd -- happens to be the existing, installed version of -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] -- IndefiniteUnitId, they won't compare equal; only -- after improvement will the equality hold. improveUnitId (getPackageConfigMap dflags) $ IndefiniteUnitId iuid data IndefModule = IndefModule { indefModuleUnitId :: IndefUnitId, indefModuleName :: ModuleName } deriving (Eq, Ord) instance Outputable IndefModule where ppr (IndefModule uid m) = ppr uid <> char ':' <> ppr m -- | Injects an 'IndefModule' to 'Module' (see also -- 'indefUnitIdToUnitId'. indefModuleToModule :: DynFlags -> IndefModule -> Module indefModuleToModule dflags (IndefModule iuid mod_name) = mkModule (indefUnitIdToUnitId dflags iuid) mod_name -- | An installed unit identifier identifies a library which has -- been installed to the package database. These strings are -- provided to us via the @-this-unit-id@ flag. The library -- in question may be definite or indefinite; if it is indefinite, -- none of the holes have been filled (we never install partially -- instantiated libraries.) Put another way, an installed unit id -- is either fully instantiated, or not instantiated at all. -- -- Installed unit identifiers look something like @p+af23SAj2dZ219@, -- or maybe just @p@ if they don't use Backpack. newtype InstalledUnitId = InstalledUnitId { -- | The full hashed unit identifier, including the component id -- and the hash. installedUnitIdFS :: FastString } instance Binary InstalledUnitId where put_ bh (InstalledUnitId fs) = put_ bh fs get bh = do fs <- get bh; return (InstalledUnitId fs) instance BinaryStringRep InstalledUnitId where fromStringRep bs = InstalledUnitId (mkFastStringByteString bs) -- GHC doesn't write to database toStringRep = error "BinaryStringRep InstalledUnitId: not implemented" instance Eq InstalledUnitId where uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2 instance Ord InstalledUnitId where u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2 instance Uniquable InstalledUnitId where getUnique = installedUnitIdKey instance Outputable InstalledUnitId where ppr uid@(InstalledUnitId fs) = getPprStyle $ \sty -> sdocWithDynFlags $ \dflags -> case displayInstalledUnitId dflags uid of Just str | not (debugStyle sty) -> text str _ -> ftext fs installedUnitIdKey :: InstalledUnitId -> Unique installedUnitIdKey = getUnique . installedUnitIdFS -- | Lossy conversion to the on-disk 'InstalledUnitId' for a component. toInstalledUnitId :: UnitId -> InstalledUnitId toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid toInstalledUnitId (IndefiniteUnitId indef) = componentIdToInstalledUnitId (indefUnitIdComponentId indef) installedUnitIdString :: InstalledUnitId -> String installedUnitIdString = unpackFS . installedUnitIdFS instance Outputable IndefUnitId where ppr uid = -- getPprStyle $ \sty -> ppr cid <> (if not (null insts) -- pprIf then brackets (hcat (punctuate comma $ [ ppr modname <> text "=" <> ppr m | (modname, m) <- insts])) else empty) where cid = indefUnitIdComponentId uid insts = indefUnitIdInsts uid -- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'. data InstalledModule = InstalledModule { installedModuleUnitId :: !InstalledUnitId, installedModuleName :: !ModuleName } deriving (Eq, Ord) instance Outputable InstalledModule where ppr (InstalledModule p n) = ppr p <> char ':' <> pprModuleName n fsToInstalledUnitId :: FastString -> InstalledUnitId fsToInstalledUnitId fs = InstalledUnitId fs componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId componentIdToInstalledUnitId (ComponentId fs) = fsToInstalledUnitId fs stringToInstalledUnitId :: String -> InstalledUnitId stringToInstalledUnitId = fsToInstalledUnitId . mkFastString -- | Test if a 'Module' corresponds to a given 'InstalledModule', -- modulo instantiation. installedModuleEq :: InstalledModule -> Module -> Bool installedModuleEq imod mod = fst (splitModuleInsts mod) == imod -- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId', -- modulo instantiation. installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool installedUnitIdEq iuid uid = fst (splitUnitIdInsts uid) == iuid -- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that -- it only refers to a definite library; i.e., one we have generated -- code for. newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId } deriving (Eq, Ord) instance Outputable DefUnitId where ppr (DefUnitId uid) = ppr uid instance Binary DefUnitId where put_ bh (DefUnitId uid) = put_ bh uid get bh = do uid <- get bh; return (DefUnitId uid) -- | A map keyed off of 'InstalledModule' newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt) emptyInstalledModuleEnv :: InstalledModuleEnv a emptyInstalledModuleEnv = InstalledModuleEnv Map.empty lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e) filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a filterInstalledModuleEnv f (InstalledModuleEnv e) = InstalledModuleEnv (Map.filterWithKey f e) delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e) -- Note [UnitId to InstalledUnitId improvement] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Just because a UnitId is definite (has no holes) doesn't -- mean it's necessarily a InstalledUnitId; it could just be -- that over the course of renaming UnitIds on the fly -- while typechecking an indefinite library, we -- ended up with a fully instantiated unit id with no hash, -- since we haven't built it yet. This is fine. -- -- However, if there is a hashed unit id for this instantiation -- in the package database, we *better use it*, because -- that hashed unit id may be lurking in another interface, -- and chaos will ensue if we attempt to compare the two -- (the unitIdFS for a UnitId never corresponds to a Cabal-provided -- hash of a compiled instantiated library). -- -- There is one last niggle: improvement based on the package database means -- that we might end up developing on a package that is not transitively -- depended upon by the packages the user specified directly via command line -- flags. This could lead to strange and difficult to understand bugs if those -- instantiations are out of date. The solution is to only improve a -- unit id if the new unit id is part of the 'preloadClosure'; i.e., the -- closure of all the packages which were explicitly specified. -- | Retrieve the set of free holes of a 'UnitId'. unitIdFreeHoles :: UnitId -> UniqDSet ModuleName unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x -- Hashed unit ids are always fully instantiated unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet instance Show UnitId where show = unitIdString -- | A 'UnitId' is definite if it has no free holes. unitIdIsDefinite :: UnitId -> Bool unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles -- | Generate a uniquely identifying 'FastString' for a unit -- identifier. This is a one-way function. You can rely on one special -- property: if a unit identifier is in most general form, its 'FastString' -- coincides with its 'ComponentId'. This hash is completely internal -- to GHC and is not used for symbol names or file paths. hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString hashUnitId cid sorted_holes = mkFastStringByteString . fingerprintUnitId (toStringRep cid) $ rawHashUnitId sorted_holes -- | Generate a hash for a sorted module substitution. rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint rawHashUnitId sorted_holes = fingerprintByteString . BS.concat $ do (m, b) <- sorted_holes [ toStringRep m, BS.Char8.singleton ' ', bytesFS (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':', toStringRep (moduleName b), BS.Char8.singleton '\n'] fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString fingerprintUnitId prefix (Fingerprint a b) = BS.concat $ [ prefix , BS.Char8.singleton '-' , BS.Char8.pack (toBase62Padded a) , BS.Char8.pack (toBase62Padded b) ] -- | Create a new, un-hashed unit identifier. newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug... newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts pprUnitId :: UnitId -> SDoc pprUnitId (DefiniteUnitId uid) = ppr uid pprUnitId (IndefiniteUnitId uid) = ppr uid instance Eq UnitId where uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2 instance Uniquable UnitId where getUnique = unitIdKey instance Ord UnitId where nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2 instance Data UnitId where -- don't traverse? toConstr _ = abstractConstr "UnitId" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "UnitId" instance NFData UnitId where rnf x = x `seq` () stableUnitIdCmp :: UnitId -> UnitId -> Ordering -- ^ Compares package ids lexically, rather than by their 'Unique's stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2 instance Outputable UnitId where ppr pk = pprUnitId pk -- Performance: would prefer to have a NameCache like thing instance Binary UnitId where put_ bh (DefiniteUnitId def_uid) = do putByte bh 0 put_ bh def_uid put_ bh (IndefiniteUnitId indef_uid) = do putByte bh 1 put_ bh indef_uid get bh = do b <- getByte bh case b of 0 -> fmap DefiniteUnitId (get bh) _ -> fmap IndefiniteUnitId (get bh) instance Binary ComponentId where put_ bh (ComponentId fs) = put_ bh fs get bh = do { fs <- get bh; return (ComponentId fs) } -- | Create a new simple unit identifier (no holes) from a 'ComponentId'. newSimpleUnitId :: ComponentId -> UnitId newSimpleUnitId (ComponentId fs) = fsToUnitId fs -- | Create a new simple unit identifier from a 'FastString'. Internally, -- this is primarily used to specify wired-in unit identifiers. fsToUnitId :: FastString -> UnitId fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId stringToUnitId :: String -> UnitId stringToUnitId = fsToUnitId . mkFastString unitIdString :: UnitId -> String unitIdString = unpackFS . unitIdFS {- ************************************************************************ * * Hole substitutions * * ************************************************************************ -} -- | Substitution on module variables, mapping module names to module -- identifiers. type ShHoleSubst = ModuleNameEnv Module -- | Substitutes holes in a 'Module'. NOT suitable for being called -- directly on a 'nameModule', see Note [Representation of module/name variable]. -- @p[A=]:B@ maps to @p[A=q():A]:B@ with @A=q():A@; -- similarly, @@ maps to @q():A@. renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module renameHoleModule dflags = renameHoleModule' (getPackageConfigMap dflags) -- | Substitutes holes in a 'UnitId', suitable for renaming when -- an include occurs; see Note [Representation of module/name variable]. -- -- @p[A=]@ maps to @p[A=]@ with @A=@. renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId renameHoleUnitId dflags = renameHoleUnitId' (getPackageConfigMap dflags) -- | Like 'renameHoleModule', but requires only 'PackageConfigMap' -- so it can be used by "Packages". renameHoleModule' :: PackageConfigMap -> ShHoleSubst -> Module -> Module renameHoleModule' pkg_map env m | not (isHoleModule m) = let uid = renameHoleUnitId' pkg_map env (moduleUnitId m) in mkModule uid (moduleName m) | Just m' <- lookupUFM env (moduleName m) = m' -- NB m = , that's what's in scope. | otherwise = m -- | Like 'renameHoleUnitId, but requires only 'PackageConfigMap' -- so it can be used by "Packages". renameHoleUnitId' :: PackageConfigMap -> ShHoleSubst -> UnitId -> UnitId renameHoleUnitId' pkg_map env uid = case uid of (IndefiniteUnitId IndefUnitId{ indefUnitIdComponentId = cid , indefUnitIdInsts = insts , indefUnitIdFreeHoles = fh }) -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) then uid -- Functorially apply the substitution to the instantiation, -- then check the 'PackageConfigMap' to see if there is -- a compiled version of this 'UnitId' we can improve to. -- See Note [UnitId to InstalledUnitId] improvement else improveUnitId pkg_map $ newUnitId cid (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) _ -> uid -- | Given a possibly on-the-fly instantiated module, split it into -- a 'Module' that we definitely can find on-disk, as well as an -- instantiation if we need to instantiate it on the fly. If the -- instantiation is @Nothing@ no on-the-fly renaming is needed. splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule) splitModuleInsts m = let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m) in (InstalledModule uid (moduleName m), fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid) -- | See 'splitModuleInsts'. splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId) splitUnitIdInsts (IndefiniteUnitId iuid) = (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid) splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing) generalizeIndefUnitId :: IndefUnitId -> IndefUnitId generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid , indefUnitIdInsts = insts } = newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts) generalizeIndefModule :: IndefModule -> IndefModule generalizeIndefModule (IndefModule uid n) = IndefModule (generalizeIndefUnitId uid) n parseModuleName :: ReadP ModuleName parseModuleName = fmap mkModuleName $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") parseUnitId :: ReadP UnitId parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId where parseFullUnitId = do cid <- parseComponentId insts <- parseModSubst return (newUnitId cid insts) parseDefiniteUnitId = do s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") return (stringToUnitId s) parseSimpleUnitId = do cid <- parseComponentId return (newSimpleUnitId cid) parseComponentId :: ReadP ComponentId parseComponentId = (ComponentId . mkFastString) `fmap` Parse.munch1 abi_char where abi_char c = isAlphaNum c || c `elem` "-_." parseModuleId :: ReadP Module parseModuleId = parseModuleVar <++ parseModule where parseModuleVar = do _ <- Parse.char '<' modname <- parseModuleName _ <- Parse.char '>' return (mkHoleModule modname) parseModule = do uid <- parseUnitId _ <- Parse.char ':' modname <- parseModuleName return (mkModule uid modname) parseModSubst :: ReadP [(ModuleName, Module)] parseModSubst = Parse.between (Parse.char '[') (Parse.char ']') . flip Parse.sepBy (Parse.char ',') $ do k <- parseModuleName _ <- Parse.char '=' v <- parseModuleId return (k, v) {- Note [Wired-in packages] ~~~~~~~~~~~~~~~~~~~~~~~~ Certain packages are known to the compiler, in that we know about certain entities that reside in these packages, and the compiler needs to declare static Modules and Names that refer to these packages. Hence the wired-in packages can't include version numbers in their package UnitId, since we don't want to bake the version numbers of these packages into GHC. So here's the plan. Wired-in packages are still versioned as normal in the packages database, and you can still have multiple versions of them installed. To the user, everything looks normal. However, for each invocation of GHC, only a single instance of each wired-in package will be recognised (the desired one is selected via @-package@\/@-hide-package@), and GHC will internall pretend that it has the *unversioned* 'UnitId', including in .hi files and object file symbols. Unselected versions of wired-in packages will be ignored, as will any other package that depends directly or indirectly on it (much as if you had used @-ignore-package@). The affected packages are compiled with, e.g., @-this-unit-id base@, so that the symbols in the object files have the unversioned unit id in their name. Make sure you change 'Packages.findWiredInPackages' if you add an entry here. For `integer-gmp`/`integer-simple` we also change the base name to `integer-wired-in`, but this is fundamentally no different. See Note [The integer library] in PrelNames. -} integerUnitId, primUnitId, baseUnitId, rtsUnitId, thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId primUnitId = fsToUnitId (fsLit "ghc-prim") integerUnitId = fsToUnitId (fsLit "integer-wired-in") -- See Note [The integer library] in PrelNames baseUnitId = fsToUnitId (fsLit "base") rtsUnitId = fsToUnitId (fsLit "rts") thUnitId = fsToUnitId (fsLit "template-haskell") thisGhcUnitId = fsToUnitId (fsLit "ghc") interactiveUnitId = fsToUnitId (fsLit "interactive") -- | This is the package Id for the current program. It is the default -- package Id if you don't specify a package name. We don't add this prefix -- to symbol names, since there can be only one main package per program. mainUnitId = fsToUnitId (fsLit "main") -- | This is a fake package id used to provide identities to any un-implemented -- signatures. The set of hole identities is global over an entire compilation. -- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead. -- See Note [Representation of module/name variables] holeUnitId :: UnitId holeUnitId = fsToUnitId (fsLit "hole") isInteractiveModule :: Module -> Bool isInteractiveModule mod = moduleUnitId mod == interactiveUnitId -- Note [Representation of module/name variables] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- In our ICFP'16, we use to represent module holes, and {A.T} to represent -- name holes. This could have been represented by adding some new cases -- to the core data types, but this would have made the existing 'nameModule' -- and 'moduleUnitId' partial, which would have required a lot of modifications -- to existing code. -- -- Instead, we adopted the following encoding scheme: -- -- ===> hole:A -- {A.T} ===> hole:A.T -- -- This encoding is quite convenient, but it is also a bit dangerous too, -- because if you have a 'hole:A' you need to know if it's actually a -- 'Module' or just a module stored in a 'Name'; these two cases must be -- treated differently when doing substitutions. 'renameHoleModule' -- and 'renameHoleUnitId' assume they are NOT operating on a -- 'Name'; 'NameShape' handles name substitutions exclusively. isHoleModule :: Module -> Bool isHoleModule mod = moduleUnitId mod == holeUnitId wiredInUnitIds :: [UnitId] wiredInUnitIds = [ primUnitId, integerUnitId, baseUnitId, rtsUnitId, thUnitId, thisGhcUnitId ] {- ************************************************************************ * * \subsection{@ModuleEnv@s} * * ************************************************************************ -} -- | A map keyed off of 'Module's newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) {- Note [ModuleEnv performance and determinism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To prevent accidental reintroduction of nondeterminism the Ord instance for Module was changed to not depend on Unique ordering and to use the lexicographic order. This is potentially expensive, but when measured there was no difference in performance. To be on the safe side and not pessimize ModuleEnv uses nondeterministic ordering on Module and normalizes by doing the lexicographic sort when turning the env to a list. See Note [Unique Determinism] for more information about the source of nondeterminismand and Note [Deterministic UniqFM] for explanation of why it matters for maps. -} newtype NDModule = NDModule { unNDModule :: Module } deriving Eq -- A wrapper for Module with faster nondeterministic Ord. -- Don't export, See [ModuleEnv performance and determinism] instance Ord NDModule where compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) = (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp` (getUnique n1 `nonDetCmpUnique` getUnique n2) filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a filterModuleEnv f (ModuleEnv e) = ModuleEnv (Map.filterWithKey (f . unNDModule) e) elemModuleEnv :: Module -> ModuleEnv a -> Bool elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e) extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a extendModuleEnvWith f (ModuleEnv e) m x = ModuleEnv (Map.insertWith f (NDModule m) x e) extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a extendModuleEnvList (ModuleEnv e) xs = ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e) extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)] -> ModuleEnv a extendModuleEnvList_C f (ModuleEnv e) xs = ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e) plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.unionWith f e1 e2) delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a delModuleEnvList (ModuleEnv e) ms = ModuleEnv (Map.deleteList (map NDModule ms) e) delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e) plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2) lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a lookupWithDefaultModuleEnv (ModuleEnv e) x m = Map.findWithDefault x (NDModule m) e mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e) mkModuleEnv :: [(Module, a)] -> ModuleEnv a mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs]) emptyModuleEnv :: ModuleEnv a emptyModuleEnv = ModuleEnv Map.empty moduleEnvKeys :: ModuleEnv a -> [Module] moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e -- See Note [ModuleEnv performance and determinism] moduleEnvElts :: ModuleEnv a -> [a] moduleEnvElts e = map snd $ moduleEnvToList e -- See Note [ModuleEnv performance and determinism] moduleEnvToList :: ModuleEnv a -> [(Module, a)] moduleEnvToList (ModuleEnv e) = sortBy (comparing fst) [(m, v) | (NDModule m, v) <- Map.toList e] -- See Note [ModuleEnv performance and determinism] unitModuleEnv :: Module -> a -> ModuleEnv a unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x) isEmptyModuleEnv :: ModuleEnv a -> Bool isEmptyModuleEnv (ModuleEnv e) = Map.null e -- | A set of 'Module's type ModuleSet = Set NDModule mkModuleSet :: [Module] -> ModuleSet mkModuleSet = Set.fromList . coerce extendModuleSet :: ModuleSet -> Module -> ModuleSet extendModuleSet s m = Set.insert (NDModule m) s extendModuleSetList :: ModuleSet -> [Module] -> ModuleSet extendModuleSetList s ms = foldl' (coerce . flip Set.insert) s ms emptyModuleSet :: ModuleSet emptyModuleSet = Set.empty moduleSetElts :: ModuleSet -> [Module] moduleSetElts = sort . coerce . Set.toList elemModuleSet :: Module -> ModuleSet -> Bool elemModuleSet = Set.member . coerce intersectModuleSet :: ModuleSet -> ModuleSet -> ModuleSet intersectModuleSet = coerce Set.intersection minusModuleSet :: ModuleSet -> ModuleSet -> ModuleSet minusModuleSet = coerce Set.difference delModuleSet :: ModuleSet -> Module -> ModuleSet delModuleSet = coerce (flip Set.delete) unionModuleSet :: ModuleSet -> ModuleSet -> ModuleSet unionModuleSet = coerce Set.union unitModuleSet :: Module -> ModuleSet unitModuleSet = coerce Set.singleton {- A ModuleName has a Unique, so we can build mappings of these using UniqFM. -} -- | A map keyed off of 'ModuleName's (actually, their 'Unique's) type ModuleNameEnv elt = UniqFM elt -- | A map keyed off of 'ModuleName's (actually, their 'Unique's) -- Has deterministic folds and can be deterministically converted to a list type DModuleNameEnv elt = UniqDFM elt ghc-lib-parser-8.10.2.20200808/compiler/utils/MonadUtils.hs0000644000000000000000000002027713713635745021104 0ustar0000000000000000-- | Utilities related to Monad and Applicative classes -- Mostly for backwards compatibility. module MonadUtils ( Applicative(..) , (<$>) , MonadFix(..) , MonadIO(..) , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M , mapAccumLM , mapSndM , concatMapM , mapMaybeM , fmapMaybeM, fmapEitherM , anyM, allM, orM , foldlM, foldlM_, foldrM , maybeMapM , whenM, unlessM , filterOutM ) where ------------------------------------------------------------------------------- -- Imports ------------------------------------------------------------------------------- import GhcPrelude import Control.Applicative import Control.Monad import Control.Monad.Fix import Control.Monad.IO.Class import Data.Foldable (sequenceA_, foldlM, foldrM) import Data.List (unzip4, unzip5, zipWith4) ------------------------------------------------------------------------------- -- Common functions -- These are used throughout the compiler ------------------------------------------------------------------------------- {- Note [Inline @zipWithNM@ functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The inline principle for 'zipWith3M', 'zipWith4M' and 'zipWith3M_' is the same as for 'zipWithM' and 'zipWithM_' in "Control.Monad", see Note [Fusion for zipN/zipWithN] in GHC/List.hs for more details. The 'zipWithM'/'zipWithM_' functions are inlined so that the `zipWith` and `sequenceA` functions with which they are defined have an opportunity to fuse. Furthermore, 'zipWith3M'/'zipWith4M' and 'zipWith3M_' have been explicitly rewritten in a non-recursive way similarly to 'zipWithM'/'zipWithM_', and for more than just uniformity: after [D5241](https://phabricator.haskell.org/D5241) for issue #14037, all @zipN@/@zipWithN@ functions fuse, meaning 'zipWith3M'/'zipWIth4M' and 'zipWith3M_'@ now behave like 'zipWithM' and 'zipWithM_', respectively, with regards to fusion. As such, since there are not any differences between 2-ary 'zipWithM'/ 'zipWithM_' and their n-ary counterparts below aside from the number of arguments, the `INLINE` pragma should be replicated in the @zipWithNM@ functions below as well. -} zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] {-# INLINE zipWith3M #-} -- Inline so that fusion with 'zipWith3' and 'sequenceA' has a chance to fire. -- See Note [Inline @zipWithNM@ functions] above. zipWith3M f xs ys zs = sequenceA (zipWith3 f xs ys zs) zipWith3M_ :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m () {-# INLINE zipWith3M_ #-} -- Inline so that fusion with 'zipWith4' and 'sequenceA' has a chance to fire. -- See Note [Inline @zipWithNM@ functions] above. zipWith3M_ f xs ys zs = sequenceA_ (zipWith3 f xs ys zs) zipWith4M :: Monad m => (a -> b -> c -> d -> m e) -> [a] -> [b] -> [c] -> [d] -> m [e] {-# INLINE zipWith4M #-} -- Inline so that fusion with 'zipWith5' and 'sequenceA' has a chance to fire. -- See Note [Inline @zipWithNM@ functions] above. zipWith4M f xs ys ws zs = sequenceA (zipWith4 f xs ys ws zs) zipWithAndUnzipM :: Monad m => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) {-# INLINABLE zipWithAndUnzipM #-} -- See Note [flatten_many performance] in TcFlatten for why this -- pragma is essential. zipWithAndUnzipM f (x:xs) (y:ys) = do { (c, d) <- f x y ; (cs, ds) <- zipWithAndUnzipM f xs ys ; return (c:cs, d:ds) } zipWithAndUnzipM _ _ _ = return ([], []) {- Note [Inline @mapAndUnzipNM@ functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The inline principle is the same as 'mapAndUnzipM' in "Control.Monad". The 'mapAndUnzipM' function is inlined so that the `unzip` and `traverse` functions with which it is defined have an opportunity to fuse, see Note [Inline @unzipN@ functions] in Data/OldList.hs for more details. Furthermore, the @mapAndUnzipNM@ functions have been explicitly rewritten in a non-recursive way similarly to 'mapAndUnzipM', and for more than just uniformity: after [D5249](https://phabricator.haskell.org/D5249) for Trac ticket #14037, all @unzipN@ functions fuse, meaning 'mapAndUnzip3M', 'mapAndUnzip4M' and 'mapAndUnzip5M' now behave like 'mapAndUnzipM' with regards to fusion. As such, since there are not any differences between 2-ary 'mapAndUnzipM' and its n-ary counterparts below aside from the number of arguments, the `INLINE` pragma should be replicated in the @mapAndUnzipNM@ functions below as well. -} -- | mapAndUnzipM for triples mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d]) {-# INLINE mapAndUnzip3M #-} -- Inline so that fusion with 'unzip3' and 'traverse' has a chance to fire. -- See Note [Inline @mapAndUnzipNM@ functions] above. mapAndUnzip3M f xs = unzip3 <$> traverse f xs mapAndUnzip4M :: Monad m => (a -> m (b,c,d,e)) -> [a] -> m ([b],[c],[d],[e]) {-# INLINE mapAndUnzip4M #-} -- Inline so that fusion with 'unzip4' and 'traverse' has a chance to fire. -- See Note [Inline @mapAndUnzipNM@ functions] above. mapAndUnzip4M f xs = unzip4 <$> traverse f xs mapAndUnzip5M :: Monad m => (a -> m (b,c,d,e,f)) -> [a] -> m ([b],[c],[d],[e],[f]) {-# INLINE mapAndUnzip5M #-} -- Inline so that fusion with 'unzip5' and 'traverse' has a chance to fire. -- See Note [Inline @mapAndUnzipNM@ functions] above. mapAndUnzip5M f xs = unzip5 <$> traverse f xs -- | Monadic version of mapAccumL mapAccumLM :: Monad m => (acc -> x -> m (acc, y)) -- ^ combining function -> acc -- ^ initial state -> [x] -- ^ inputs -> m (acc, [y]) -- ^ final state, outputs mapAccumLM _ s [] = return (s, []) mapAccumLM f s (x:xs) = do (s1, x') <- f s x (s2, xs') <- mapAccumLM f s1 xs return (s2, x' : xs') -- | Monadic version of mapSnd mapSndM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] mapSndM _ [] = return [] mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) } -- | Monadic version of concatMap concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f xs = liftM concat (mapM f xs) -- | Applicative version of mapMaybe mapMaybeM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM f = foldr g (pure []) where g a = liftA2 (maybe id (:)) (f a) -- | Monadic version of fmap fmapMaybeM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b) fmapMaybeM _ Nothing = return Nothing fmapMaybeM f (Just x) = f x >>= (return . Just) -- | Monadic version of fmap fmapEitherM :: Monad m => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d) fmapEitherM fl _ (Left a) = fl a >>= (return . Left) fmapEitherM _ fr (Right b) = fr b >>= (return . Right) -- | Monadic version of 'any', aborts the computation at the first @True@ value anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool anyM _ [] = return False anyM f (x:xs) = do b <- f x if b then return True else anyM f xs -- | Monad version of 'all', aborts the computation at the first @False@ value allM :: Monad m => (a -> m Bool) -> [a] -> m Bool allM _ [] = return True allM f (b:bs) = (f b) >>= (\bv -> if bv then allM f bs else return False) -- | Monadic version of or orM :: Monad m => m Bool -> m Bool -> m Bool orM m1 m2 = m1 >>= \x -> if x then return True else m2 -- | Monadic version of foldl that discards its result foldlM_ :: (Monad m, Foldable t) => (a -> b -> m a) -> a -> t b -> m () foldlM_ = foldM_ -- | Monadic version of fmap specialised for Maybe maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) maybeMapM _ Nothing = return Nothing maybeMapM m (Just x) = liftM Just $ m x -- | Monadic version of @when@, taking the condition in the monad whenM :: Monad m => m Bool -> m () -> m () whenM mb thing = do { b <- mb ; when b thing } -- | Monadic version of @unless@, taking the condition in the monad unlessM :: Monad m => m Bool -> m () -> m () unlessM condM acc = do { cond <- condM ; unless cond acc } -- | Like 'filterM', only it reverses the sense of the test. filterOutM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] filterOutM p = foldr (\ x -> liftA2 (\ flg -> if flg then id else (x:)) (p x)) (pure []) ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/Name.hs0000644000000000000000000006574213713635744020660 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[Name]{@Name@: to transmit name info from renamer to typechecker} -} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} -- | -- #name_types# -- GHC uses several kinds of name internally: -- -- * 'OccName.OccName': see "OccName#name_types" -- -- * 'RdrName.RdrName': see "RdrName#name_types" -- -- * 'Name.Name' is the type of names that have had their scoping and binding resolved. They -- have an 'OccName.OccName' but also a 'Unique.Unique' that disambiguates Names that have -- the same 'OccName.OccName' and indeed is used for all 'Name.Name' comparison. Names -- also contain information about where they originated from, see "Name#name_sorts" -- -- * 'Id.Id': see "Id#name_types" -- -- * 'Var.Var': see "Var#name_types" -- -- #name_sorts# -- Names are one of: -- -- * External, if they name things declared in other modules. Some external -- Names are wired in, i.e. they name primitives defined in the compiler itself -- -- * Internal, if they name things in the module being compiled. Some internal -- Names are system names, if they are names manufactured by the compiler module Name ( -- * The main types Name, -- Abstract BuiltInSyntax(..), -- ** Creating 'Name's mkSystemName, mkSystemNameAt, mkInternalName, mkClonedInternalName, mkDerivedInternalName, mkSystemVarName, mkSysTvName, mkFCallName, mkExternalName, mkWiredInName, -- ** Manipulating and deconstructing 'Name's nameUnique, setNameUnique, nameOccName, nameNameSpace, nameModule, nameModule_maybe, setNameLoc, tidyNameOcc, localiseName, nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, -- ** Predicates on 'Name's isSystemName, isInternalName, isExternalName, isTyVarName, isTyConName, isDataConName, isValName, isVarName, isWiredInName, isBuiltInSyntax, isHoleName, wiredInNameTyThing_maybe, nameIsLocalOrFrom, nameIsHomePackage, nameIsHomePackageImport, nameIsFromExternalPackage, stableNameCmp, -- * Class 'NamedThing' and overloaded friends NamedThing(..), getSrcLoc, getSrcSpan, getOccString, getOccFS, pprInfixName, pprPrefixName, pprModulePrefix, pprNameUnqualified, nameStableString, -- Re-export the OccName stuff module OccName ) where import GhcPrelude import {-# SOURCE #-} TyCoRep( TyThing ) import OccName import Module import SrcLoc import Unique import Util import Maybes import Binary import DynFlags import FastString import Outputable import Control.DeepSeq import Data.Data {- ************************************************************************ * * \subsection[Name-datatype]{The @Name@ datatype, and name construction} * * ************************************************************************ -} -- | A unique, unambiguous name for something, containing information about where -- that thing originated. data Name = Name { n_sort :: NameSort, -- What sort of name it is n_occ :: !OccName, -- Its occurrence name n_uniq :: {-# UNPACK #-} !Unique, n_loc :: !SrcSpan -- Definition site } -- NOTE: we make the n_loc field strict to eliminate some potential -- (and real!) space leaks, due to the fact that we don't look at -- the SrcLoc in a Name all that often. -- See Note [About the NameSorts] data NameSort = External Module | WiredIn Module TyThing BuiltInSyntax -- A variant of External, for wired-in things | Internal -- A user-defined Id or TyVar -- defined in the module being compiled | System -- A system-defined Id or TyVar. Typically the -- OccName is very uninformative (like 's') instance Outputable NameSort where ppr (External _) = text "external" ppr (WiredIn _ _ _) = text "wired-in" ppr Internal = text "internal" ppr System = text "system" instance NFData Name where rnf Name{..} = rnf n_sort instance NFData NameSort where rnf (External m) = rnf m rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` () -- XXX this is a *lie*, we're not going to rnf the TyThing, but -- since the TyThings for WiredIn Names are all static they can't -- be hiding space leaks or errors. rnf Internal = () rnf System = () -- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples, -- which have special syntactic forms. They aren't in scope -- as such. data BuiltInSyntax = BuiltInSyntax | UserSyntax {- Note [About the NameSorts] 1. Initially, top-level Ids (including locally-defined ones) get External names, and all other local Ids get Internal names 2. In any invocation of GHC, an External Name for "M.x" has one and only one unique. This unique association is ensured via the Name Cache; see Note [The Name Cache] in IfaceEnv. 3. Things with a External name are given C static labels, so they finally appear in the .o file's symbol table. They appear in the symbol table in the form M.n. If originally-local things have this property they must be made @External@ first. 4. In the tidy-core phase, a External that is not visible to an importer is changed to Internal, and a Internal that is visible is changed to External 5. A System Name differs in the following ways: a) has unique attached when printing dumps b) unifier eliminates sys tyvars in favour of user provs where possible Before anything gets printed in interface files or output code, it's fed through a 'tidy' processor, which zaps the OccNames to have unique names; and converts all sys-locals to user locals If any desugarer sys-locals have survived that far, they get changed to "ds1", "ds2", etc. Built-in syntax => It's a syntactic form, not "in scope" (e.g. []) Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, not read from an interface file. E.g. Bool, True, Int, Float, and many others All built-in syntax is for wired-in things. -} instance HasOccName Name where occName = nameOccName nameUnique :: Name -> Unique nameOccName :: Name -> OccName nameNameSpace :: Name -> NameSpace nameModule :: HasDebugCallStack => Name -> Module nameSrcLoc :: Name -> SrcLoc nameSrcSpan :: Name -> SrcSpan nameUnique name = n_uniq name nameOccName name = n_occ name nameNameSpace name = occNameSpace (n_occ name) nameSrcLoc name = srcSpanStart (n_loc name) nameSrcSpan name = n_loc name type instance SrcSpanLess Name = Name instance HasSrcSpan Name where composeSrcSpan (L sp n) = n {n_loc = sp} decomposeSrcSpan n = L (n_loc n) n {- ************************************************************************ * * \subsection{Predicates on names} * * ************************************************************************ -} isInternalName :: Name -> Bool isExternalName :: Name -> Bool isSystemName :: Name -> Bool isWiredInName :: Name -> Bool isWiredInName (Name {n_sort = WiredIn _ _ _}) = True isWiredInName _ = False wiredInNameTyThing_maybe :: Name -> Maybe TyThing wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing wiredInNameTyThing_maybe _ = Nothing isBuiltInSyntax :: Name -> Bool isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True isBuiltInSyntax _ = False isExternalName (Name {n_sort = External _}) = True isExternalName (Name {n_sort = WiredIn _ _ _}) = True isExternalName _ = False isInternalName name = not (isExternalName name) isHoleName :: Name -> Bool isHoleName = isHoleModule . nameModule nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr (n_sort name) <+> ppr name) nameModule_maybe :: Name -> Maybe Module nameModule_maybe (Name { n_sort = External mod}) = Just mod nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod nameModule_maybe _ = Nothing nameIsLocalOrFrom :: Module -> Name -> Bool -- ^ Returns True if the name is -- (a) Internal -- (b) External but from the specified module -- (c) External but from the 'interactive' package -- -- The key idea is that -- False means: the entity is defined in some other module -- you can find the details (type, fixity, instances) -- in some interface file -- those details will be stored in the EPT or HPT -- -- True means: the entity is defined in this module or earlier in -- the GHCi session -- you can find details (type, fixity, instances) in the -- TcGblEnv or TcLclEnv -- -- The isInteractiveModule part is because successive interactions of a GHCi session -- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come -- from the magic 'interactive' package; and all the details are kept in the -- TcLclEnv, TcGblEnv, NOT in the HPT or EPT. -- See Note [The interactive package] in HscTypes nameIsLocalOrFrom from name | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod | otherwise = True nameIsHomePackage :: Module -> Name -> Bool -- True if the Name is defined in module of this package nameIsHomePackage this_mod = \nm -> case n_sort nm of External nm_mod -> moduleUnitId nm_mod == this_pkg WiredIn nm_mod _ _ -> moduleUnitId nm_mod == this_pkg Internal -> True System -> False where this_pkg = moduleUnitId this_mod nameIsHomePackageImport :: Module -> Name -> Bool -- True if the Name is defined in module of this package -- /other than/ the this_mod nameIsHomePackageImport this_mod = \nm -> case nameModule_maybe nm of Nothing -> False Just nm_mod -> nm_mod /= this_mod && moduleUnitId nm_mod == this_pkg where this_pkg = moduleUnitId this_mod -- | Returns True if the Name comes from some other package: neither this -- package nor the interactive package. nameIsFromExternalPackage :: UnitId -> Name -> Bool nameIsFromExternalPackage this_pkg name | Just mod <- nameModule_maybe name , moduleUnitId mod /= this_pkg -- Not this package , not (isInteractiveModule mod) -- Not the 'interactive' package = True | otherwise = False isTyVarName :: Name -> Bool isTyVarName name = isTvOcc (nameOccName name) isTyConName :: Name -> Bool isTyConName name = isTcOcc (nameOccName name) isDataConName :: Name -> Bool isDataConName name = isDataOcc (nameOccName name) isValName :: Name -> Bool isValName name = isValOcc (nameOccName name) isVarName :: Name -> Bool isVarName = isVarOcc . nameOccName isSystemName (Name {n_sort = System}) = True isSystemName _ = False {- ************************************************************************ * * \subsection{Making names} * * ************************************************************************ -} -- | Create a name which is (for now at least) local to the current module and hence -- does not need a 'Module' to disambiguate it from other 'Name's mkInternalName :: Unique -> OccName -> SrcSpan -> Name mkInternalName uniq occ loc = Name { n_uniq = uniq , n_sort = Internal , n_occ = occ , n_loc = loc } -- NB: You might worry that after lots of huffing and -- puffing we might end up with two local names with distinct -- uniques, but the same OccName. Indeed we can, but that's ok -- * the insides of the compiler don't care: they use the Unique -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the -- uniques if you get confused -- * for interface files we tidyCore first, which makes -- the OccNames distinct when they need to be mkClonedInternalName :: Unique -> Name -> Name mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc }) = Name { n_uniq = uniq, n_sort = Internal , n_occ = occ, n_loc = loc } mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) = Name { n_uniq = uniq, n_sort = Internal , n_occ = derive_occ occ, n_loc = loc } -- | Create a name which definitely originates in the given module mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name -- WATCH OUT! External Names should be in the Name Cache -- (see Note [The Name Cache] in IfaceEnv), so don't just call mkExternalName -- with some fresh unique without populating the Name Cache mkExternalName uniq mod occ loc = Name { n_uniq = uniq, n_sort = External mod, n_occ = occ, n_loc = loc } -- | Create a name which is actually defined by the compiler itself mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name mkWiredInName mod occ uniq thing built_in = Name { n_uniq = uniq, n_sort = WiredIn mod thing built_in, n_occ = occ, n_loc = wiredInSrcSpan } -- | Create a name brought into being by the compiler mkSystemName :: Unique -> OccName -> Name mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name mkSystemNameAt uniq occ loc = Name { n_uniq = uniq, n_sort = System , n_occ = occ, n_loc = loc } mkSystemVarName :: Unique -> FastString -> Name mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) mkSysTvName :: Unique -> FastString -> Name mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs) -- | Make a name for a foreign call mkFCallName :: Unique -> String -> Name mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan -- The encoded string completely describes the ccall -- When we renumber/rename things, we need to be -- able to change a Name's Unique to match the cached -- one in the thing it's the name of. If you know what I mean. setNameUnique :: Name -> Unique -> Name setNameUnique name uniq = name {n_uniq = uniq} -- This is used for hsigs: we want to use the name of the originally exported -- entity, but edit the location to refer to the reexport site setNameLoc :: Name -> SrcSpan -> Name setNameLoc name loc = name {n_loc = loc} tidyNameOcc :: Name -> OccName -> Name -- We set the OccName of a Name when tidying -- In doing so, we change System --> Internal, so that when we print -- it we don't get the unique by default. It's tidy now! tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal} tidyNameOcc name occ = name { n_occ = occ } -- | Make the 'Name' into an internal name, regardless of what it was to begin with localiseName :: Name -> Name localiseName n = n { n_sort = Internal } {- ************************************************************************ * * \subsection{Hashing and comparison} * * ************************************************************************ -} cmpName :: Name -> Name -> Ordering cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2 -- | Compare Names lexicographically -- This only works for Names that originate in the source code or have been -- tidied. stableNameCmp :: Name -> Name -> Ordering stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) (Name { n_sort = s2, n_occ = occ2 }) = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) -- The ordinary compare on OccNames is lexicographic where -- Later constructors are bigger sort_cmp (External m1) (External m2) = m1 `stableModuleCmp` m2 sort_cmp (External {}) _ = LT sort_cmp (WiredIn {}) (External {}) = GT sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2 sort_cmp (WiredIn {}) _ = LT sort_cmp Internal (External {}) = GT sort_cmp Internal (WiredIn {}) = GT sort_cmp Internal Internal = EQ sort_cmp Internal System = LT sort_cmp System System = EQ sort_cmp System _ = GT {- ************************************************************************ * * \subsection[Name-instances]{Instance declarations} * * ************************************************************************ -} -- | The same comments as for `Name`'s `Ord` instance apply. instance Eq Name where a == b = case (a `compare` b) of { EQ -> True; _ -> False } a /= b = case (a `compare` b) of { EQ -> False; _ -> True } -- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which -- means that the ordering is not stable across deserialization or rebuilds. -- -- See `nonDetCmpUnique` for further information, and trac #15240 for a bug -- caused by improper use of this instance. -- For a deterministic lexicographic ordering, use `stableNameCmp`. instance Ord Name where a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } compare a b = cmpName a b instance Uniquable Name where getUnique = nameUnique instance NamedThing Name where getName n = n instance Data Name where -- don't traverse? toConstr _ = abstractConstr "Name" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Name" {- ************************************************************************ * * \subsection{Binary} * * ************************************************************************ -} -- | Assumes that the 'Name' is a non-binding one. See -- 'IfaceSyn.putIfaceTopBndr' and 'IfaceSyn.getIfaceTopBndr' for serializing -- binding 'Name's. See 'UserData' for the rationale for this distinction. instance Binary Name where put_ bh name = case getUserData bh of UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name get bh = case getUserData bh of UserData { ud_get_name = get_name } -> get_name bh {- ************************************************************************ * * \subsection{Pretty printing} * * ************************************************************************ -} instance Outputable Name where ppr name = pprName name instance OutputableBndr Name where pprBndr _ name = pprName name pprInfixOcc = pprInfixName pprPrefixOcc = pprPrefixName pprName :: Name -> SDoc pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) = getPprStyle $ \ sty -> case sort of WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin External mod -> pprExternal sty uniq mod occ False UserSyntax System -> pprSystem sty uniq occ Internal -> pprInternal sty uniq occ -- | Print the string of Name unqualifiedly directly. pprNameUnqualified :: Name -> SDoc pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc pprExternal sty uniq mod occ is_wired is_builtin | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ -- In code style, always qualify -- ToDo: maybe we could print all wired-in things unqualified -- in code style, to reduce symbol table bloat? | debugStyle sty = pp_mod <> ppr_occ_name occ <> braces (hsep [if is_wired then text "(w)" else empty, pprNameSpaceBrief (occNameSpace occ), pprUnique uniq]) | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax | otherwise = if isHoleModule mod then case qualName sty mod occ of NameUnqual -> ppr_occ_name occ _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ) else pprModulePrefix sty mod occ <> ppr_occ_name occ where pp_mod = sdocWithDynFlags $ \dflags -> if gopt Opt_SuppressModulePrefixes dflags then empty else ppr mod <> dot pprInternal :: PprStyle -> Unique -> OccName -> SDoc pprInternal sty uniq occ | codeStyle sty = pprUniqueAlways uniq | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), pprUnique uniq]) | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq -- For debug dumps, we're not necessarily dumping -- tidied code, so we need to print the uniques. | otherwise = ppr_occ_name occ -- User style -- Like Internal, except that we only omit the unique in Iface style pprSystem :: PprStyle -> Unique -> OccName -> SDoc pprSystem sty uniq occ | codeStyle sty = pprUniqueAlways uniq | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq <> braces (pprNameSpaceBrief (occNameSpace occ)) | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq -- If the tidy phase hasn't run, the OccName -- is unlikely to be informative (like 's'), -- so print the unique pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc -- Print the "M." part of a name, based on whether it's in scope or not -- See Note [Printing original names] in HscTypes pprModulePrefix sty mod occ = sdocWithDynFlags $ \dflags -> if gopt Opt_SuppressModulePrefixes dflags then empty else case qualName sty mod occ of -- See Outputable.QualifyName: NameQual modname -> ppr modname <> dot -- Name is in scope NameNotInScope1 -> ppr mod <> dot -- Not in scope NameNotInScope2 -> ppr (moduleUnitId mod) <> colon -- Module not in <> ppr (moduleName mod) <> dot -- scope either NameUnqual -> empty -- In scope unqualified pprUnique :: Unique -> SDoc -- Print a unique unless we are suppressing them pprUnique uniq = sdocWithDynFlags $ \dflags -> ppUnless (gopt Opt_SuppressUniques dflags) $ pprUniqueAlways uniq ppr_underscore_unique :: Unique -> SDoc -- Print an underscore separating the name from its unique -- But suppress it if we aren't printing the uniques anyway ppr_underscore_unique uniq = sdocWithDynFlags $ \dflags -> ppUnless (gopt Opt_SuppressUniques dflags) $ char '_' <> pprUniqueAlways uniq ppr_occ_name :: OccName -> SDoc ppr_occ_name occ = ftext (occNameFS occ) -- Don't use pprOccName; instead, just print the string of the OccName; -- we print the namespace in the debug stuff above -- In code style, we Z-encode the strings. The results of Z-encoding each FastString are -- cached behind the scenes in the FastString implementation. ppr_z_occ_name :: OccName -> SDoc ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) -- Prints (if mod information is available) "Defined at " or -- "Defined in " information for a Name. pprDefinedAt :: Name -> SDoc pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name pprNameDefnLoc :: Name -> SDoc -- Prints "at " or -- or "in " depending on what info is available pprNameDefnLoc name = case nameSrcLoc name of -- nameSrcLoc rather than nameSrcSpan -- It seems less cluttered to show a location -- rather than a span for the definition point RealSrcLoc s -> text "at" <+> ppr s UnhelpfulLoc s | isInternalName name || isSystemName name -> text "at" <+> ftext s | otherwise -> text "in" <+> quotes (ppr (nameModule name)) -- | Get a string representation of a 'Name' that's unique and stable -- across recompilations. Used for deterministic generation of binds for -- derived instances. -- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal$String" nameStableString :: Name -> String nameStableString Name{..} = nameSortStableString n_sort ++ "$" ++ occNameString n_occ nameSortStableString :: NameSort -> String nameSortStableString System = "$_sys" nameSortStableString Internal = "$_in" nameSortStableString (External mod) = moduleStableString mod nameSortStableString (WiredIn mod _ _) = moduleStableString mod {- ************************************************************************ * * \subsection{Overloaded functions related to Names} * * ************************************************************************ -} -- | A class allowing convenient access to the 'Name' of various datatypes class NamedThing a where getOccName :: a -> OccName getName :: a -> Name getOccName n = nameOccName (getName n) -- Default method instance NamedThing e => NamedThing (Located e) where getName = getName . unLoc getSrcLoc :: NamedThing a => a -> SrcLoc getSrcSpan :: NamedThing a => a -> SrcSpan getOccString :: NamedThing a => a -> String getOccFS :: NamedThing a => a -> FastString getSrcLoc = nameSrcLoc . getName getSrcSpan = nameSrcSpan . getName getOccString = occNameString . getOccName getOccFS = occNameFS . getOccName pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc -- See Outputable.pprPrefixVar, pprInfixVar; -- add parens or back-quotes as appropriate pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) pprPrefixName :: NamedThing a => a -> SDoc pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) where name = getName thing ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/NameCache.hs0000644000000000000000000001003313713635744021563 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} -- | The Name Cache module NameCache ( lookupOrigNameCache , extendOrigNameCache , extendNameCache , initNameCache , NameCache(..), OrigNameCache ) where import GhcPrelude import Module import Name import UniqSupply import TysWiredIn import Util import Outputable import PrelNames #include "GhclibHsVersions.h" {- Note [The Name Cache] ~~~~~~~~~~~~~~~~~~~~~ The Name Cache makes sure that, during any invocation of GHC, each External Name "M.x" has one, and only one globally-agreed Unique. * The first time we come across M.x we make up a Unique and record that association in the Name Cache. * When we come across "M.x" again, we look it up in the Name Cache, and get a hit. The functions newGlobalBinder, allocateGlobalBinder do the main work. When you make an External name, you should probably be calling one of them. Note [Built-in syntax and the OrigNameCache] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower their cost we use two tricks, a. We specially encode tuple and sum Names in interface files' symbol tables to avoid having to look up their names while loading interface files. Namely these names are encoded as by their Uniques. We know how to get from a Unique back to the Name which it represents via the mapping defined in the SumTupleUniques module. See Note [Symbol table representation of names] in BinIface and for details. b. We don't include them in the Orig name cache but instead parse their OccNames (in isBuiltInOcc_maybe) to avoid bloating the name cache with them. Why is the second measure necessary? Good question; afterall, 1) the parser emits built-in syntax directly as Exact RdrNames, and 2) built-in syntax never needs to looked-up during interface loading due to (a). It turns out that there are two reasons why we might look up an Orig RdrName for built-in syntax, * If you use setRdrNameSpace on an Exact RdrName it may be turned into an Orig RdrName. * Template Haskell turns a BuiltInSyntax Name into a TH.NameG (DsMeta.globalVar), and parses a NameG into an Orig RdrName (Convert.thRdrName). So, e.g. $(do { reify '(,); ... }) will go this route (#8954). -} -- | Per-module cache of original 'OccName's given 'Name's type OrigNameCache = ModuleEnv (OccEnv Name) lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name lookupOrigNameCache nc mod occ | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE , Just name <- isBuiltInOcc_maybe occ = -- See Note [Known-key names], 3(c) in PrelNames -- Special case for tuples; there are too many -- of them to pre-populate the original-name cache Just name | otherwise = case lookupModuleEnv nc mod of Nothing -> Nothing Just occ_env -> lookupOccEnv occ_env occ extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache extendOrigNameCache nc name = ASSERT2( isExternalName name, ppr name ) extendNameCache nc (nameModule name) (nameOccName name) name extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache extendNameCache nc mod occ name = extendModuleEnvWith combine nc mod (unitOccEnv occ name) where combine _ occ_env = extendOccEnv occ_env occ name -- | The NameCache makes sure that there is just one Unique assigned for -- each original name; i.e. (module-name, occ-name) pair and provides -- something of a lookup mechanism for those names. data NameCache = NameCache { nsUniqs :: !UniqSupply, -- ^ Supply of uniques nsNames :: !OrigNameCache -- ^ Ensures that one original name gets one unique } -- | Return a function to atomically update the name cache. initNameCache :: UniqSupply -> [Name] -> NameCache initNameCache us names = NameCache { nsUniqs = us, nsNames = initOrigNames names } initOrigNames :: [Name] -> OrigNameCache initOrigNames names = foldl' extendOrigNameCache emptyModuleEnv names ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/NameEnv.hs0000644000000000000000000001371113713635744021316 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[NameEnv]{@NameEnv@: name environments} -} {-# LANGUAGE CPP #-} module NameEnv ( -- * Var, Id and TyVar environments (maps) NameEnv, -- ** Manipulating these environments mkNameEnv, mkNameEnvWith, emptyNameEnv, isEmptyNameEnv, unitNameEnv, nameEnvElts, extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, extendNameEnvList, extendNameEnvList_C, filterNameEnv, anyNameEnv, plusNameEnv, plusNameEnv_C, alterNameEnv, lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, elemNameEnv, mapNameEnv, disjointNameEnv, DNameEnv, emptyDNameEnv, lookupDNameEnv, delFromDNameEnv, filterDNameEnv, mapDNameEnv, adjustDNameEnv, alterDNameEnv, extendDNameEnv, -- ** Dependency analysis depAnal ) where #include "GhclibHsVersions.h" import GhcPrelude import Digraph import Name import UniqFM import UniqDFM import Maybes {- ************************************************************************ * * \subsection{Name environment} * * ************************************************************************ -} {- Note [depAnal determinism] ~~~~~~~~~~~~~~~~~~~~~~~~~~ depAnal is deterministic provided it gets the nodes in a deterministic order. The order of lists that get_defs and get_uses return doesn't matter, as these are only used to construct the edges, and stronglyConnCompFromEdgedVertices is deterministic even when the edges are not in deterministic order as explained in Note [Deterministic SCC] in Digraph. -} depAnal :: (node -> [Name]) -- Defs -> (node -> [Name]) -- Uses -> [node] -> [SCC node] -- Perform dependency analysis on a group of definitions, -- where each definition may define more than one Name -- -- The get_defs and get_uses functions are called only once per node depAnal get_defs get_uses nodes = stronglyConnCompFromEdgedVerticesUniq (map mk_node keyed_nodes) where keyed_nodes = nodes `zip` [(1::Int)..] mk_node (node, key) = DigraphNode node key (mapMaybe (lookupNameEnv key_map) (get_uses node)) key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node] {- ************************************************************************ * * \subsection{Name environment} * * ************************************************************************ -} -- | Name Environment type NameEnv a = UniqFM a -- Domain is Name emptyNameEnv :: NameEnv a isEmptyNameEnv :: NameEnv a -> Bool mkNameEnv :: [(Name,a)] -> NameEnv a mkNameEnvWith :: (a -> Name) -> [a] -> NameEnv a nameEnvElts :: NameEnv a -> [a] alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a delFromNameEnv :: NameEnv a -> Name -> NameEnv a delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a elemNameEnv :: Name -> NameEnv a -> Bool unitNameEnv :: Name -> a -> NameEnv a lookupNameEnv :: NameEnv a -> Name -> Maybe a lookupNameEnv_NF :: NameEnv a -> Name -> a filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt anyNameEnv :: (elt -> Bool) -> NameEnv elt -> Bool mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 disjointNameEnv :: NameEnv a -> NameEnv a -> Bool nameEnvElts x = eltsUFM x emptyNameEnv = emptyUFM isEmptyNameEnv = isNullUFM unitNameEnv x y = unitUFM x y extendNameEnv x y z = addToUFM x y z extendNameEnvList x l = addListToUFM x l lookupNameEnv x y = lookupUFM x y alterNameEnv = alterUFM mkNameEnv l = listToUFM l mkNameEnvWith f = mkNameEnv . map (\a -> (f a, a)) elemNameEnv x y = elemUFM x y plusNameEnv x y = plusUFM x y plusNameEnv_C f x y = plusUFM_C f x y extendNameEnv_C f x y z = addToUFM_C f x y z mapNameEnv f x = mapUFM f x extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b extendNameEnvList_C x y z = addListToUFM_C x y z delFromNameEnv x y = delFromUFM x y delListFromNameEnv x y = delListFromUFM x y filterNameEnv x y = filterUFM x y anyNameEnv f x = foldUFM ((||) . f) False x disjointNameEnv x y = isNullUFM (intersectUFM x y) lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n) -- | Deterministic Name Environment -- -- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need -- DNameEnv. type DNameEnv a = UniqDFM a emptyDNameEnv :: DNameEnv a emptyDNameEnv = emptyUDFM lookupDNameEnv :: DNameEnv a -> Name -> Maybe a lookupDNameEnv = lookupUDFM delFromDNameEnv :: DNameEnv a -> Name -> DNameEnv a delFromDNameEnv = delFromUDFM filterDNameEnv :: (a -> Bool) -> DNameEnv a -> DNameEnv a filterDNameEnv = filterUDFM mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b mapDNameEnv = mapUDFM adjustDNameEnv :: (a -> a) -> DNameEnv a -> Name -> DNameEnv a adjustDNameEnv = adjustUDFM alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a alterDNameEnv = alterUDFM extendDNameEnv :: DNameEnv a -> Name -> a -> DNameEnv a extendDNameEnv = addToUDFM ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/NameSet.hs0000644000000000000000000001603513713635744021323 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1998 -} {-# LANGUAGE CPP #-} module NameSet ( -- * Names set type NameSet, -- ** Manipulating these sets emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets, minusNameSet, elemNameSet, extendNameSet, extendNameSetList, delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet, intersectsNameSet, intersectNameSet, nameSetAny, nameSetAll, nameSetElemsStable, -- * Free variables FreeVars, -- ** Manipulating sets of free variables isEmptyFVs, emptyFVs, plusFVs, plusFV, mkFVs, addOneFV, unitFV, delFV, delFVs, intersectFVs, -- * Defs and uses Defs, Uses, DefUse, DefUses, -- ** Manipulating defs and uses emptyDUs, usesOnly, mkDUs, plusDU, findUses, duDefs, duUses, allUses ) where #include "GhclibHsVersions.h" import GhcPrelude import Name import OrdList import UniqSet import Data.List (sortBy) {- ************************************************************************ * * \subsection[Sets of names} * * ************************************************************************ -} type NameSet = UniqSet Name emptyNameSet :: NameSet unitNameSet :: Name -> NameSet extendNameSetList :: NameSet -> [Name] -> NameSet extendNameSet :: NameSet -> Name -> NameSet mkNameSet :: [Name] -> NameSet unionNameSet :: NameSet -> NameSet -> NameSet unionNameSets :: [NameSet] -> NameSet minusNameSet :: NameSet -> NameSet -> NameSet elemNameSet :: Name -> NameSet -> Bool isEmptyNameSet :: NameSet -> Bool delFromNameSet :: NameSet -> Name -> NameSet delListFromNameSet :: NameSet -> [Name] -> NameSet filterNameSet :: (Name -> Bool) -> NameSet -> NameSet intersectNameSet :: NameSet -> NameSet -> NameSet intersectsNameSet :: NameSet -> NameSet -> Bool -- ^ True if there is a non-empty intersection. -- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty isEmptyNameSet = isEmptyUniqSet emptyNameSet = emptyUniqSet unitNameSet = unitUniqSet mkNameSet = mkUniqSet extendNameSetList = addListToUniqSet extendNameSet = addOneToUniqSet unionNameSet = unionUniqSets unionNameSets = unionManyUniqSets minusNameSet = minusUniqSet elemNameSet = elementOfUniqSet delFromNameSet = delOneFromUniqSet filterNameSet = filterUniqSet intersectNameSet = intersectUniqSets delListFromNameSet set ns = foldl' delFromNameSet set ns intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2)) nameSetAny :: (Name -> Bool) -> NameSet -> Bool nameSetAny = uniqSetAny nameSetAll :: (Name -> Bool) -> NameSet -> Bool nameSetAll = uniqSetAll -- | Get the elements of a NameSet with some stable ordering. -- This only works for Names that originate in the source code or have been -- tidied. -- See Note [Deterministic UniqFM] to learn about nondeterminism nameSetElemsStable :: NameSet -> [Name] nameSetElemsStable ns = sortBy stableNameCmp $ nonDetEltsUniqSet ns -- It's OK to use nonDetEltsUniqSet here because we immediately sort -- with stableNameCmp {- ************************************************************************ * * \subsection{Free variables} * * ************************************************************************ These synonyms are useful when we are thinking of free variables -} type FreeVars = NameSet plusFV :: FreeVars -> FreeVars -> FreeVars addOneFV :: FreeVars -> Name -> FreeVars unitFV :: Name -> FreeVars emptyFVs :: FreeVars plusFVs :: [FreeVars] -> FreeVars mkFVs :: [Name] -> FreeVars delFV :: Name -> FreeVars -> FreeVars delFVs :: [Name] -> FreeVars -> FreeVars intersectFVs :: FreeVars -> FreeVars -> FreeVars isEmptyFVs :: NameSet -> Bool isEmptyFVs = isEmptyNameSet emptyFVs = emptyNameSet plusFVs = unionNameSets plusFV = unionNameSet mkFVs = mkNameSet addOneFV = extendNameSet unitFV = unitNameSet delFV n s = delFromNameSet s n delFVs ns s = delListFromNameSet s ns intersectFVs = intersectNameSet {- ************************************************************************ * * Defs and uses * * ************************************************************************ -} -- | A set of names that are defined somewhere type Defs = NameSet -- | A set of names that are used somewhere type Uses = NameSet -- | @(Just ds, us) =>@ The use of any member of the @ds@ -- implies that all the @us@ are used too. -- Also, @us@ may mention @ds@. -- -- @Nothing =>@ Nothing is defined in this group, but -- nevertheless all the uses are essential. -- Used for instance declarations, for example type DefUse = (Maybe Defs, Uses) -- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses' -- In a single (def, use) pair, the defs also scope over the uses type DefUses = OrdList DefUse emptyDUs :: DefUses emptyDUs = nilOL usesOnly :: Uses -> DefUses usesOnly uses = unitOL (Nothing, uses) mkDUs :: [(Defs,Uses)] -> DefUses mkDUs pairs = toOL [(Just defs, uses) | (defs,uses) <- pairs] plusDU :: DefUses -> DefUses -> DefUses plusDU = appOL duDefs :: DefUses -> Defs duDefs dus = foldr get emptyNameSet dus where get (Nothing, _u1) d2 = d2 get (Just d1, _u1) d2 = d1 `unionNameSet` d2 allUses :: DefUses -> Uses -- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned allUses dus = foldr get emptyNameSet dus where get (_d1, u1) u2 = u1 `unionNameSet` u2 duUses :: DefUses -> Uses -- ^ Collect all 'Uses', regardless of whether the group is itself used, -- but remove 'Defs' on the way duUses dus = foldr get emptyNameSet dus where get (Nothing, rhs_uses) uses = rhs_uses `unionNameSet` uses get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSet` uses) `minusNameSet` defs findUses :: DefUses -> Uses -> Uses -- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively. -- The result is a superset of the input 'Uses'; and includes things defined -- in the input 'DefUses' (but only if they are used) findUses dus uses = foldr get uses dus where get (Nothing, rhs_uses) uses = rhs_uses `unionNameSet` uses get (Just defs, rhs_uses) uses | defs `intersectsNameSet` uses -- Used || nameSetAny (startsWithUnderscore . nameOccName) defs -- At least one starts with an "_", -- so treat the group as used = rhs_uses `unionNameSet` uses | otherwise -- No def is used = uses ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/OccName.hs0000644000000000000000000010103213713635744021264 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -- | -- #name_types# -- GHC uses several kinds of name internally: -- -- * 'OccName.OccName' represents names as strings with just a little more information: -- the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or -- data constructors -- -- * 'RdrName.RdrName': see "RdrName#name_types" -- -- * 'Name.Name': see "Name#name_types" -- -- * 'Id.Id': see "Id#name_types" -- -- * 'Var.Var': see "Var#name_types" module OccName ( -- * The 'NameSpace' type NameSpace, -- Abstract nameSpacesRelated, -- ** Construction -- $real_vs_source_data_constructors tcName, clsName, tcClsName, dataName, varName, tvName, srcDataName, -- ** Pretty Printing pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, -- * The 'OccName' type OccName, -- Abstract, instance of Outputable pprOccName, -- ** Construction mkOccName, mkOccNameFS, mkVarOcc, mkVarOccFS, mkDataOcc, mkDataOccFS, mkTyVarOcc, mkTyVarOccFS, mkTcOcc, mkTcOccFS, mkClsOcc, mkClsOccFS, mkDFunOcc, setOccNameSpace, demoteOccName, HasOccName(..), -- ** Derived 'OccName's isDerivedOccName, mkDataConWrapperOcc, mkWorkerOcc, mkMatcherOcc, mkBuilderOcc, mkDefaultMethodOcc, isDefaultMethodOcc, isTypeableBindOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, mkGenR, mkGen1R, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkSuperDictSelOcc, mkSuperDictAuxOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkRecFldSelOcc, mkTyConRepOcc, -- ** Deconstruction occNameFS, occNameString, occNameSpace, isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, parenSymOcc, startsWithUnderscore, isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, -- * The 'OccEnv' type OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, alterOccEnv, pprOccEnv, -- * The 'OccSet' type OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, extendOccSetList, unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet, filterOccSet, -- * Tidying up TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, tidyOccName, avoidClashesOccEnv, -- FsEnv FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv ) where import GhcPrelude import Util import Unique import DynFlags import UniqFM import UniqSet import FastString import FastStringEnv import Outputable import Lexeme import Binary import Control.DeepSeq import Data.Char import Data.Data {- ************************************************************************ * * \subsection{Name space} * * ************************************************************************ -} data NameSpace = VarName -- Variables, including "real" data constructors | DataName -- "Source" data constructors | TvName -- Type variables | TcClsName -- Type constructors and classes; Haskell has them -- in the same name space for now. deriving( Eq, Ord ) -- Note [Data Constructors] -- see also: Note [Data Constructor Naming] in DataCon.hs -- -- $real_vs_source_data_constructors -- There are two forms of data constructor: -- -- [Source data constructors] The data constructors mentioned in Haskell source code -- -- [Real data constructors] The data constructors of the representation type, which may not be the same as the source type -- -- For example: -- -- > data T = T !(Int, Int) -- -- The source datacon has type @(Int, Int) -> T@ -- The real datacon has type @Int -> Int -> T@ -- -- GHC chooses a representation based on the strictness etc. tcName, clsName, tcClsName :: NameSpace dataName, srcDataName :: NameSpace tvName, varName :: NameSpace -- Though type constructors and classes are in the same name space now, -- the NameSpace type is abstract, so we can easily separate them later tcName = TcClsName -- Type constructors clsName = TcClsName -- Classes tcClsName = TcClsName -- Not sure which! dataName = DataName srcDataName = DataName -- Haskell-source data constructors should be -- in the Data name space tvName = TvName varName = VarName isDataConNameSpace :: NameSpace -> Bool isDataConNameSpace DataName = True isDataConNameSpace _ = False isTcClsNameSpace :: NameSpace -> Bool isTcClsNameSpace TcClsName = True isTcClsNameSpace _ = False isTvNameSpace :: NameSpace -> Bool isTvNameSpace TvName = True isTvNameSpace _ = False isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors isVarNameSpace TvName = True isVarNameSpace VarName = True isVarNameSpace _ = False isValNameSpace :: NameSpace -> Bool isValNameSpace DataName = True isValNameSpace VarName = True isValNameSpace _ = False pprNameSpace :: NameSpace -> SDoc pprNameSpace DataName = text "data constructor" pprNameSpace VarName = text "variable" pprNameSpace TvName = text "type variable" pprNameSpace TcClsName = text "type constructor or class" pprNonVarNameSpace :: NameSpace -> SDoc pprNonVarNameSpace VarName = empty pprNonVarNameSpace ns = pprNameSpace ns pprNameSpaceBrief :: NameSpace -> SDoc pprNameSpaceBrief DataName = char 'd' pprNameSpaceBrief VarName = char 'v' pprNameSpaceBrief TvName = text "tv" pprNameSpaceBrief TcClsName = text "tc" -- demoteNameSpace lowers the NameSpace if possible. We can not know -- in advance, since a TvName can appear in an HsTyVar. -- See Note [Demotion] in RnEnv demoteNameSpace :: NameSpace -> Maybe NameSpace demoteNameSpace VarName = Nothing demoteNameSpace DataName = Nothing demoteNameSpace TvName = Nothing demoteNameSpace TcClsName = Just DataName {- ************************************************************************ * * \subsection[Name-pieces-datatypes]{The @OccName@ datatypes} * * ************************************************************************ -} -- | Occurrence Name -- -- In this context that means: -- "classified (i.e. as a type name, value name, etc) but not qualified -- and not yet resolved" data OccName = OccName { occNameSpace :: !NameSpace , occNameFS :: !FastString } instance Eq OccName where (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 instance Ord OccName where -- Compares lexicographically, *not* by Unique of the string compare (OccName sp1 s1) (OccName sp2 s2) = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) instance Data OccName where -- don't traverse? toConstr _ = abstractConstr "OccName" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "OccName" instance HasOccName OccName where occName = id instance NFData OccName where rnf x = x `seq` () {- ************************************************************************ * * \subsection{Printing} * * ************************************************************************ -} instance Outputable OccName where ppr = pprOccName instance OutputableBndr OccName where pprBndr _ = ppr pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n) pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n) pprOccName :: OccName -> SDoc pprOccName (OccName sp occ) = getPprStyle $ \ sty -> if codeStyle sty then ztext (zEncodeFS occ) else pp_occ <> pp_debug sty where pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp) | otherwise = empty pp_occ = sdocWithDynFlags $ \dflags -> if gopt Opt_SuppressUniques dflags then text (strip_th_unique (unpackFS occ)) else ftext occ -- See Note [Suppressing uniques in OccNames] strip_th_unique ('[' : c : _) | isAlphaNum c = [] strip_th_unique (c : cs) = c : strip_th_unique cs strip_th_unique [] = [] {- Note [Suppressing uniques in OccNames] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This is a hack to de-wobblify the OccNames that contain uniques from Template Haskell that have been turned into a string in the OccName. See Note [Unique OccNames from Template Haskell] in Convert.hs ************************************************************************ * * \subsection{Construction} * * ************************************************************************ -} mkOccName :: NameSpace -> String -> OccName mkOccName occ_sp str = OccName occ_sp (mkFastString str) mkOccNameFS :: NameSpace -> FastString -> OccName mkOccNameFS occ_sp fs = OccName occ_sp fs mkVarOcc :: String -> OccName mkVarOcc s = mkOccName varName s mkVarOccFS :: FastString -> OccName mkVarOccFS fs = mkOccNameFS varName fs mkDataOcc :: String -> OccName mkDataOcc = mkOccName dataName mkDataOccFS :: FastString -> OccName mkDataOccFS = mkOccNameFS dataName mkTyVarOcc :: String -> OccName mkTyVarOcc = mkOccName tvName mkTyVarOccFS :: FastString -> OccName mkTyVarOccFS fs = mkOccNameFS tvName fs mkTcOcc :: String -> OccName mkTcOcc = mkOccName tcName mkTcOccFS :: FastString -> OccName mkTcOccFS = mkOccNameFS tcName mkClsOcc :: String -> OccName mkClsOcc = mkOccName clsName mkClsOccFS :: FastString -> OccName mkClsOccFS = mkOccNameFS clsName -- demoteOccName lowers the Namespace of OccName. -- see Note [Demotion] demoteOccName :: OccName -> Maybe OccName demoteOccName (OccName space name) = do space' <- demoteNameSpace space return $ OccName space' name -- Name spaces are related if there is a chance to mean the one when one writes -- the other, i.e. variables <-> data constructors and type variables <-> type constructors nameSpacesRelated :: NameSpace -> NameSpace -> Bool nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2 otherNameSpace :: NameSpace -> NameSpace otherNameSpace VarName = DataName otherNameSpace DataName = VarName otherNameSpace TvName = TcClsName otherNameSpace TcClsName = TvName {- | Other names in the compiler add additional information to an OccName. This class provides a consistent way to access the underlying OccName. -} class HasOccName name where occName :: name -> OccName {- ************************************************************************ * * Environments * * ************************************************************************ OccEnvs are used mainly for the envts in ModIfaces. Note [The Unique of an OccName] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ They are efficient, because FastStrings have unique Int# keys. We assume this key is less than 2^24, and indeed FastStrings are allocated keys sequentially starting at 0. So we can make a Unique using mkUnique ns key :: Unique where 'ns' is a Char representing the name space. This in turn makes it easy to build an OccEnv. -} instance Uniquable OccName where -- See Note [The Unique of an OccName] getUnique (OccName VarName fs) = mkVarOccUnique fs getUnique (OccName DataName fs) = mkDataOccUnique fs getUnique (OccName TvName fs) = mkTvOccUnique fs getUnique (OccName TcClsName fs) = mkTcOccUnique fs newtype OccEnv a = A (UniqFM a) deriving Data emptyOccEnv :: OccEnv a unitOccEnv :: OccName -> a -> OccEnv a extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a lookupOccEnv :: OccEnv a -> OccName -> Maybe a mkOccEnv :: [(OccName,a)] -> OccEnv a mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a elemOccEnv :: OccName -> OccEnv a -> Bool foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b occEnvElts :: OccEnv a -> [a] extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b delFromOccEnv :: OccEnv a -> OccName -> OccEnv a delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt alterOccEnv :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt emptyOccEnv = A emptyUFM unitOccEnv x y = A $ unitUFM x y extendOccEnv (A x) y z = A $ addToUFM x y z extendOccEnvList (A x) l = A $ addListToUFM x l lookupOccEnv (A x) y = lookupUFM x y mkOccEnv l = A $ listToUFM l elemOccEnv x (A y) = elemUFM x y foldOccEnv a b (A c) = foldUFM a b c occEnvElts (A x) = eltsUFM x plusOccEnv (A x) (A y) = A $ plusUFM x y plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z mapOccEnv f (A x) = A $ mapUFM f x mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l delFromOccEnv (A x) y = A $ delFromUFM x y delListFromOccEnv (A x) y = A $ delListFromUFM x y filterOccEnv x (A y) = A $ filterUFM x y alterOccEnv fn (A y) k = A $ alterUFM fn y k instance Outputable a => Outputable (OccEnv a) where ppr x = pprOccEnv ppr x pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env type OccSet = UniqSet OccName emptyOccSet :: OccSet unitOccSet :: OccName -> OccSet mkOccSet :: [OccName] -> OccSet extendOccSet :: OccSet -> OccName -> OccSet extendOccSetList :: OccSet -> [OccName] -> OccSet unionOccSets :: OccSet -> OccSet -> OccSet unionManyOccSets :: [OccSet] -> OccSet minusOccSet :: OccSet -> OccSet -> OccSet elemOccSet :: OccName -> OccSet -> Bool isEmptyOccSet :: OccSet -> Bool intersectOccSet :: OccSet -> OccSet -> OccSet intersectsOccSet :: OccSet -> OccSet -> Bool filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet emptyOccSet = emptyUniqSet unitOccSet = unitUniqSet mkOccSet = mkUniqSet extendOccSet = addOneToUniqSet extendOccSetList = addListToUniqSet unionOccSets = unionUniqSets unionManyOccSets = unionManyUniqSets minusOccSet = minusUniqSet elemOccSet = elementOfUniqSet isEmptyOccSet = isEmptyUniqSet intersectOccSet = intersectUniqSets intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) filterOccSet = filterUniqSet {- ************************************************************************ * * \subsection{Predicates and taking them apart} * * ************************************************************************ -} occNameString :: OccName -> String occNameString (OccName _ s) = unpackFS s setOccNameSpace :: NameSpace -> OccName -> OccName setOccNameSpace sp (OccName _ occ) = OccName sp occ isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool isVarOcc (OccName VarName _) = True isVarOcc _ = False isTvOcc (OccName TvName _) = True isTvOcc _ = False isTcOcc (OccName TcClsName _) = True isTcOcc _ = False -- | /Value/ 'OccNames's are those that are either in -- the variable or data constructor namespaces isValOcc :: OccName -> Bool isValOcc (OccName VarName _) = True isValOcc (OccName DataName _) = True isValOcc _ = False isDataOcc (OccName DataName _) = True isDataOcc _ = False -- | Test if the 'OccName' is a data constructor that starts with -- a symbol (e.g. @:@, or @[]@) isDataSymOcc :: OccName -> Bool isDataSymOcc (OccName DataName s) = isLexConSym s isDataSymOcc _ = False -- Pretty inefficient! -- | Test if the 'OccName' is that for any operator (whether -- it is a data constructor or variable or whatever) isSymOcc :: OccName -> Bool isSymOcc (OccName DataName s) = isLexConSym s isSymOcc (OccName TcClsName s) = isLexSym s isSymOcc (OccName VarName s) = isLexSym s isSymOcc (OccName TvName s) = isLexSym s -- Pretty inefficient! parenSymOcc :: OccName -> SDoc -> SDoc -- ^ Wrap parens around an operator parenSymOcc occ doc | isSymOcc occ = parens doc | otherwise = doc startsWithUnderscore :: OccName -> Bool -- ^ Haskell 98 encourages compilers to suppress warnings about unsed -- names in a pattern if they start with @_@: this implements that test startsWithUnderscore occ = headFS (occNameFS occ) == '_' {- ************************************************************************ * * \subsection{Making system names} * * ************************************************************************ Here's our convention for splitting up the interface file name space: d... dictionary identifiers (local variables, so no name-clash worries) All of these other OccNames contain a mixture of alphabetic and symbolic characters, and hence cannot possibly clash with a user-written type or function name $f... Dict-fun identifiers (from inst decls) $dmop Default method for 'op' $pnC n'th superclass selector for class C $wf Worker for function 'f' $sf.. Specialised version of f D:C Data constructor for dictionary for class C NTCo:T Coercion connecting newtype T with its representation type TFCo:R Coercion connecting a data family to its representation type R In encoded form these appear as Zdfxxx etc :... keywords (export:, letrec: etc.) --- I THINK THIS IS WRONG! This knowledge is encoded in the following functions. @mk_deriv@ generates an @OccName@ from the prefix and a string. NB: The string must already be encoded! -} -- | Build an 'OccName' derived from another 'OccName'. -- -- Note that the pieces of the name are passed in as a @[FastString]@ so that -- the whole name can be constructed with a single 'concatFS', minimizing -- unnecessary intermediate allocations. mk_deriv :: NameSpace -> FastString -- ^ A prefix which distinguishes one sort of -- derived name from another -> [FastString] -- ^ The name we are deriving from in pieces which -- will be concatenated. -> OccName mk_deriv occ_sp sys_prefix str = mkOccNameFS occ_sp (concatFS $ sys_prefix : str) isDerivedOccName :: OccName -> Bool -- ^ Test for definitions internally generated by GHC. This predicte -- is used to suppress printing of internal definitions in some debug prints isDerivedOccName occ = case occNameString occ of '$':c:_ | isAlphaNum c -> True -- E.g. $wfoo c:':':_ | isAlphaNum c -> True -- E.g. N:blah newtype coercions _other -> False isDefaultMethodOcc :: OccName -> Bool isDefaultMethodOcc occ = case occNameString occ of '$':'d':'m':_ -> True _ -> False -- | Is an 'OccName' one of a Typeable @TyCon@ or @Module@ binding? -- This is needed as these bindings are renamed differently. -- See Note [Grand plan for Typeable] in TcTypeable. isTypeableBindOcc :: OccName -> Bool isTypeableBindOcc occ = case occNameString occ of '$':'t':'c':_ -> True -- mkTyConRepOcc '$':'t':'r':_ -> True -- Module binding _ -> False mkDataConWrapperOcc, mkWorkerOcc, mkMatcherOcc, mkBuilderOcc, mkDefaultMethodOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, mkGenR, mkGen1R, mkDataConWorkerOcc, mkNewTyCoOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkTyConRepOcc :: OccName -> OccName -- These derived variables have a prefix that no Haskell value could have mkDataConWrapperOcc = mk_simple_deriv varName "$W" mkWorkerOcc = mk_simple_deriv varName "$w" mkMatcherOcc = mk_simple_deriv varName "$m" mkBuilderOcc = mk_simple_deriv varName "$b" mkDefaultMethodOcc = mk_simple_deriv varName "$dm" mkClassOpAuxOcc = mk_simple_deriv varName "$c" mkDictOcc = mk_simple_deriv varName "$d" mkIPOcc = mk_simple_deriv varName "$i" mkSpecOcc = mk_simple_deriv varName "$s" mkForeignExportOcc = mk_simple_deriv varName "$f" mkRepEqOcc = mk_simple_deriv tvName "$r" -- In RULES involving Coercible mkClassDataConOcc = mk_simple_deriv dataName "C:" -- Data con for a class mkNewTyCoOcc = mk_simple_deriv tcName "N:" -- Coercion for newtypes mkInstTyCoOcc = mk_simple_deriv tcName "D:" -- Coercion for type functions mkEqPredCoOcc = mk_simple_deriv tcName "$co" -- Used in derived instances mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" -- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable mkTyConRepOcc occ = mk_simple_deriv varName prefix occ where prefix | isDataOcc occ = "$tc'" | otherwise = "$tc" -- Generic deriving mechanism mkGenR = mk_simple_deriv tcName "Rep_" mkGen1R = mk_simple_deriv tcName "Rep1_" -- Overloaded record field selectors mkRecFldSelOcc :: String -> OccName mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s] mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] -- Data constructor workers are made by setting the name space -- of the data constructor OccName (which should be a DataName) -- to VarName mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ mkSuperDictAuxOcc :: Int -> OccName -> OccName mkSuperDictAuxOcc index cls_tc_occ = mk_deriv varName "$cp" [fsLit $ show index, occNameFS cls_tc_occ] mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3 -> OccName -- ^ Class, e.g. @Ord@ -> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@ mkSuperDictSelOcc index cls_tc_occ = mk_deriv varName "$p" [fsLit $ show index, occNameFS cls_tc_occ] mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName' -> OccName -- ^ Local name, e.g. @sat@ -> OccName -- ^ Nice unique version, e.g. @$L23sat@ mkLocalOcc uniq occ = mk_deriv varName "$L" [fsLit $ show uniq, occNameFS occ] -- The Unique might print with characters -- that need encoding (e.g. 'z'!) -- | Derive a name for the representation type constructor of a -- @data@\/@newtype@ instance. mkInstTyTcOcc :: String -- ^ Family name, e.g. @Map@ -> OccSet -- ^ avoid these Occs -> OccName -- ^ @R:Map@ mkInstTyTcOcc str = chooseUniqueOcc tcName ('R' : ':' : str) mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @OrdMaybe@. -- Only used in debug mode, for extra clarity -> Bool -- ^ Is this a hs-boot instance DFun? -> OccSet -- ^ avoid these Occs -> OccName -- ^ E.g. @$f3OrdMaybe@ -- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real -- thing when we compile the mother module. Reason: we don't know exactly -- what the mother module will call it. mkDFunOcc info_str is_boot set = chooseUniqueOcc VarName (prefix ++ info_str) set where prefix | is_boot = "$fx" | otherwise = "$f" mkDataTOcc, mkDataCOcc :: OccName -- ^ TyCon or data con string -> OccSet -- ^ avoid these Occs -> OccName -- ^ E.g. @$f3OrdMaybe@ -- data T = MkT ... deriving( Data ) needs definitions for -- $tT :: Data.Generics.Basics.DataType -- $cMkT :: Data.Generics.Basics.Constr mkDataTOcc occ = chooseUniqueOcc VarName ("$t" ++ occNameString occ) mkDataCOcc occ = chooseUniqueOcc VarName ("$c" ++ occNameString occ) {- Sometimes we need to pick an OccName that has not already been used, given a set of in-use OccNames. -} chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int) where loop occ n | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1) | otherwise = occ {- We used to add a '$m' to indicate a method, but that gives rise to bad error messages from the type checker when we print the function name or pattern of an instance-decl binding. Why? Because the binding is zapped to use the method name in place of the selector name. (See TcClassDcl.tcMethodBind) The way it is now, -ddump-xx output may look confusing, but you can always say -dppr-debug to get the uniques. However, we *do* have to zap the first character to be lower case, because overloaded constructors (blarg) generate methods too. And convert to VarName space e.g. a call to constructor MkFoo where data (Ord a) => Foo a = MkFoo a If this is necessary, we do it by prefixing '$m'. These guys never show up in error messages. What a hack. -} mkMethodOcc :: OccName -> OccName mkMethodOcc occ@(OccName VarName _) = occ mkMethodOcc occ = mk_simple_deriv varName "$m" occ {- ************************************************************************ * * \subsection{Tidying them up} * * ************************************************************************ Before we print chunks of code we like to rename it so that we don't have to print lots of silly uniques in it. But we mustn't accidentally introduce name clashes! So the idea is that we leave the OccName alone unless it accidentally clashes with one that is already in scope; if so, we tack on '1' at the end and try again, then '2', and so on till we find a unique one. There's a wrinkle for operators. Consider '>>='. We can't use '>>=1' because that isn't a single lexeme. So we encode it to 'lle' and *then* tack on the '1', if necessary. Note [TidyOccEnv] ~~~~~~~~~~~~~~~~~ type TidyOccEnv = UniqFM Int * Domain = The OccName's FastString. These FastStrings are "taken"; make sure that we don't re-use * Int, n = A plausible starting point for new guesses There is no guarantee that "FSn" is available; you must look that up in the TidyOccEnv. But it's a good place to start looking. * When looking for a renaming for "foo2" we strip off the "2" and start with "foo". Otherwise if we tidy twice we get silly names like foo23. However, if it started with digits at the end, we always make a name with digits at the end, rather than shortening "foo2" to just "foo", even if "foo" is unused. Reasons: - Plain "foo" might be used later - We use trailing digits to subtly indicate a unification variable in typechecker error message; see TypeRep.tidyTyVarBndr We have to take care though! Consider a machine-generated module (#10370) module Foo where a1 = e1 a2 = e2 ... a2000 = e2000 Then "a1", "a2" etc are all marked taken. But now if we come across "a7" again, we have to do a linear search to find a free one, "a2001". That might just be acceptable once. But if we now come across "a8" again, we don't want to repeat that search. So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for starting the search; and we make sure to update the starting point for "a" after we allocate a new one. Note [Tidying multiple names at once] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider > :t (id,id,id) Every id contributes a type variable to the type signature, and all of them are "a". If we tidy them one by one, we get (id,id,id) :: (a2 -> a2, a1 -> a1, a -> a) which is a bit unfortunate, as it unfairly renames only one of them. What we would like to see is (id,id,id) :: (a3 -> a3, a2 -> a2, a1 -> a1) To achieve this, the function avoidClashesOccEnv can be used to prepare the TidyEnv, by “blocking” every name that occurs twice in the map. This way, none of the "a"s will get the privilege of keeping this name, and all of them will get a suitable number by tidyOccName. This prepared TidyEnv can then be used with tidyOccName. See tidyTyCoVarBndrs for an example where this is used. This is #12382. -} type TidyOccEnv = UniqFM Int -- The in-scope OccNames -- See Note [TidyOccEnv] emptyTidyOccEnv :: TidyOccEnv emptyTidyOccEnv = emptyUFM initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! initTidyOccEnv = foldl' add emptyUFM where add env (OccName _ fs) = addToUFM env fs 1 -- see Note [Tidying multiple names at once] avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv avoidClashesOccEnv env occs = go env emptyUFM occs where go env _ [] = env go env seenOnce ((OccName _ fs):occs) | fs `elemUFM` env = go env seenOnce occs | fs `elemUFM` seenOnce = go (addToUFM env fs 1) seenOnce occs | otherwise = go env (addToUFM seenOnce fs ()) occs tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) tidyOccName env occ@(OccName occ_sp fs) | not (fs `elemUFM` env) = -- Desired OccName is free, so use it, -- and record in 'env' that it's no longer available (addToUFM env fs 1, occ) | otherwise = case lookupUFM env base1 of Nothing -> (addToUFM env base1 2, OccName occ_sp base1) Just n -> find 1 n where base :: String -- Drop trailing digits (see Note [TidyOccEnv]) base = dropWhileEndLE isDigit (unpackFS fs) base1 = mkFastString (base ++ "1") find !k !n = case lookupUFM env new_fs of Just {} -> find (k+1 :: Int) (n+k) -- By using n+k, the n argument to find goes -- 1, add 1, add 2, add 3, etc which -- moves at quadratic speed through a dense patch Nothing -> (new_env, OccName occ_sp new_fs) where new_fs = mkFastString (base ++ show n) new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1) -- Update: base1, so that next time we'll start where we left off -- new_fs, so that we know it is taken -- If they are the same (n==1), the former wins -- See Note [TidyOccEnv] {- ************************************************************************ * * Binary instance Here rather than BinIface because OccName is abstract * * ************************************************************************ -} instance Binary NameSpace where put_ bh VarName = do putByte bh 0 put_ bh DataName = do putByte bh 1 put_ bh TvName = do putByte bh 2 put_ bh TcClsName = do putByte bh 3 get bh = do h <- getByte bh case h of 0 -> do return VarName 1 -> do return DataName 2 -> do return TvName _ -> do return TcClsName instance Binary OccName where put_ bh (OccName aa ab) = do put_ bh aa put_ bh ab get bh = do aa <- get bh ab <- get bh return (OccName aa ab) ghc-lib-parser-8.10.2.20200808/compiler/simplCore/OccurAnal.hs0000644000000000000000000034637513713635745021503 0ustar0000000000000000{- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 ************************************************************************ * * \section[OccurAnal]{Occurrence analysis pass} * * ************************************************************************ The occurrence analyser re-typechecks a core expression, returning a new core expression with (hopefully) improved usage information. -} {-# LANGUAGE CPP, BangPatterns, MultiWayIf, ViewPatterns #-} module OccurAnal ( occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap ) where #include "GhclibHsVersions.h" import GhcPrelude import CoreSyn import CoreFVs import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, stripTicksTopE, mkTicks ) import CoreArity ( joinRhsArity ) import Id import IdInfo import Name( localiseName ) import BasicTypes import Module( Module ) import Coercion import Type import VarSet import VarEnv import Var import Demand ( argOneShots, argsOneShots ) import Digraph ( SCC(..), Node(..) , stronglyConnCompFromEdgedVerticesUniq , stronglyConnCompFromEdgedVerticesUniqR ) import Unique import UniqFM import UniqSet import Util import Outputable import Data.List import Control.Arrow ( second ) {- ************************************************************************ * * occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap * * ************************************************************************ Here's the externally-callable interface: -} occurAnalysePgm :: Module -- Used only in debug output -> (Id -> Bool) -- Active unfoldings -> (Activation -> Bool) -- Active rules -> [CoreRule] -> CoreProgram -> CoreProgram occurAnalysePgm this_mod active_unf active_rule imp_rules binds | isEmptyDetails final_usage = occ_anald_binds | otherwise -- See Note [Glomming] = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon) 2 (ppr final_usage ) ) occ_anald_glommed_binds where init_env = initOccEnv { occ_rule_act = active_rule , occ_unf_act = active_unf } (final_usage, occ_anald_binds) = go init_env binds (_, occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel imp_rule_edges (flattenBinds binds) initial_uds -- It's crucial to re-analyse the glommed-together bindings -- so that we establish the right loop breakers. Otherwise -- we can easily create an infinite loop (#9583 is an example) -- -- Also crucial to re-analyse the /original/ bindings -- in case the first pass accidentally discarded as dead code -- a binding that was actually needed (albeit before its -- definition site). #17724 threw this up. initial_uds = addManyOccsSet emptyDetails (rulesFreeVars imp_rules) -- The RULES declarations keep things alive! -- Note [Preventing loops due to imported functions rules] imp_rule_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv [ mapVarEnv (const maps_to) $ getUniqSet (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule) | imp_rule <- imp_rules , not (isBuiltinRule imp_rule) -- See Note [Plugin rules] , let maps_to = exprFreeIds (ru_rhs imp_rule) `delVarSetList` ru_bndrs imp_rule , arg <- ru_args imp_rule ] go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) go _ [] = (initial_uds, []) go env (bind:binds) = (final_usage, bind' ++ binds') where (bs_usage, binds') = go env binds (final_usage, bind') = occAnalBind env TopLevel imp_rule_edges bind bs_usage occurAnalyseExpr :: CoreExpr -> CoreExpr -- Do occurrence analysis, and discard occurrence info returned occurAnalyseExpr = occurAnalyseExpr' True -- do binder swap occurAnalyseExpr_NoBinderSwap :: CoreExpr -> CoreExpr occurAnalyseExpr_NoBinderSwap = occurAnalyseExpr' False -- do not do binder swap occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr occurAnalyseExpr' enable_binder_swap expr = snd (occAnal env expr) where env = initOccEnv { occ_binder_swap = enable_binder_swap } {- Note [Plugin rules] ~~~~~~~~~~~~~~~~~~~~~~ Conal Elliott (#11651) built a GHC plugin that added some BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to do some domain-specific transformations that could not be expressed with an ordinary pattern-matching CoreRule. But then we can't extract the dependencies (in imp_rule_edges) from ru_rhs etc, because a BuiltinRule doesn't have any of that stuff. So we simply assume that BuiltinRules have no dependencies, and filter them out from the imp_rule_edges comprehension. -} {- ************************************************************************ * * Bindings * * ************************************************************************ Note [Recursive bindings: the grand plan] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we come across a binding group Rec { x1 = r1; ...; xn = rn } we treat it like this (occAnalRecBind): 1. Occurrence-analyse each right hand side, and build a "Details" for each binding to capture the results. Wrap the details in a Node (details, node-id, dep-node-ids), where node-id is just the unique of the binder, and dep-node-ids lists all binders on which this binding depends. We'll call these the "scope edges". See Note [Forming the Rec groups]. All this is done by makeNode. 2. Do SCC-analysis on these Nodes. Each SCC will become a new Rec or NonRec. The key property is that every free variable of a binding is accounted for by the scope edges, so that when we are done everything is still in scope. 3. For each Cyclic SCC of the scope-edge SCC-analysis in (2), we identify suitable loop-breakers to ensure that inlining terminates. This is done by occAnalRec. 4. To do so we form a new set of Nodes, with the same details, but different edges, the "loop-breaker nodes". The loop-breaker nodes have both more and fewer dependencies than the scope edges (see Note [Choosing loop breakers]) More edges: if f calls g, and g has an active rule that mentions h then we add an edge from f -> h Fewer edges: we only include dependencies on active rules, on rule RHSs (not LHSs) and if there is an INLINE pragma only on the stable unfolding (and vice versa). The scope edges must be much more inclusive. 5. The "weak fvs" of a node are, by definition: the scope fvs - the loop-breaker fvs See Note [Weak loop breakers], and the nd_weak field of Details 6. Having formed the loop-breaker nodes Note [Dead code] ~~~~~~~~~~~~~~~~ Dropping dead code for a cyclic Strongly Connected Component is done in a very simple way: the entire SCC is dropped if none of its binders are mentioned in the body; otherwise the whole thing is kept. The key observation is that dead code elimination happens after dependency analysis: so 'occAnalBind' processes SCCs instead of the original term's binding groups. Thus 'occAnalBind' does indeed drop 'f' in an example like letrec f = ...g... g = ...(...g...)... in ...g... when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in 'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes 'AcyclicSCC f', where 'body_usage' won't contain 'f'. ------------------------------------------------------------ Note [Forming Rec groups] ~~~~~~~~~~~~~~~~~~~~~~~~~ We put bindings {f = ef; g = eg } in a Rec group if "f uses g" and "g uses f", no matter how indirectly. We do a SCC analysis with an edge f -> g if "f uses g". More precisely, "f uses g" iff g should be in scope wherever f is. That is, g is free in: a) the rhs 'ef' b) or the RHS of a rule for f (Note [Rules are extra RHSs]) c) or the LHS or a rule for f (Note [Rule dependency info]) These conditions apply regardless of the activation of the RULE (eg it might be inactive in this phase but become active later). Once a Rec is broken up it can never be put back together, so we must be conservative. The principle is that, regardless of rule firings, every variable is always in scope. * Note [Rules are extra RHSs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ A RULE for 'f' is like an extra RHS for 'f'. That way the "parent" keeps the specialised "children" alive. If the parent dies (because it isn't referenced any more), then the children will die too (unless they are already referenced directly). To that end, we build a Rec group for each cyclic strongly connected component, *treating f's rules as extra RHSs for 'f'*. More concretely, the SCC analysis runs on a graph with an edge from f -> g iff g is mentioned in (a) f's rhs (b) f's RULES These are rec_edges. Under (b) we include variables free in *either* LHS *or* RHS of the rule. The former might seems silly, but see Note [Rule dependency info]. So in Example [eftInt], eftInt and eftIntFB will be put in the same Rec, even though their 'main' RHSs are both non-recursive. * Note [Rule dependency info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ The VarSet in a RuleInfo is used for dependency analysis in the occurrence analyser. We must track free vars in *both* lhs and rhs. Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. Why both? Consider x = y RULE f x = v+4 Then if we substitute y for x, we'd better do so in the rule's LHS too, so we'd better ensure the RULE appears to mention 'x' as well as 'v' * Note [Rules are visible in their own rec group] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want the rules for 'f' to be visible in f's right-hand side. And we'd like them to be visible in other functions in f's Rec group. E.g. in Note [Specialisation rules] we want f' rule to be visible in both f's RHS, and fs's RHS. This means that we must simplify the RULEs first, before looking at any of the definitions. This is done by Simplify.simplRecBind, when it calls addLetIdInfo. ------------------------------------------------------------ Note [Choosing loop breakers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Loop breaking is surprisingly subtle. First read the section 4 of "Secrets of the GHC inliner". This describes our basic plan. We avoid infinite inlinings by choosing loop breakers, and ensuring that a loop breaker cuts each loop. See also Note [Inlining and hs-boot files] in ToIface, which deals with a closely related source of infinite loops. Fundamentally, we do SCC analysis on a graph. For each recursive group we choose a loop breaker, delete all edges to that node, re-analyse the SCC, and iterate. But what is the graph? NOT the same graph as was used for Note [Forming Rec groups]! In particular, a RULE is like an equation for 'f' that is *always* inlined if it is applicable. We do *not* disable rules for loop-breakers. It's up to whoever makes the rules to make sure that the rules themselves always terminate. See Note [Rules for recursive functions] in Simplify.hs Hence, if f's RHS (or its INLINE template if it has one) mentions g, and g has a RULE that mentions h, and h has a RULE that mentions f then we *must* choose f to be a loop breaker. Example: see Note [Specialisation rules]. In general, take the free variables of f's RHS, and augment it with all the variables reachable by RULES from those starting points. That is the whole reason for computing rule_fv_env in occAnalBind. (Of course we only consider free vars that are also binders in this Rec group.) See also Note [Finding rule RHS free vars] Note that when we compute this rule_fv_env, we only consider variables free in the *RHS* of the rule, in contrast to the way we build the Rec group in the first place (Note [Rule dependency info]) Note that if 'g' has RHS that mentions 'w', we should add w to g's loop-breaker edges. More concretely there is an edge from f -> g iff (a) g is mentioned in f's RHS `xor` f's INLINE rhs (see Note [Inline rules]) (b) or h is mentioned in f's RHS, and g appears in the RHS of an active RULE of h or a transitive sequence of active rules starting with h Why "active rules"? See Note [Finding rule RHS free vars] Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is chosen as a loop breaker, because their RHSs don't mention each other. And indeed both can be inlined safely. Note again that the edges of the graph we use for computing loop breakers are not the same as the edges we use for computing the Rec blocks. That's why we compute - rec_edges for the Rec block analysis - loop_breaker_nodes for the loop breaker analysis * Note [Finding rule RHS free vars] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this real example from Data Parallel Haskell tagZero :: Array Int -> Array Tag {-# INLINE [1] tagZeroes #-} tagZero xs = pmap (\x -> fromBool (x==0)) xs {-# RULES "tagZero" [~1] forall xs n. pmap fromBool = tagZero xs #-} So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero. However, tagZero can only be inlined in phase 1 and later, while the RULE is only active *before* phase 1. So there's no problem. To make this work, we look for the RHS free vars only for *active* rules. That's the reason for the occ_rule_act field of the OccEnv. * Note [Weak loop breakers] ~~~~~~~~~~~~~~~~~~~~~~~~~ There is a last nasty wrinkle. Suppose we have Rec { f = f_rhs RULE f [] = g h = h_rhs g = h ...more... } Remember that we simplify the RULES before any RHS (see Note [Rules are visible in their own rec group] above). So we must *not* postInlineUnconditionally 'g', even though its RHS turns out to be trivial. (I'm assuming that 'g' is not choosen as a loop breaker.) Why not? Because then we drop the binding for 'g', which leaves it out of scope in the RULE! Here's a somewhat different example of the same thing Rec { g = h ; h = ...f... ; f = f_rhs RULE f [] = g } Here the RULE is "below" g, but we *still* can't postInlineUnconditionally g, because the RULE for f is active throughout. So the RHS of h might rewrite to h = ...g... So g must remain in scope in the output program! We "solve" this by: Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True) iff g is a "missing free variable" of the Rec group A "missing free variable" x is one that is mentioned in an RHS or INLINE or RULE of a binding in the Rec group, but where the dependency on x may not show up in the loop_breaker_nodes (see note [Choosing loop breakers} above). A normal "strong" loop breaker has IAmLoopBreaker False. So Inline postInlineUnconditionally strong IAmLoopBreaker False no no weak IAmLoopBreaker True yes no other yes yes The **sole** reason for this kind of loop breaker is so that postInlineUnconditionally does not fire. Ugh. (Typically it'll inline via the usual callSiteInline stuff, so it'll be dead in the next pass, so the main Ugh is the tiresome complication.) Note [Rules for imported functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this f = /\a. B.g a RULE B.g Int = 1 + f Int Note that * The RULE is for an imported function. * f is non-recursive Now we can get f Int --> B.g Int Inlining f --> 1 + f Int Firing RULE and so the simplifier goes into an infinite loop. This would not happen if the RULE was for a local function, because we keep track of dependencies through rules. But that is pretty much impossible to do for imported Ids. Suppose f's definition had been f = /\a. C.h a where (by some long and devious process), C.h eventually inlines to B.g. We could only spot such loops by exhaustively following unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE) f. Note that RULES for imported functions are important in practice; they occur a lot in the libraries. We regard this potential infinite loop as a *programmer* error. It's up the programmer not to write silly rules like RULE f x = f x and the example above is just a more complicated version. Note [Preventing loops due to imported functions rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider: import GHC.Base (foldr) {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-} filter p xs = build (\c n -> foldr (filterFB c p) n xs) filterFB c p = ... f = filter p xs Note that filter is not a loop-breaker, so what happens is: f = filter p xs = {inline} build (\c n -> foldr (filterFB c p) n xs) = {inline} foldr (filterFB (:) p) [] xs = {RULE} filter p xs We are in an infinite loop. A more elaborate example (that I actually saw in practice when I went to mark GHC.List.filter as INLINABLE) is as follows. Say I have this module: {-# LANGUAGE RankNTypes #-} module GHCList where import Prelude hiding (filter) import GHC.Base (build) {-# INLINABLE filter #-} filter :: (a -> Bool) -> [a] -> [a] filter p [] = [] filter p (x:xs) = if p x then x : filter p xs else filter p xs {-# NOINLINE [0] filterFB #-} filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b filterFB c p x r | p x = x `c` r | otherwise = r {-# RULES "filter" [~1] forall p xs. filter p xs = build (\c n -> foldr (filterFB c p) n xs) "filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p #-} Then (because RULES are applied inside INLINABLE unfoldings, but inlinings are not), the unfolding given to "filter" in the interface file will be: filter p [] = [] filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs) else build (\c n -> foldr (filterFB c p) n xs Note that because this unfolding does not mention "filter", filter is not marked as a strong loop breaker. Therefore at a use site in another module: filter p xs = {inline} case xs of [] -> [] (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs) else build (\c n -> foldr (filterFB c p) n xs) build (\c n -> foldr (filterFB c p) n xs) = {inline} foldr (filterFB (:) p) [] xs = {RULE} filter p xs And we are in an infinite loop again, except that this time the loop is producing an infinitely large *term* (an unrolling of filter) and so the simplifier finally dies with "ticks exhausted" Because of this problem, we make a small change in the occurrence analyser designed to mark functions like "filter" as strong loop breakers on the basis that: 1. The RHS of filter mentions the local function "filterFB" 2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS So for each RULE for an *imported* function we are going to add dependency edges between the *local* FVS of the rule LHS and the *local* FVS of the rule RHS. We don't do anything special for RULES on local functions because the standard occurrence analysis stuff is pretty good at getting loop-breakerness correct there. It is important to note that even with this extra hack we aren't always going to get things right. For example, it might be that the rule LHS mentions an imported Id, and another module has a RULE that can rewrite that imported Id to one of our local Ids. Note [Specialising imported functions] (referred to from Specialise) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ BUT for *automatically-generated* rules, the programmer can't be responsible for the "programmer error" in Note [Rules for imported functions]. In paricular, consider specialising a recursive function defined in another module. If we specialise a recursive function B.g, we get g_spec = .....(B.g Int)..... RULE B.g Int = g_spec Here, g_spec doesn't look recursive, but when the rule fires, it becomes so. And if B.g was mutually recursive, the loop might not be as obvious as it is here. To avoid this, * When specialising a function that is a loop breaker, give a NOINLINE pragma to the specialised function Note [Glomming] ~~~~~~~~~~~~~~~ RULES for imported Ids can make something at the top refer to something at the bottom: f = \x -> B.g (q x) h = \y -> 3 RULE: B.g (q x) = h x Applying this rule makes f refer to h, although f doesn't appear to depend on h. (And, as in Note [Rules for imported functions], the dependency might be more indirect. For example, f might mention C.t rather than B.g, where C.t eventually inlines to B.g.) NOTICE that this cannot happen for rules whose head is a locally-defined function, because we accurately track dependencies through RULES. It only happens for rules whose head is an imported function (B.g in the example above). Solution: - When simplifying, bring all top level identifiers into scope at the start, ignoring the Rec/NonRec structure, so that when 'h' pops up in f's rhs, we find it in the in-scope set (as the simplifier generally expects). This happens in simplTopBinds. - In the occurrence analyser, if there are any out-of-scope occurrences that pop out of the top, which will happen after firing the rule: f = \x -> h x h = \y -> 3 then just glom all the bindings into a single Rec, so that the *next* iteration of the occurrence analyser will sort them all out. This part happens in occurAnalysePgm. ------------------------------------------------------------ Note [Inline rules] ~~~~~~~~~~~~~~~~~~~ None of the above stuff about RULES applies to Inline Rules, stored in a CoreUnfolding. The unfolding, if any, is simplified at the same time as the regular RHS of the function (ie *not* like Note [Rules are visible in their own rec group]), so it should be treated *exactly* like an extra RHS. Or, rather, when computing loop-breaker edges, * If f has an INLINE pragma, and it is active, we treat the INLINE rhs as f's rhs * If it's inactive, we treat f as having no rhs * If it has no INLINE pragma, we look at f's actual rhs There is a danger that we'll be sub-optimal if we see this f = ...f... [INLINE f = ..no f...] where f is recursive, but the INLINE is not. This can just about happen with a sufficiently odd set of rules; eg foo :: Int -> Int {-# INLINE [1] foo #-} foo x = x+1 bar :: Int -> Int {-# INLINE [1] bar #-} bar x = foo x + 1 {-# RULES "foo" [~1] forall x. foo x = bar x #-} Here the RULE makes bar recursive; but it's INLINE pragma remains non-recursive. It's tempting to then say that 'bar' should not be a loop breaker, but an attempt to do so goes wrong in two ways: a) We may get $df = ...$cfoo... $cfoo = ...$df.... [INLINE $cfoo = ...no-$df...] But we want $cfoo to depend on $df explicitly so that we put the bindings in the right order to inline $df in $cfoo and perhaps break the loop altogether. (Maybe this b) Example [eftInt] ~~~~~~~~~~~~~~~ Example (from GHC.Enum): eftInt :: Int# -> Int# -> [Int] eftInt x y = ...(non-recursive)... {-# INLINE [0] eftIntFB #-} eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r eftIntFB c n x y = ...(non-recursive)... {-# RULES "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) "eftIntList" [1] eftIntFB (:) [] = eftInt #-} Note [Specialisation rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this group, which is typical of what SpecConstr builds: fs a = ....f (C a).... f x = ....f (C a).... {-# RULE f (C a) = fs a #-} So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE). But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop: - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify - fs is inlined (say it's small) - now there's another opportunity to apply the RULE This showed up when compiling Control.Concurrent.Chan.getChanContents. ------------------------------------------------------------ Note [Finding join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~ It's the occurrence analyser's job to find bindings that we can turn into join points, but it doesn't perform that transformation right away. Rather, it marks the eligible bindings as part of their occurrence data, leaving it to the simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'. The simplifier then eta-expands the RHS if needed and then updates the occurrence sites. Dividing the work this way means that the occurrence analyser still only takes one pass, yet one can always tell the difference between a function call and a jump by looking at the occurrence (because the same pass changes the 'IdDetails' and propagates the binders to their occurrence sites). To track potential join points, we use the 'occ_tail' field of OccInfo. A value of `AlwaysTailCalled n` indicates that every occurrence of the variable is a tail call with `n` arguments (counting both value and type arguments). Otherwise 'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the rest of 'OccInfo' until it goes on the binder. Note [Rules and join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Things get fiddly with rules. Suppose we have: let j :: Int -> Int j y = 2 * y k :: Int -> Int -> Int {-# RULES "SPEC k 0" k 0 = j #-} k x y = x + 2 * y in ... Now suppose that both j and k appear only as saturated tail calls in the body. Thus we would like to make them both join points. The rule complicates matters, though, as its RHS has an unapplied occurrence of j. *However*, if we were to eta-expand the rule, all would be well: {-# RULES "SPEC k 0" forall a. k 0 a = j a #-} So conceivably we could notice that a potential join point would have an "undersaturated" rule and account for it. This would mean we could make something that's been specialised a join point, for instance. But local bindings are rarely specialised, and being overly cautious about rules only costs us anything when, for some `j`: * Before specialisation, `j` has non-tail calls, so it can't be a join point. * During specialisation, `j` gets specialised and thus acquires rules. * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say), and so now `j` *could* become a join point. This appears to be very rare in practice. TODO Perhaps we should gather statistics to be sure. ------------------------------------------------------------ Note [Adjusting right-hand sides] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There's a bit of a dance we need to do after analysing a lambda expression or a right-hand side. In particular, we need to a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot lambda, or a non-recursive join point; and b) call 'markAllNonTailCalled' *unless* the binding is for a join point. Some examples, with how the free occurrences in e (assumed not to be a value lambda) get marked: inside lam non-tail-called ------------------------------------------------------------ let x = e No Yes let f = \x -> e Yes Yes let f = \x{OneShot} -> e No Yes \x -> e Yes Yes join j x = e No No joinrec j x = e Yes No There are a few other caveats; most importantly, if we're marking a binding as 'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so that the effect cascades properly. Consequently, at the time the RHS is analysed, we won't know what adjustments to make; thus 'occAnalLamOrRhs' must return the unadjusted 'UsageDetails', to be adjusted by 'adjustRhsUsage' once join-point-hood has been decided. Thus the overall sequence taking place in 'occAnalNonRecBind' and 'occAnalRecBind' is as follows: 1. Call 'occAnalLamOrRhs' to find usage information for the RHS. 2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make the binding a join point. 3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when recursive.) (In the recursive case, this logic is spread between 'makeNode' and 'occAnalRec'.) -} ------------------------------------------------------------------ -- occAnalBind ------------------------------------------------------------------ occAnalBind :: OccEnv -- The incoming OccEnv -> TopLevelFlag -> ImpRuleEdges -> CoreBind -> UsageDetails -- Usage details of scope -> (UsageDetails, -- Of the whole let(rec) [CoreBind]) occAnalBind env lvl top_env (NonRec binder rhs) body_usage = occAnalNonRecBind env lvl top_env binder rhs body_usage occAnalBind env lvl top_env (Rec pairs) body_usage = occAnalRecBind env lvl top_env pairs body_usage ----------------- occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr -> UsageDetails -> (UsageDetails, [CoreBind]) occAnalNonRecBind env lvl imp_rule_edges binder rhs body_usage | isTyVar binder -- A type let; we don't gather usage info = (body_usage, [NonRec binder rhs]) | not (binder `usedIn` body_usage) -- It's not mentioned = (body_usage, []) | otherwise -- It's mentioned in the body = (body_usage' `andUDs` rhs_usage', [NonRec tagged_binder rhs']) where (body_usage', tagged_binder) = tagNonRecBinder lvl body_usage binder mb_join_arity = willBeJoinId_maybe tagged_binder (bndrs, body) = collectBinders rhs (rhs_usage1, bndrs', body') = occAnalNonRecRhs env tagged_binder bndrs body rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body' -- For a /non-recursive/ join point we can mark all -- its join-lambda as one-shot; and it's a good idea to do so -- Unfoldings -- See Note [Unfoldings and join points] rhs_usage2 = case occAnalUnfolding env NonRecursive binder of Just unf_usage -> rhs_usage1 `andUDs` unf_usage Nothing -> rhs_usage1 -- Rules -- See Note [Rules are extra RHSs] and Note [Rule dependency info] rules_w_uds = occAnalRules env mb_join_arity NonRecursive tagged_binder rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds rhs_usage3 = foldr andUDs rhs_usage2 rule_uds rhs_usage4 = case lookupVarEnv imp_rule_edges binder of Nothing -> rhs_usage3 Just vs -> addManyOccsSet rhs_usage3 vs -- See Note [Preventing loops due to imported functions rules] -- Final adjustment rhs_usage' = adjustRhsUsage mb_join_arity NonRecursive bndrs' rhs_usage4 ----------------- occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)] -> UsageDetails -> (UsageDetails, [CoreBind]) occAnalRecBind env lvl imp_rule_edges pairs body_usage = foldr (occAnalRec env lvl) (body_usage, []) sccs -- For a recursive group, we -- * occ-analyse all the RHSs -- * compute strongly-connected components -- * feed those components to occAnalRec -- See Note [Recursive bindings: the grand plan] where sccs :: [SCC Details] sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesUniq nodes nodes :: [LetrecNode] nodes = {-# SCC "occAnalBind.assoc" #-} map (makeNode env imp_rule_edges bndr_set) pairs bndr_set = mkVarSet (map fst pairs) {- Note [Unfoldings and join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We assume that anything in an unfolding occurs multiple times, since unfoldings are often copied (that's the whole point!). But we still need to track tail calls for the purpose of finding join points. -} ----------------------------- occAnalRec :: OccEnv -> TopLevelFlag -> SCC Details -> (UsageDetails, [CoreBind]) -> (UsageDetails, [CoreBind]) -- The NonRec case is just like a Let (NonRec ...) above occAnalRec _ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs , nd_uds = rhs_uds, nd_rhs_bndrs = rhs_bndrs })) (body_uds, binds) | not (bndr `usedIn` body_uds) = (body_uds, binds) -- See Note [Dead code] | otherwise -- It's mentioned in the body = (body_uds' `andUDs` rhs_uds', NonRec tagged_bndr rhs : binds) where (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr rhs_uds' = adjustRhsUsage (willBeJoinId_maybe tagged_bndr) NonRecursive rhs_bndrs rhs_uds -- The Rec case is the interesting one -- See Note [Recursive bindings: the grand plan] -- See Note [Loop breaking] occAnalRec env lvl (CyclicSCC details_s) (body_uds, binds) | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds = (body_uds, binds) -- See Note [Dead code] | otherwise -- At this point we always build a single Rec = -- pprTrace "occAnalRec" (vcat -- [ text "weak_fvs" <+> ppr weak_fvs -- , text "lb nodes" <+> ppr loop_breaker_nodes]) (final_uds, Rec pairs : binds) where bndrs = map nd_bndr details_s bndr_set = mkVarSet bndrs ------------------------------ -- See Note [Choosing loop breakers] for loop_breaker_nodes final_uds :: UsageDetails loop_breaker_nodes :: [LetrecNode] (final_uds, loop_breaker_nodes) = mkLoopBreakerNodes env lvl bndr_set body_uds details_s ------------------------------ weak_fvs :: VarSet weak_fvs = mapUnionVarSet nd_weak details_s --------------------------- -- Now reconstruct the cycle pairs :: [(Id,CoreExpr)] pairs | isEmptyVarSet weak_fvs = reOrderNodes 0 bndr_set weak_fvs loop_breaker_nodes [] | otherwise = loopBreakNodes 0 bndr_set weak_fvs loop_breaker_nodes [] -- If weak_fvs is empty, the loop_breaker_nodes will include -- all the edges in the original scope edges [remember, -- weak_fvs is the difference between scope edges and -- lb-edges], so a fresh SCC computation would yield a -- single CyclicSCC result; and reOrderNodes deals with -- exactly that case ------------------------------------------------------------------ -- Loop breaking ------------------------------------------------------------------ type Binding = (Id,CoreExpr) loopBreakNodes :: Int -> VarSet -- All binders -> VarSet -- Binders whose dependencies may be "missing" -- See Note [Weak loop breakers] -> [LetrecNode] -> [Binding] -- Append these to the end -> [Binding] {- loopBreakNodes is applied to the list of nodes for a cyclic strongly connected component (there's guaranteed to be a cycle). It returns the same nodes, but a) in a better order, b) with some of the Ids having a IAmALoopBreaker pragma The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means that the simplifier can guarantee not to loop provided it never records an inlining for these no-inline guys. Furthermore, the order of the binds is such that if we neglect dependencies on the no-inline Ids then the binds are topologically sorted. This means that the simplifier will generally do a good job if it works from top bottom, recording inlinings for any Ids which aren't marked as "no-inline" as it goes. -} -- Return the bindings sorted into a plausible order, and marked with loop breakers. loopBreakNodes depth bndr_set weak_fvs nodes binds = -- pprTrace "loopBreakNodes" (ppr nodes) $ go (stronglyConnCompFromEdgedVerticesUniqR nodes) binds where go [] binds = binds go (scc:sccs) binds = loop_break_scc scc (go sccs binds) loop_break_scc scc binds = case scc of AcyclicSCC node -> mk_non_loop_breaker weak_fvs node : binds CyclicSCC nodes -> reOrderNodes depth bndr_set weak_fvs nodes binds ---------------------------------- reOrderNodes :: Int -> VarSet -> VarSet -> [LetrecNode] -> [Binding] -> [Binding] -- Choose a loop breaker, mark it no-inline, -- and call loopBreakNodes on the rest reOrderNodes _ _ _ [] _ = panic "reOrderNodes" reOrderNodes _ _ _ [node] binds = mk_loop_breaker node : binds reOrderNodes depth bndr_set weak_fvs (node : nodes) binds = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen -- , text "chosen" <+> ppr chosen_nodes ]) $ loopBreakNodes new_depth bndr_set weak_fvs unchosen $ (map mk_loop_breaker chosen_nodes ++ binds) where (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb (nd_score (node_payload node)) [node] [] nodes approximate_lb = depth >= 2 new_depth | approximate_lb = 0 | otherwise = depth+1 -- After two iterations (d=0, d=1) give up -- and approximate, returning to d=0 mk_loop_breaker :: LetrecNode -> Binding mk_loop_breaker (node_payload -> ND { nd_bndr = bndr, nd_rhs = rhs}) = (bndr `setIdOccInfo` strongLoopBreaker { occ_tail = tail_info }, rhs) where tail_info = tailCallInfo (idOccInfo bndr) mk_non_loop_breaker :: VarSet -> LetrecNode -> Binding -- See Note [Weak loop breakers] mk_non_loop_breaker weak_fvs (node_payload -> ND { nd_bndr = bndr , nd_rhs = rhs}) | bndr `elemVarSet` weak_fvs = (setIdOccInfo bndr occ', rhs) | otherwise = (bndr, rhs) where occ' = weakLoopBreaker { occ_tail = tail_info } tail_info = tailCallInfo (idOccInfo bndr) ---------------------------------- chooseLoopBreaker :: Bool -- True <=> Too many iterations, -- so approximate -> NodeScore -- Best score so far -> [LetrecNode] -- Nodes with this score -> [LetrecNode] -- Nodes with higher scores -> [LetrecNode] -- Unprocessed nodes -> ([LetrecNode], [LetrecNode]) -- This loop looks for the bind with the lowest score -- to pick as the loop breaker. The rest accumulate in chooseLoopBreaker _ _ loop_nodes acc [] = (loop_nodes, acc) -- Done -- If approximate_loop_breaker is True, we pick *all* -- nodes with lowest score, else just one -- See Note [Complexity of loop breaking] chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes) | approx_lb , rank sc == rank loop_sc = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes | sc `betterLB` loop_sc -- Better score so pick this new one = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes | otherwise -- Worse score so don't pick it = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes where sc = nd_score (node_payload node) {- Note [Complexity of loop breaking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The loop-breaking algorithm knocks out one binder at a time, and performs a new SCC analysis on the remaining binders. That can behave very badly in tightly-coupled groups of bindings; in the worst case it can be (N**2)*log N, because it does a full SCC on N, then N-1, then N-2 and so on. To avoid this, we switch plans after 2 (or whatever) attempts: Plan A: pick one binder with the lowest score, make it a loop breaker, and try again Plan B: pick *all* binders with the lowest score, make them all loop breakers, and try again Since there are only a small finite number of scores, this will terminate in a constant number of iterations, rather than O(N) iterations. You might thing that it's very unlikely, but RULES make it much more likely. Here's a real example from #1969: Rec { $dm = \d.\x. op d {-# RULES forall d. $dm Int d = $s$dm1 forall d. $dm Bool d = $s$dm2 #-} dInt = MkD .... opInt ... dInt = MkD .... opBool ... opInt = $dm dInt opBool = $dm dBool $s$dm1 = \x. op dInt $s$dm2 = \x. op dBool } The RULES stuff means that we can't choose $dm as a loop breaker (Note [Choosing loop breakers]), so we must choose at least (say) opInt *and* opBool, and so on. The number of loop breakders is linear in the number of instance declarations. Note [Loop breakers and INLINE/INLINABLE pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Avoid choosing a function with an INLINE pramga as the loop breaker! If such a function is mutually-recursive with a non-INLINE thing, then the latter should be the loop-breaker. It's vital to distinguish between INLINE and INLINABLE (the Bool returned by hasStableCoreUnfolding_maybe). If we start with Rec { {-# INLINABLE f #-} f x = ...f... } and then worker/wrapper it through strictness analysis, we'll get Rec { {-# INLINABLE $wf #-} $wf p q = let x = (p,q) in ...f... {-# INLINE f #-} f x = case x of (p,q) -> $wf p q } Now it is vital that we choose $wf as the loop breaker, so we can inline 'f' in '$wf'. Note [DFuns should not be loop breakers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's particularly bad to make a DFun into a loop breaker. See Note [How instance declarations are translated] in TcInstDcls We give DFuns a higher score than ordinary CONLIKE things because if there's a choice we want the DFun to be the non-loop breaker. Eg rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC) $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE) {-# DFUN #-} $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC) } Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it if we can't unravel the DFun first. Note [Constructor applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's really really important to inline dictionaries. Real example (the Enum Ordering instance from GHC.Base): rec f = \ x -> case d of (p,q,r) -> p x g = \ x -> case d of (p,q,r) -> q x d = (v, f, g) Here, f and g occur just once; but we can't inline them into d. On the other hand we *could* simplify those case expressions if we didn't stupidly choose d as the loop breaker. But we won't because constructor args are marked "Many". Inlining dictionaries is really essential to unravelling the loops in static numeric dictionaries, see GHC.Float. Note [Closure conversion] ~~~~~~~~~~~~~~~~~~~~~~~~~ We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm. The immediate motivation came from the result of a closure-conversion transformation which generated code like this: data Clo a b = forall c. Clo (c -> a -> b) c ($:) :: Clo a b -> a -> b Clo f env $: x = f env x rec { plus = Clo plus1 () ; plus1 _ n = Clo plus2 n ; plus2 Zero n = n ; plus2 (Succ m) n = Succ (plus $: m $: n) } If we inline 'plus' and 'plus1', everything unravels nicely. But if we choose 'plus1' as the loop breaker (which is entirely possible otherwise), the loop does not unravel nicely. @occAnalUnfolding@ deals with the question of bindings where the Id is marked by an INLINE pragma. For these we record that anything which occurs in its RHS occurs many times. This pessimistically assumes that this inlined binder also occurs many times in its scope, but if it doesn't we'll catch it next time round. At worst this costs an extra simplifier pass. ToDo: try using the occurrence info for the inline'd binder. [March 97] We do the same for atomic RHSs. Reason: see notes with loopBreakSCC. [June 98, SLPJ] I've undone this change; I don't understand it. See notes with loopBreakSCC. ************************************************************************ * * Making nodes * * ************************************************************************ -} type ImpRuleEdges = IdEnv IdSet -- Mapping from FVs of imported RULE LHSs to RHS FVs noImpRuleEdges :: ImpRuleEdges noImpRuleEdges = emptyVarEnv type LetrecNode = Node Unique Details -- Node comes from Digraph -- The Unique key is gotten from the Id data Details = ND { nd_bndr :: Id -- Binder , nd_rhs :: CoreExpr -- RHS, already occ-analysed , nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS -- INVARIANT: (nd_rhs_bndrs nd, _) == -- collectBinders (nd_rhs nd) , nd_uds :: UsageDetails -- Usage from RHS, and RULES, and stable unfoldings -- ignoring phase (ie assuming all are active) -- See Note [Forming Rec groups] , nd_inl :: IdSet -- Free variables of -- the stable unfolding (if present and active) -- or the RHS (if not) -- but excluding any RULES -- This is the IdSet that may be used if the Id is inlined , nd_weak :: IdSet -- Binders of this Rec that are mentioned in nd_uds -- but are *not* in nd_inl. These are the ones whose -- dependencies might not be respected by loop_breaker_nodes -- See Note [Weak loop breakers] , nd_active_rule_fvs :: IdSet -- Free variables of the RHS of active RULES , nd_score :: NodeScore } instance Outputable Details where ppr nd = text "ND" <> braces (sep [ text "bndr =" <+> ppr (nd_bndr nd) , text "uds =" <+> ppr (nd_uds nd) , text "inl =" <+> ppr (nd_inl nd) , text "weak =" <+> ppr (nd_weak nd) , text "rule =" <+> ppr (nd_active_rule_fvs nd) , text "score =" <+> ppr (nd_score nd) ]) -- The NodeScore is compared lexicographically; -- e.g. lower rank wins regardless of size type NodeScore = ( Int -- Rank: lower => more likely to be picked as loop breaker , Int -- Size of rhs: higher => more likely to be picked as LB -- Maxes out at maxExprSize; we just use it to prioritise -- small functions , Bool ) -- Was it a loop breaker before? -- True => more likely to be picked -- Note [Loop breakers, node scoring, and stability] rank :: NodeScore -> Int rank (r, _, _) = r makeNode :: OccEnv -> ImpRuleEdges -> VarSet -> (Var, CoreExpr) -> LetrecNode -- See Note [Recursive bindings: the grand plan] makeNode env imp_rule_edges bndr_set (bndr, rhs) = DigraphNode details (varUnique bndr) (nonDetKeysUniqSet node_fvs) -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR -- is still deterministic with edges in nondeterministic order as -- explained in Note [Deterministic SCC] in Digraph. where details = ND { nd_bndr = bndr , nd_rhs = rhs' , nd_rhs_bndrs = bndrs' , nd_uds = rhs_usage3 , nd_inl = inl_fvs , nd_weak = node_fvs `minusVarSet` inl_fvs , nd_active_rule_fvs = active_rule_fvs , nd_score = pprPanic "makeNodeDetails" (ppr bndr) } -- Constructing the edges for the main Rec computation -- See Note [Forming Rec groups] (bndrs, body) = collectBinders rhs (rhs_usage1, bndrs', body') = occAnalRecRhs env bndrs body rhs' = mkLams bndrs' body' rhs_usage2 = foldr andUDs rhs_usage1 rule_uds -- Note [Rules are extra RHSs] -- Note [Rule dependency info] rhs_usage3 = case mb_unf_uds of Just unf_uds -> rhs_usage2 `andUDs` unf_uds Nothing -> rhs_usage2 node_fvs = udFreeVars bndr_set rhs_usage3 -- Finding the free variables of the rules is_active = occ_rule_act env :: Activation -> Bool rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)] rules_w_uds = occAnalRules env (Just (length bndrs)) Recursive bndr rules_w_rhs_fvs :: [(Activation, VarSet)] -- Find the RHS fvs rules_w_rhs_fvs = maybe id (\ids -> ((AlwaysActive, ids):)) (lookupVarEnv imp_rule_edges bndr) -- See Note [Preventing loops due to imported functions rules] [ (ru_act rule, udFreeVars bndr_set rhs_uds) | (rule, _, rhs_uds) <- rules_w_uds ] rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_rhs_fvs , is_active a] -- Finding the usage details of the INLINE pragma (if any) mb_unf_uds = occAnalUnfolding env Recursive bndr -- Find the "nd_inl" free vars; for the loop-breaker phase inl_fvs = case mb_unf_uds of Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS Just unf_uds -> udFreeVars bndr_set unf_uds -- We could check for an *active* INLINE (returning -- emptyVarSet for an inactive one), but is_active -- isn't the right thing (it tells about -- RULE activation), so we'd need more plumbing mkLoopBreakerNodes :: OccEnv -> TopLevelFlag -> VarSet -> UsageDetails -- for BODY of let -> [Details] -> (UsageDetails, -- adjusted [LetrecNode]) -- Does four things -- a) tag each binder with its occurrence info -- b) add a NodeScore to each node -- c) make a Node with the right dependency edges for -- the loop-breaker SCC analysis -- d) adjust each RHS's usage details according to -- the binder's (new) shotness and join-point-hood mkLoopBreakerNodes env lvl bndr_set body_uds details_s = (final_uds, zipWith mk_lb_node details_s bndrs') where (final_uds, bndrs') = tagRecBinders lvl body_uds [ ((nd_bndr nd) ,(nd_uds nd) ,(nd_rhs_bndrs nd)) | nd <- details_s ] mk_lb_node nd@(ND { nd_bndr = bndr, nd_rhs = rhs, nd_inl = inl_fvs }) bndr' = DigraphNode nd' (varUnique bndr) (nonDetKeysUniqSet lb_deps) -- It's OK to use nonDetKeysUniqSet here as -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges -- in nondeterministic order as explained in -- Note [Deterministic SCC] in Digraph. where nd' = nd { nd_bndr = bndr', nd_score = score } score = nodeScore env bndr bndr' rhs lb_deps lb_deps = extendFvs_ rule_fv_env inl_fvs rule_fv_env :: IdEnv IdSet -- Maps a variable f to the variables from this group -- mentioned in RHS of active rules for f -- Domain is *subset* of bound vars (others have no rule fvs) rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs) init_rule_fvs -- See Note [Finding rule RHS free vars] = [ (b, trimmed_rule_fvs) | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set , not (isEmptyVarSet trimmed_rule_fvs) ] ------------------------------------------ nodeScore :: OccEnv -> Id -- Binder has old occ-info (just for loop-breaker-ness) -> Id -- Binder with new occ-info -> CoreExpr -- RHS -> VarSet -- Loop-breaker dependencies -> NodeScore nodeScore env old_bndr new_bndr bind_rhs lb_deps | not (isId old_bndr) -- A type or cercion variable is never a loop breaker = (100, 0, False) | old_bndr `elemVarSet` lb_deps -- Self-recursive things are great loop breakers = (0, 0, True) -- See Note [Self-recursion and loop breakers] | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has = (0, 0, True) -- a NOINLINE pragma) makes a great loop breaker | exprIsTrivial rhs = mk_score 10 -- Practically certain to be inlined -- Used to have also: && not (isExportedId bndr) -- But I found this sometimes cost an extra iteration when we have -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } -- where df is the exported dictionary. Then df makes a really -- bad choice for loop breaker | DFunUnfolding { df_args = args } <- id_unfolding -- Never choose a DFun as a loop breaker -- Note [DFuns should not be loop breakers] = (9, length args, is_lb) -- Data structures are more important than INLINE pragmas -- so that dictionary/method recursion unravels | CoreUnfolding { uf_guidance = UnfWhen {} } <- id_unfolding = mk_score 6 | is_con_app rhs -- Data types help with cases: = mk_score 5 -- Note [Constructor applications] | isStableUnfolding id_unfolding , can_unfold = mk_score 3 | isOneOcc (idOccInfo new_bndr) = mk_score 2 -- Likely to be inlined | can_unfold -- The Id has some kind of unfolding = mk_score 1 | otherwise = (0, 0, is_lb) where mk_score :: Int -> NodeScore mk_score rank = (rank, rhs_size, is_lb) is_lb = isStrongLoopBreaker (idOccInfo old_bndr) rhs = case id_unfolding of CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs } | isStableSource src -> unf_rhs _ -> bind_rhs -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding rhs_size = case id_unfolding of CoreUnfolding { uf_guidance = guidance } | UnfIfGoodArgs { ug_size = size } <- guidance -> size _ -> cheapExprSize rhs can_unfold = canUnfold id_unfolding id_unfolding = realIdUnfolding old_bndr -- realIdUnfolding: Ignore loop-breaker-ness here because -- that is what we are setting! -- Checking for a constructor application -- Cheap and cheerful; the simplifier moves casts out of the way -- The lambda case is important to spot x = /\a. C (f a) -- which comes up when C is a dictionary constructor and -- f is a default method. -- Example: the instance for Show (ST s a) in GHC.ST -- -- However we *also* treat (\x. C p q) as a con-app-like thing, -- Note [Closure conversion] is_con_app (Var v) = isConLikeId v is_con_app (App f _) = is_con_app f is_con_app (Lam _ e) = is_con_app e is_con_app (Tick _ e) = is_con_app e is_con_app _ = False maxExprSize :: Int maxExprSize = 20 -- Rather arbitrary cheapExprSize :: CoreExpr -> Int -- Maxes out at maxExprSize cheapExprSize e = go 0 e where go n e | n >= maxExprSize = n | otherwise = go1 n e go1 n (Var {}) = n+1 go1 n (Lit {}) = n+1 go1 n (Type {}) = n go1 n (Coercion {}) = n go1 n (Tick _ e) = go1 n e go1 n (Cast e _) = go1 n e go1 n (App f a) = go (go1 n f) a go1 n (Lam b e) | isTyVar b = go1 n e | otherwise = go (n+1) e go1 n (Let b e) = gos (go1 n e) (rhssOfBind b) go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as) gos n [] = n gos n (e:es) | n >= maxExprSize = n | otherwise = gos (go1 n e) es betterLB :: NodeScore -> NodeScore -> Bool -- If n1 `betterLB` n2 then choose n1 as the loop breaker betterLB (rank1, size1, lb1) (rank2, size2, _) | rank1 < rank2 = True | rank1 > rank2 = False | size1 < size2 = False -- Make the bigger n2 into the loop breaker | size1 > size2 = True | lb1 = True -- Tie-break: if n1 was a loop breaker before, choose it | otherwise = False -- See Note [Loop breakers, node scoring, and stability] {- Note [Self-recursion and loop breakers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have rec { f = ...f...g... ; g = .....f... } then 'f' has to be a loop breaker anyway, so we may as well choose it right away, so that g can inline freely. This is really just a cheap hack. Consider rec { f = ...g... ; g = ..f..h... ; h = ...f....} Here f or g are better loop breakers than h; but we might accidentally choose h. Finding the minimal set of loop breakers is hard. Note [Loop breakers, node scoring, and stability] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To choose a loop breaker, we give a NodeScore to each node in the SCC, and pick the one with the best score (according to 'betterLB'). We need to be jolly careful (#12425, #12234) about the stability of this choice. Suppose we have let rec { f = ...g...g... ; g = ...f...f... } in case x of True -> ...f.. False -> ..f... In each iteration of the simplifier the occurrence analyser OccAnal chooses a loop breaker. Suppose in iteration 1 it choose g as the loop breaker. That means it is free to inline f. Suppose that GHC decides to inline f in the branches of the case, but (for some reason; eg it is not saturated) in the rhs of g. So we get let rec { f = ...g...g... ; g = ...f...f... } in case x of True -> ...g...g..... False -> ..g..g.... Now suppose that, for some reason, in the next iteration the occurrence analyser chooses f as the loop breaker, so it can freely inline g. And again for some reason the simplifier inlines g at its calls in the case branches, but not in the RHS of f. Then we get let rec { f = ...g...g... ; g = ...f...f... } in case x of True -> ...(...f...f...)...(...f..f..)..... False -> ..(...f...f...)...(..f..f...).... You can see where this is going! Each iteration of the simplifier doubles the number of calls to f or g. No wonder GHC is slow! (In the particular example in comment:3 of #12425, f and g are the two mutually recursive fmap instances for CondT and Result. They are both marked INLINE which, oddly, is why they don't inline in each other's RHS, because the call there is not saturated.) The root cause is that we flip-flop on our choice of loop breaker. I always thought it didn't matter, and indeed for any single iteration to terminate, it doesn't matter. But when we iterate, it matters a lot!! So The Plan is this: If there is a tie, choose the node that was a loop breaker last time round Hence the is_lb field of NodeScore ************************************************************************ * * Right hand sides * * ************************************************************************ -} occAnalRhs :: OccEnv -> RecFlag -> Id -> [CoreBndr] -> CoreExpr -> (UsageDetails, [CoreBndr], CoreExpr) -- Returned usage details covers only the RHS, -- and *not* the RULE or INLINE template for the Id occAnalRhs env Recursive _ bndrs body = occAnalRecRhs env bndrs body occAnalRhs env NonRecursive id bndrs body = occAnalNonRecRhs env id bndrs body occAnalRecRhs :: OccEnv -> [CoreBndr] -> CoreExpr -- Rhs lambdas, body -> (UsageDetails, [CoreBndr], CoreExpr) -- Returned usage details covers only the RHS, -- and *not* the RULE or INLINE template for the Id occAnalRecRhs env bndrs body = occAnalLamOrRhs (rhsCtxt env) bndrs body occAnalNonRecRhs :: OccEnv -> Id -> [CoreBndr] -> CoreExpr -- Binder; rhs lams, body -- Binder is already tagged with occurrence info -> (UsageDetails, [CoreBndr], CoreExpr) -- Returned usage details covers only the RHS, -- and *not* the RULE or INLINE template for the Id occAnalNonRecRhs env bndr bndrs body = occAnalLamOrRhs rhs_env bndrs body where env1 | is_join_point = env -- See Note [Join point RHSs] | certainly_inline = env -- See Note [Cascading inlines] | otherwise = rhsCtxt env -- See Note [Sources of one-shot information] rhs_env = env1 { occ_one_shots = argOneShots dmd } certainly_inline -- See Note [Cascading inlines] = case occ of OneOcc { occ_in_lam = in_lam, occ_one_br = one_br } -> not in_lam && one_br && active && not_stable _ -> False is_join_point = isAlwaysTailCalled occ -- Like (isJoinId bndr) but happens one step earlier -- c.f. willBeJoinId_maybe occ = idOccInfo bndr dmd = idDemandInfo bndr active = isAlwaysActive (idInlineActivation bndr) not_stable = not (isStableUnfolding (idUnfolding bndr)) occAnalUnfolding :: OccEnv -> RecFlag -> Id -> Maybe UsageDetails -- Just the analysis, not a new unfolding. The unfolding -- got analysed when it was created and we don't need to -- update it. occAnalUnfolding env rec_flag id = case realIdUnfolding id of -- ignore previous loop-breaker flag CoreUnfolding { uf_tmpl = rhs, uf_src = src } | not (isStableSource src) -> Nothing | otherwise -> Just $ markAllMany usage where (bndrs, body) = collectBinders rhs (usage, _, _) = occAnalRhs env rec_flag id bndrs body DFunUnfolding { df_bndrs = bndrs, df_args = args } -> Just $ zapDetails (delDetailsList usage bndrs) where usage = andUDsList (map (fst . occAnal env) args) _ -> Nothing occAnalRules :: OccEnv -> Maybe JoinArity -- If the binder is (or MAY become) a join -- point, what its join arity is (or WOULD -- become). See Note [Rules and join points]. -> RecFlag -> Id -> [(CoreRule, -- Each (non-built-in) rule UsageDetails, -- Usage details for LHS UsageDetails)] -- Usage details for RHS occAnalRules env mb_expected_join_arity rec_flag id = [ (rule, lhs_uds, rhs_uds) | rule@Rule {} <- idCoreRules id , let (lhs_uds, rhs_uds) = occ_anal_rule rule ] where occ_anal_rule (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) = (lhs_uds, final_rhs_uds) where lhs_uds = addManyOccsSet emptyDetails $ (exprsFreeVars args `delVarSetList` bndrs) (rhs_bndrs, rhs_body) = collectBinders rhs (rhs_uds, _, _) = occAnalRhs env rec_flag id rhs_bndrs rhs_body -- Note [Rules are extra RHSs] -- Note [Rule dependency info] final_rhs_uds = adjust_tail_info args $ markAllMany $ (rhs_uds `delDetailsList` bndrs) occ_anal_rule _ = (emptyDetails, emptyDetails) adjust_tail_info args uds -- see Note [Rules and join points] = case mb_expected_join_arity of Just ar | args `lengthIs` ar -> uds _ -> markAllNonTailCalled uds {- Note [Join point RHSs] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider x = e join j = Just x We want to inline x into j right away, so we don't want to give the join point a RhsCtxt (#14137). It's not a huge deal, because the FloatIn pass knows to float into join point RHSs; and the simplifier does not float things out of join point RHSs. But it's a simple, cheap thing to do. See #14137. Note [Cascading inlines] ~~~~~~~~~~~~~~~~~~~~~~~~ By default we use an rhsCtxt for the RHS of a binding. This tells the occ anal n that it's looking at an RHS, which has an effect in occAnalApp. In particular, for constructor applications, it makes the arguments appear to have NoOccInfo, so that we don't inline into them. Thus x = f y k = Just x we do not want to inline x. But there's a problem. Consider x1 = a0 : [] x2 = a1 : x1 x3 = a2 : x2 g = f x3 First time round, it looks as if x1 and x2 occur as an arg of a let-bound constructor ==> give them a many-occurrence. But then x3 is inlined (unconditionally as it happens) and next time round, x2 will be, and the next time round x1 will be Result: multiple simplifier iterations. Sigh. So, when analysing the RHS of x3 we notice that x3 will itself definitely inline the next time round, and so we analyse x3's rhs in an ordinary context, not rhsCtxt. Hence the "certainly_inline" stuff. Annoyingly, we have to approximate SimplUtils.preInlineUnconditionally. If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and (b) certainly_inline says "yes" when preInlineUnconditionally says "no" then the simplifier iterates indefinitely: x = f y k = Just x -- We decide that k is 'certainly_inline' v = ...k... -- but preInlineUnconditionally doesn't inline it inline ==> k = Just (f y) v = ...k... float ==> x1 = f y k = Just x1 v = ...k... This is worse than the slow cascade, so we only want to say "certainly_inline" if it really is certain. Look at the note with preInlineUnconditionally for the various clauses. ************************************************************************ * * Expressions * * ************************************************************************ -} occAnal :: OccEnv -> CoreExpr -> (UsageDetails, -- Gives info only about the "interesting" Ids CoreExpr) occAnal _ expr@(Type _) = (emptyDetails, expr) occAnal _ expr@(Lit _) = (emptyDetails, expr) occAnal env expr@(Var _) = occAnalApp env (expr, [], []) -- At one stage, I gathered the idRuleVars for the variable here too, -- which in a way is the right thing to do. -- But that went wrong right after specialisation, when -- the *occurrences* of the overloaded function didn't have any -- rules in them, so the *specialised* versions looked as if they -- weren't used at all. occAnal _ (Coercion co) = (addManyOccsSet emptyDetails (coVarsOfCo co), Coercion co) -- See Note [Gather occurrences of coercion variables] {- Note [Gather occurrences of coercion variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to gather info about what coercion variables appear, so that we can sort them into the right place when doing dependency analysis. -} occAnal env (Tick tickish body) | SourceNote{} <- tickish = (usage, Tick tickish body') -- SourceNotes are best-effort; so we just proceed as usual. -- If we drop a tick due to the issues described below it's -- not the end of the world. | tickish `tickishScopesLike` SoftScope = (markAllNonTailCalled usage, Tick tickish body') | Breakpoint _ ids <- tickish = (usage_lam `andUDs` foldr addManyOccs emptyDetails ids, Tick tickish body') -- never substitute for any of the Ids in a Breakpoint | otherwise = (usage_lam, Tick tickish body') where !(usage,body') = occAnal env body -- for a non-soft tick scope, we can inline lambdas only usage_lam = markAllNonTailCalled (markAllInsideLam usage) -- TODO There may be ways to make ticks and join points play -- nicer together, but right now there are problems: -- let j x = ... in tick (j 1) -- Making j a join point may cause the simplifier to drop t -- (if the tick is put into the continuation). So we don't -- count j 1 as a tail call. -- See #14242. occAnal env (Cast expr co) = case occAnal env expr of { (usage, expr') -> let usage1 = zapDetailsIf (isRhsEnv env) usage -- usage1: if we see let x = y `cast` co -- then mark y as 'Many' so that we don't -- immediately inline y again. usage2 = addManyOccsSet usage1 (coVarsOfCo co) -- usage2: see Note [Gather occurrences of coercion variables] in (markAllNonTailCalled usage2, Cast expr' co) } occAnal env app@(App _ _) = occAnalApp env (collectArgsTicks tickishFloatable app) -- Ignore type variables altogether -- (a) occurrences inside type lambdas only not marked as InsideLam -- (b) type variables not in environment occAnal env (Lam x body) | isTyVar x = case occAnal env body of { (body_usage, body') -> (markAllNonTailCalled body_usage, Lam x body') } -- For value lambdas we do a special hack. Consider -- (\x. \y. ...x...) -- If we did nothing, x is used inside the \y, so would be marked -- as dangerous to dup. But in the common case where the abstraction -- is applied to two arguments this is over-pessimistic. -- So instead, we just mark each binder with its occurrence -- info in the *body* of the multiple lambda. -- Then, the simplifier is careful when partially applying lambdas. occAnal env expr@(Lam _ _) = case occAnalLamOrRhs env binders body of { (usage, tagged_binders, body') -> let expr' = mkLams tagged_binders body' usage1 = markAllNonTailCalled usage one_shot_gp = all isOneShotBndr tagged_binders final_usage | one_shot_gp = usage1 | otherwise = markAllInsideLam usage1 in (final_usage, expr') } where (binders, body) = collectBinders expr occAnal env (Case scrut bndr ty alts) = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') -> let alts_usage = foldr orUDs emptyDetails alts_usage_s (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr total_usage = markAllNonTailCalled scrut_usage `andUDs` alts_usage1 -- Alts can have tail calls, but the scrutinee can't in total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} where alt_env = mkAltEnv env scrut bndr occ_anal_alt = occAnalAlt alt_env occ_anal_scrut (Var v) (alt1 : other_alts) | not (null other_alts) || not (isDefaultAlt alt1) = (mkOneOcc env v True 0, Var v) -- The 'True' says that the variable occurs in an interesting -- context; the case has at least one non-default alternative occ_anal_scrut (Tick t e) alts | t `tickishScopesLike` SoftScope -- No reason to not look through all ticks here, but only -- for soft-scoped ticks we can do so without having to -- update returned occurance info (see occAnal) = second (Tick t) $ occ_anal_scrut e alts occ_anal_scrut scrut _alts = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt occAnal env (Let bind body) = case occAnal env body of { (body_usage, body') -> case occAnalBind env NotTopLevel noImpRuleEdges bind body_usage of { (final_usage, new_binds) -> (final_usage, mkLets new_binds body') }} occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr]) occAnalArgs _ [] _ = (emptyDetails, []) occAnalArgs env (arg:args) one_shots | isTypeArg arg = case occAnalArgs env args one_shots of { (uds, args') -> (uds, arg:args') } | otherwise = case argCtxt env one_shots of { (arg_env, one_shots') -> case occAnal arg_env arg of { (uds1, arg') -> case occAnalArgs env args one_shots' of { (uds2, args') -> (uds1 `andUDs` uds2, arg':args') }}} {- Applications are dealt with specially because we want the "build hack" to work. Note [Arguments of let-bound constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider f x = let y = expensive x in let z = (True,y) in (case z of {(p,q)->q}, case z of {(p,q)->q}) We feel free to duplicate the WHNF (True,y), but that means that y may be duplicated thereby. If we aren't careful we duplicate the (expensive x) call! Constructors are rather like lambdas in this way. -} occAnalApp :: OccEnv -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id]) -> (UsageDetails, Expr CoreBndr) occAnalApp env (Var fun, args, ticks) | null ticks = (uds, mkApps (Var fun) args') | otherwise = (uds, mkTicks ticks $ mkApps (Var fun) args') where uds = fun_uds `andUDs` final_args_uds !(args_uds, args') = occAnalArgs env args one_shots !final_args_uds | isRhsEnv env && is_exp = markAllNonTailCalled $ markAllInsideLam args_uds | otherwise = markAllNonTailCalled args_uds -- We mark the free vars of the argument of a constructor or PAP -- as "inside-lambda", if it is the RHS of a let(rec). -- This means that nothing gets inlined into a constructor or PAP -- argument position, which is what we want. Typically those -- constructor arguments are just variables, or trivial expressions. -- We use inside-lam because it's like eta-expanding the PAP. -- -- This is the *whole point* of the isRhsEnv predicate -- See Note [Arguments of let-bound constructors] n_val_args = valArgCount args n_args = length args fun_uds = mkOneOcc env fun (n_val_args > 0) n_args is_exp = isExpandableApp fun n_val_args -- See Note [CONLIKE pragma] in BasicTypes -- The definition of is_exp should match that in Simplify.prepareRhs one_shots = argsOneShots (idStrictness fun) guaranteed_val_args guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo (occ_one_shots env)) -- See Note [Sources of one-shot information], bullet point A'] occAnalApp env (fun, args, ticks) = (markAllNonTailCalled (fun_uds `andUDs` args_uds), mkTicks ticks $ mkApps fun' args') where !(fun_uds, fun') = occAnal (addAppCtxt env args) fun -- The addAppCtxt is a bit cunning. One iteration of the simplifier -- often leaves behind beta redexs like -- (\x y -> e) a1 a2 -- Here we would like to mark x,y as one-shot, and treat the whole -- thing much like a let. We do this by pushing some True items -- onto the context stack. !(args_uds, args') = occAnalArgs env args [] zapDetailsIf :: Bool -- If this is true -> UsageDetails -- Then do zapDetails on this -> UsageDetails zapDetailsIf True uds = zapDetails uds zapDetailsIf False uds = uds {- Note [Sources of one-shot information] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The occurrence analyser obtains one-shot-lambda information from two sources: A: Saturated applications: eg f e1 .. en In general, given a call (f e1 .. en) we can propagate one-shot info from f's strictness signature into e1 .. en, but /only/ if n is enough to saturate the strictness signature. A strictness signature like f :: C1(C1(L))LS means that *if f is applied to three arguments* then it will guarantee to call its first argument at most once, and to call the result of that at most once. But if f has fewer than three arguments, all bets are off; e.g. map (f (\x y. expensive) e2) xs Here the \x y abstraction may be called many times (once for each element of xs) so we should not mark x and y as one-shot. But if it was map (f (\x y. expensive) 3 2) xs then the first argument of f will be called at most once. The one-shot info, derived from f's strictness signature, is computed by 'argsOneShots', called in occAnalApp. A': Non-obviously saturated applications: eg build (f (\x y -> expensive)) where f is as above. In this case, f is only manifestly applied to one argument, so it does not look saturated. So by the previous point, we should not use its strictness signature to learn about the one-shotness of \x y. But in this case we can: build is fully applied, so we may use its strictness signature; and from that we learn that build calls its argument with two arguments *at most once*. So there is really only one call to f, and it will have three arguments. In that sense, f is saturated, and we may proceed as described above. Hence the computation of 'guaranteed_val_args' in occAnalApp, using '(occ_one_shots env)'. See also #13227, comment:9 B: Let-bindings: eg let f = \c. let ... in \n -> blah in (build f, build f) Propagate one-shot info from the demanand-info on 'f' to the lambdas in its RHS (which may not be syntactically at the top) This information must have come from a previous run of the demanand analyser. Previously, the demand analyser would *also* set the one-shot information, but that code was buggy (see #11770), so doing it only in on place, namely here, is saner. Note [OneShots] ~~~~~~~~~~~~~~~ When analysing an expression, the occ_one_shots argument contains information about how the function is being used. The length of the list indicates how many arguments will eventually be passed to the analysed expression, and the OneShotInfo indicates whether this application is once or multiple times. Example: Context of f occ_one_shots when analysing f f 1 2 [OneShot, OneShot] map (f 1) [OneShot, NoOneShotInfo] build f [OneShot, OneShot] f 1 2 `seq` f 2 1 [NoOneShotInfo, OneShot] Note [Binders in case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider case x of y { (a,b) -> f y } We treat 'a', 'b' as dead, because they don't physically occur in the case alternative. (Indeed, a variable is dead iff it doesn't occur in its scope in the output of OccAnal.) It really helps to know when binders are unused. See esp the call to isDeadBinder in Simplify.mkDupableAlt In this example, though, the Simplifier will bring 'a' and 'b' back to life, beause it binds 'y' to (a,b) (imagine got inlined and scrutinised y). -} occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr -> (UsageDetails, [CoreBndr], CoreExpr) occAnalLamOrRhs env [] body = case occAnal env body of (body_usage, body') -> (body_usage, [], body') -- RHS of thunk or nullary join point occAnalLamOrRhs env (bndr:bndrs) body | isTyVar bndr = -- Important: Keep the environment so that we don't inline into an RHS like -- \(@ x) -> C @x (f @x) -- (see the beginning of Note [Cascading inlines]). case occAnalLamOrRhs env bndrs body of (body_usage, bndrs', body') -> (body_usage, bndr:bndrs', body') occAnalLamOrRhs env binders body = case occAnal env_body body of { (body_usage, body') -> let (final_usage, tagged_binders) = tagLamBinders body_usage binders' -- Use binders' to put one-shot info on the lambdas in (final_usage, tagged_binders, body') } where (env_body, binders') = oneShotGroup env binders occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr)) -> CoreAlt -> (UsageDetails, Alt IdWithOccInfo) occAnalAlt (env, scrut_bind) (con, bndrs, rhs) = case occAnal env rhs of { (rhs_usage1, rhs1) -> let (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs -- See Note [Binders in case alternatives] (alt_usg', rhs2) = wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1 in (alt_usg', (con, tagged_bndrs, rhs2)) } wrapAltRHS :: OccEnv -> Maybe (Id, CoreExpr) -- proxy mapping generated by mkAltEnv -> UsageDetails -- usage for entire alt (p -> rhs) -> [Var] -- alt binders -> CoreExpr -- alt RHS -> (UsageDetails, CoreExpr) wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs | occ_binder_swap env , scrut_var `usedIn` alt_usg -- bndrs are not be present in alt_usg so this -- handles condition (a) in Note [Binder swap] , not captured -- See condition (b) in Note [Binder swap] = ( alt_usg' `andUDs` let_rhs_usg , Let (NonRec tagged_scrut_var let_rhs') alt_rhs ) where captured = any (`usedIn` let_rhs_usg) bndrs -- Check condition (b) -- The rhs of the let may include coercion variables -- if the scrutinee was a cast, so we must gather their -- usage. See Note [Gather occurrences of coercion variables] -- Moreover, the rhs of the let may mention the case-binder, and -- we want to gather its occ-info as well (let_rhs_usg, let_rhs') = occAnal env let_rhs (alt_usg', tagged_scrut_var) = tagLamBinder alt_usg scrut_var wrapAltRHS _ _ alt_usg _ alt_rhs = (alt_usg, alt_rhs) {- ************************************************************************ * * OccEnv * * ************************************************************************ -} data OccEnv = OccEnv { occ_encl :: !OccEncl -- Enclosing context information , occ_one_shots :: !OneShots -- See Note [OneShots] , occ_gbl_scrut :: GlobalScruts , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active , occ_rule_act :: Activation -> Bool -- Which rules are active -- See Note [Finding rule RHS free vars] , occ_binder_swap :: !Bool -- enable the binder_swap -- See CorePrep Note [Dead code in CorePrep] } type GlobalScruts = IdSet -- See Note [Binder swap on GlobalId scrutinees] ----------------------------- -- OccEncl is used to control whether to inline into constructor arguments -- For example: -- x = (p,q) -- Don't inline p or q -- y = /\a -> (p a, q a) -- Still don't inline p or q -- z = f (p,q) -- Do inline p,q; it may make a rule fire -- So OccEncl tells enough about the context to know what to do when -- we encounter a constructor application or PAP. data OccEncl = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda -- Don't inline into constructor args here | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. -- Do inline into constructor args here instance Outputable OccEncl where ppr OccRhs = text "occRhs" ppr OccVanilla = text "occVanilla" -- See note [OneShots] type OneShots = [OneShotInfo] initOccEnv :: OccEnv initOccEnv = OccEnv { occ_encl = OccVanilla , occ_one_shots = [] , occ_gbl_scrut = emptyVarSet -- To be conservative, we say that all -- inlines and rules are active , occ_unf_act = \_ -> True , occ_rule_act = \_ -> True , occ_binder_swap = True } vanillaCtxt :: OccEnv -> OccEnv vanillaCtxt env = env { occ_encl = OccVanilla, occ_one_shots = [] } rhsCtxt :: OccEnv -> OccEnv rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] } argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots]) argCtxt env [] = (env { occ_encl = OccVanilla, occ_one_shots = [] }, []) argCtxt env (one_shots:one_shots_s) = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s) isRhsEnv :: OccEnv -> Bool isRhsEnv (OccEnv { occ_encl = OccRhs }) = True isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False oneShotGroup :: OccEnv -> [CoreBndr] -> ( OccEnv , [CoreBndr] ) -- The result binders have one-shot-ness set that they might not have had originally. -- This happens in (build (\c n -> e)). Here the occurrence analyser -- linearity context knows that c,n are one-shot, and it records that fact in -- the binder. This is useful to guide subsequent float-in/float-out tranformations oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs = go ctxt bndrs [] where go ctxt [] rev_bndrs = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla } , reverse rev_bndrs ) go [] bndrs rev_bndrs = ( env { occ_one_shots = [], occ_encl = OccVanilla } , reverse rev_bndrs ++ bndrs ) go ctxt@(one_shot : ctxt') (bndr : bndrs) rev_bndrs | isId bndr = go ctxt' bndrs (bndr': rev_bndrs) | otherwise = go ctxt bndrs (bndr : rev_bndrs) where bndr' = updOneShotInfo bndr one_shot -- Use updOneShotInfo, not setOneShotInfo, as pre-existing -- one-shot info might be better than what we can infer, e.g. -- due to explicit use of the magic 'oneShot' function. -- See Note [The oneShot function] markJoinOneShots :: Maybe JoinArity -> [Var] -> [Var] -- Mark the lambdas of a non-recursive join point as one-shot. -- This is good to prevent gratuitous float-out etc markJoinOneShots mb_join_arity bndrs = case mb_join_arity of Nothing -> bndrs Just n -> go n bndrs where go 0 bndrs = bndrs go _ [] = [] -- This can legitimately happen. -- e.g. let j = case ... in j True -- This will become an arity-1 join point after the -- simplifier has eta-expanded it; but it may not have -- enough lambdas /yet/. (Lint checks that JoinIds do -- have enough lambdas.) go n (b:bs) = b' : go (n-1) bs where b' | isId b = setOneShotLambda b | otherwise = b addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt } transClosureFV :: UniqFM VarSet -> UniqFM VarSet -- If (f,g), (g,h) are in the input, then (f,h) is in the output -- as well as (f,g), (g,h) transClosureFV env | no_change = env | otherwise = transClosureFV (listToUFM new_fv_list) where (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env) -- It's OK to use nonDetUFMToList here because we'll forget the -- ordering by creating a new set with listToUFM bump no_change (b,fvs) | no_change_here = (no_change, (b,fvs)) | otherwise = (False, (b,new_fvs)) where (new_fvs, no_change_here) = extendFvs env fvs ------------- extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool) -- (extendFVs env s) returns -- (s `union` env(s), env(s) `subset` s) extendFvs env s | isNullUFM env = (s, True) | otherwise = (s `unionVarSet` extras, extras `subVarSet` s) where extras :: VarSet -- env(s) extras = nonDetFoldUFM unionVarSet emptyVarSet $ -- It's OK to use nonDetFoldUFM here because unionVarSet commutes intersectUFM_C (\x _ -> x) env (getUniqSet s) {- ************************************************************************ * * Binder swap * * ************************************************************************ Note [Binder swap] ~~~~~~~~~~~~~~~~~~ The "binder swap" tranformation swaps occurence of the scrutinee of a case for occurrences of the case-binder: (1) case x of b { pi -> ri } ==> case x of b { pi -> let x=b in ri } (2) case (x |> co) of b { pi -> ri } ==> case (x |> co) of b { pi -> let x = b |> sym co in ri } In both cases, the trivial 'let' can be eliminated by the immediately following simplifier pass. There are two reasons for making this swap: (A) It reduces the number of occurrences of the scrutinee, x. That in turn might reduce its occurrences to one, so we can inline it and save an allocation. E.g. let x = factorial y in case x of b { I# v -> ...x... } If we replace 'x' by 'b' in the alternative we get let x = factorial y in case x of b { I# v -> ...b... } and now we can inline 'x', thus case (factorial y) of b { I# v -> ...b... } (B) The case-binder b has unfolding information; in the example above we know that b = I# v. That in turn allows nested cases to simplify. Consider case x of b { I# v -> ...(case x of b2 { I# v2 -> rhs })... If we replace 'x' by 'b' in the alternative we get case x of b { I# v -> ...(case b of b2 { I# v2 -> rhs })... and now it is trivial to simplify the inner case: case x of b { I# v -> ...(let b2 = b in rhs)... The same can happen even if the scrutinee is a variable with a cast: see Note [Case of cast] In both cases, in a particular alternative (pi -> ri), we only add the binding if (a) x occurs free in (pi -> ri) (ie it occurs in ri, but is not bound in pi) (b) the pi does not bind b (or the free vars of co) We need (a) and (b) for the inserted binding to be correct. For the alternatives where we inject the binding, we can transfer all x's OccInfo to b. And that is the point. Notice that * The deliberate shadowing of 'x'. * That (a) rapidly becomes false, so no bindings are injected. The reason for doing these transformations /here in the occurrence analyser/ is because it allows us to adjust the OccInfo for 'x' and 'b' as we go. * Suppose the only occurrences of 'x' are the scrutinee and in the ri; then this transformation makes it occur just once, and hence get inlined right away. * If instead we do this in the Simplifier, we don't know whether 'x' is used in ri, so we are forced to pessimistically zap b's OccInfo even though it is typically dead (ie neither it nor x appear in the ri). There's nothing actually wrong with zapping it, except that it's kind of nice to know which variables are dead. My nose tells me to keep this information as robustly as possible. The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding {x=b}; it's Nothing if the binder-swap doesn't happen. There is a danger though. Consider let v = x +# y in case (f v) of w -> ...v...v... And suppose that (f v) expands to just v. Then we'd like to use 'w' instead of 'v' in the alternative. But it may be too late; we may have substituted the (cheap) x+#y for v in the same simplifier pass that reduced (f v) to v. I think this is just too bad. CSE will recover some of it. Note [Case of cast] ~~~~~~~~~~~~~~~~~~~ Consider case (x `cast` co) of b { I# -> ... (case (x `cast` co) of {...}) ... We'd like to eliminate the inner case. That is the motivation for equation (2) in Note [Binder swap]. When we get to the inner case, we inline x, cancel the casts, and away we go. Note [Binder swap on GlobalId scrutinees] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When the scrutinee is a GlobalId we must take care in two ways i) In order to *know* whether 'x' occurs free in the RHS, we need its occurrence info. BUT, we don't gather occurrence info for GlobalIds. That's the reason for the (small) occ_gbl_scrut env in OccEnv is for: it says "gather occurrence info for these". ii) We must call localiseId on 'x' first, in case it's a GlobalId, or has an External Name. See, for example, SimplEnv Note [Global Ids in the substitution]. Note [Zap case binders in proxy bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ From the original case x of cb(dead) { p -> ...x... } we will get case x of cb(live) { p -> let x = cb in ...x... } Core Lint never expects to find an *occurrence* of an Id marked as Dead, so we must zap the OccInfo on cb before making the binding x = cb. See #5028. NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier doesn't use it. So this is only to satisfy the perhpas-over-picky Lint. Historical note [no-case-of-case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We *used* to suppress the binder-swap in case expressions when -fno-case-of-case is on. Old remarks: "This happens in the first simplifier pass, and enhances full laziness. Here's the bad case: f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) If we eliminate the inner case, we trap it inside the I# v -> arm, which might prevent some full laziness happening. I've seen this in action in spectral/cichelli/Prog.hs: [(m,n) | m <- [1..max], n <- [1..max]] Hence the check for NoCaseOfCase." However, now the full-laziness pass itself reverses the binder-swap, so this check is no longer necessary. Historical note [Suppressing the case binder-swap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This old note describes a problem that is also fixed by doing the binder-swap in OccAnal: There is another situation when it might make sense to suppress the case-expression binde-swap. If we have case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } ...other cases .... } We'll perform the binder-swap for the outer case, giving case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } ...other cases .... } But there is no point in doing it for the inner case, because w1 can't be inlined anyway. Furthermore, doing the case-swapping involves zapping w2's occurrence info (see paragraphs that follow), and that forces us to bind w2 when doing case merging. So we get case x of w1 { A -> let w2 = w1 in e1 B -> let w2 = w1 in e2 ...other cases .... } This is plain silly in the common case where w2 is dead. Even so, I can't see a good way to implement this idea. I tried not doing the binder-swap if the scrutinee was already evaluated but that failed big-time: data T = MkT !Int case v of w { MkT x -> case x of x1 { I# y1 -> case x of x2 { I# y2 -> ... Notice that because MkT is strict, x is marked "evaluated". But to eliminate the last case, we must either make sure that x (as well as x1) has unfolding MkT y1. The straightforward thing to do is to do the binder-swap. So this whole note is a no-op. It's fixed by doing the binder-swap in OccAnal because we can do the binder-swap unconditionally and still get occurrence analysis information right. -} mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr)) -- Does three things: a) makes the occ_one_shots = OccVanilla -- b) extends the GlobalScruts if possible -- c) returns a proxy mapping, binding the scrutinee -- to the case binder, if possible mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr = case stripTicksTopE (const True) scrut of Var v -> add_scrut v case_bndr' Cast (Var v) co -> add_scrut v (Cast case_bndr' (mkSymCo co)) -- See Note [Case of cast] _ -> (env { occ_encl = OccVanilla }, Nothing) where add_scrut v rhs | isGlobalId v = (env { occ_encl = OccVanilla }, Nothing) | otherwise = ( env { occ_encl = OccVanilla , occ_gbl_scrut = pe `extendVarSet` v } , Just (localise v, rhs) ) -- ToDO: this isGlobalId stuff is a TEMPORARY FIX -- to avoid the binder-swap for GlobalIds -- See #16346 case_bndr' = Var (zapIdOccInfo case_bndr) -- See Note [Zap case binders in proxy bindings] -- Localise the scrut_var before shadowing it; we're making a -- new binding for it, and it might have an External Name, or -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] -- Also we don't want any INLINE or NOINLINE pragmas! localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var)) (idType scrut_var) {- ************************************************************************ * * \subsection[OccurAnal-types]{OccEnv} * * ************************************************************************ Note [UsageDetails and zapping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ On many occasions, we must modify all gathered occurrence data at once. For instance, all occurrences underneath a (non-one-shot) lambda set the 'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but that takes O(n) time and we will do this often---in particular, there are many places where tail calls are not allowed, and each of these causes all variables to get marked with 'NoTailCallInfo'. Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along with the 'OccInfoEnv'. Each of these extra environments is a "zapped set" recording which variables have been zapped in some way. Zapping all occurrence info then simply means setting the corresponding zapped set to the whole 'OccInfoEnv', a fast O(1) operation. -} type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage -- INVARIANT: never IAmDead -- (Deadness is signalled by not being in the map at all) type ZappedSet = OccInfoEnv -- Values are ignored data UsageDetails = UD { ud_env :: !OccInfoEnv , ud_z_many :: ZappedSet -- apply 'markMany' to these , ud_z_in_lam :: ZappedSet -- apply 'markInsideLam' to these , ud_z_no_tail :: ZappedSet } -- apply 'markNonTailCalled' to these -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv instance Outputable UsageDetails where ppr ud = ppr (ud_env (flattenUsageDetails ud)) ------------------- -- UsageDetails API andUDs, orUDs :: UsageDetails -> UsageDetails -> UsageDetails andUDs = combineUsageDetailsWith addOccInfo orUDs = combineUsageDetailsWith orOccInfo andUDsList :: [UsageDetails] -> UsageDetails andUDsList = foldl' andUDs emptyDetails mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails mkOneOcc env id int_cxt arity | isLocalId id = singleton $ OneOcc { occ_in_lam = False , occ_one_br = True , occ_int_cxt = int_cxt , occ_tail = AlwaysTailCalled arity } | id `elemVarSet` occ_gbl_scrut env = singleton noOccInfo | otherwise = emptyDetails where singleton info = emptyDetails { ud_env = unitVarEnv id info } addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails addOneOcc ud id info = ud { ud_env = extendVarEnv_C plus_zapped (ud_env ud) id info } `alterZappedSets` (`delVarEnv` id) where plus_zapped old new = doZapping ud id old `addOccInfo` new addManyOccsSet :: UsageDetails -> VarSet -> UsageDetails addManyOccsSet usage id_set = nonDetFoldUniqSet addManyOccs usage id_set -- It's OK to use nonDetFoldUFM here because addManyOccs commutes -- Add several occurrences, assumed not to be tail calls addManyOccs :: Var -> UsageDetails -> UsageDetails addManyOccs v u | isId v = addOneOcc u v noOccInfo | otherwise = u -- Give a non-committal binder info (i.e noOccInfo) because -- a) Many copies of the specialised thing can appear -- b) We don't want to substitute a BIG expression inside a RULE -- even if that's the only occurrence of the thing -- (Same goes for INLINE.) delDetails :: UsageDetails -> Id -> UsageDetails delDetails ud bndr = ud `alterUsageDetails` (`delVarEnv` bndr) delDetailsList :: UsageDetails -> [Id] -> UsageDetails delDetailsList ud bndrs = ud `alterUsageDetails` (`delVarEnvList` bndrs) emptyDetails :: UsageDetails emptyDetails = UD { ud_env = emptyVarEnv , ud_z_many = emptyVarEnv , ud_z_in_lam = emptyVarEnv , ud_z_no_tail = emptyVarEnv } isEmptyDetails :: UsageDetails -> Bool isEmptyDetails = isEmptyVarEnv . ud_env markAllMany, markAllInsideLam, markAllNonTailCalled, zapDetails :: UsageDetails -> UsageDetails markAllMany ud = ud { ud_z_many = ud_env ud } markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud } markAllNonTailCalled ud = ud { ud_z_no_tail = ud_env ud } zapDetails = markAllMany . markAllNonTailCalled -- effectively sets to noOccInfo lookupDetails :: UsageDetails -> Id -> OccInfo lookupDetails ud id | isCoVar id -- We do not currenly gather occurrence info (from types) = noOccInfo -- for CoVars, so we must conservatively mark them as used -- See Note [DoO not mark CoVars as dead] | otherwise = case lookupVarEnv (ud_env ud) id of Just occ -> doZapping ud id occ Nothing -> IAmDead usedIn :: Id -> UsageDetails -> Bool v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud udFreeVars :: VarSet -> UsageDetails -> VarSet -- Find the subset of bndrs that are mentioned in uds udFreeVars bndrs ud = restrictUniqSetToUFM bndrs (ud_env ud) {- Note [Do not mark CoVars as dead] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's obviously wrong to mark CoVars as dead if they are used. Currently we don't traverse types to gather usase info for CoVars, so we had better treat them as having noOccInfo. This showed up in #15696 we had something like case eq_sel d of co -> ...(typeError @(...co...) "urk")... Then 'd' was substitued by a dictionary, so the expression simpified to case (Coercion ) of co -> ...(typeError @(...co...) "urk")... But then the "drop the case altogether" equation of rebuildCase thought that 'co' was dead, and discarded the entire case. Urk! I have no idea how we managed to avoid this pitfall for so long! -} ------------------- -- Auxiliary functions for UsageDetails implementation combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo) -> UsageDetails -> UsageDetails -> UsageDetails combineUsageDetailsWith plus_occ_info ud1 ud2 | isEmptyDetails ud1 = ud2 | isEmptyDetails ud2 = ud1 | otherwise = UD { ud_env = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2) , ud_z_many = plusVarEnv (ud_z_many ud1) (ud_z_many ud2) , ud_z_in_lam = plusVarEnv (ud_z_in_lam ud1) (ud_z_in_lam ud2) , ud_z_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) } doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo doZapping ud var occ = doZappingByUnique ud (varUnique var) occ doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo doZappingByUnique ud uniq = (if | in_subset ud_z_many -> markMany | in_subset ud_z_in_lam -> markInsideLam | otherwise -> id) . (if | in_subset ud_z_no_tail -> markNonTailCalled | otherwise -> id) where in_subset field = uniq `elemVarEnvByKey` field ud alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails alterZappedSets ud f = ud { ud_z_many = f (ud_z_many ud) , ud_z_in_lam = f (ud_z_in_lam ud) , ud_z_no_tail = f (ud_z_no_tail ud) } alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails alterUsageDetails ud f = ud { ud_env = f (ud_env ud) } `alterZappedSets` f flattenUsageDetails :: UsageDetails -> UsageDetails flattenUsageDetails ud = ud { ud_env = mapUFM_Directly (doZappingByUnique ud) (ud_env ud) } `alterZappedSets` const emptyVarEnv ------------------- -- See Note [Adjusting right-hand sides] adjustRhsUsage :: Maybe JoinArity -> RecFlag -> [CoreBndr] -- Outer lambdas, AFTER occ anal -> UsageDetails -> UsageDetails adjustRhsUsage mb_join_arity rec_flag bndrs usage = maybe_mark_lam (maybe_drop_tails usage) where maybe_mark_lam ud | one_shot = ud | otherwise = markAllInsideLam ud maybe_drop_tails ud | exact_join = ud | otherwise = markAllNonTailCalled ud one_shot = case mb_join_arity of Just join_arity | isRec rec_flag -> False | otherwise -> all isOneShotBndr (drop join_arity bndrs) Nothing -> all isOneShotBndr bndrs exact_join = case mb_join_arity of Just join_arity -> bndrs `lengthIs` join_arity _ -> False type IdWithOccInfo = Id tagLamBinders :: UsageDetails -- Of scope -> [Id] -- Binders -> (UsageDetails, -- Details with binders removed [IdWithOccInfo]) -- Tagged binders tagLamBinders usage binders = usage' `seq` (usage', bndrs') where (usage', bndrs') = mapAccumR tagLamBinder usage binders tagLamBinder :: UsageDetails -- Of scope -> Id -- Binder -> (UsageDetails, -- Details with binder removed IdWithOccInfo) -- Tagged binders -- Used for lambda and case binders -- It copes with the fact that lambda bindings can have a -- stable unfolding, used for join points tagLamBinder usage bndr = (usage2, bndr') where occ = lookupDetails usage bndr bndr' = setBinderOcc (markNonTailCalled occ) bndr -- Don't try to make an argument into a join point usage1 = usage `delDetails` bndr usage2 | isId bndr = addManyOccsSet usage1 (idUnfoldingVars bndr) -- This is effectively the RHS of a -- non-join-point binding, so it's okay to use -- addManyOccsSet, which assumes no tail calls | otherwise = usage1 tagNonRecBinder :: TopLevelFlag -- At top level? -> UsageDetails -- Of scope -> CoreBndr -- Binder -> (UsageDetails, -- Details with binder removed IdWithOccInfo) -- Tagged binder tagNonRecBinder lvl usage binder = let occ = lookupDetails usage binder will_be_join = decideJoinPointHood lvl usage [binder] occ' | will_be_join = -- must already be marked AlwaysTailCalled ASSERT(isAlwaysTailCalled occ) occ | otherwise = markNonTailCalled occ binder' = setBinderOcc occ' binder usage' = usage `delDetails` binder in usage' `seq` (usage', binder') tagRecBinders :: TopLevelFlag -- At top level? -> UsageDetails -- Of body of let ONLY -> [(CoreBndr, -- Binder UsageDetails, -- RHS usage details [CoreBndr])] -- Lambdas in new RHS -> (UsageDetails, -- Adjusted details for whole scope, -- with binders removed [IdWithOccInfo]) -- Tagged binders -- Substantially more complicated than non-recursive case. Need to adjust RHS -- details *before* tagging binders (because the tags depend on the RHSes). tagRecBinders lvl body_uds triples = let (bndrs, rhs_udss, _) = unzip3 triples -- 1. Determine join-point-hood of whole group, as determined by -- the *unadjusted* usage details unadj_uds = foldr andUDs body_uds rhs_udss will_be_joins = decideJoinPointHood lvl unadj_uds bndrs -- 2. Adjust usage details of each RHS, taking into account the -- join-point-hood decision rhs_udss' = map adjust triples adjust (bndr, rhs_uds, rhs_bndrs) = adjustRhsUsage mb_join_arity Recursive rhs_bndrs rhs_uds where -- Can't use willBeJoinId_maybe here because we haven't tagged the -- binder yet (the tag depends on these adjustments!) mb_join_arity | will_be_joins , let occ = lookupDetails unadj_uds bndr , AlwaysTailCalled arity <- tailCallInfo occ = Just arity | otherwise = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if Nothing -- we are making join points! -- 3. Compute final usage details from adjusted RHS details adj_uds = foldr andUDs body_uds rhs_udss' -- 4. Tag each binder with its adjusted details bndrs' = [ setBinderOcc (lookupDetails adj_uds bndr) bndr | bndr <- bndrs ] -- 5. Drop the binders from the adjusted details and return usage' = adj_uds `delDetailsList` bndrs in (usage', bndrs') setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr setBinderOcc occ_info bndr | isTyVar bndr = bndr | isExportedId bndr = if isManyOccs (idOccInfo bndr) then bndr else setIdOccInfo bndr noOccInfo -- Don't use local usage info for visible-elsewhere things -- BUT *do* erase any IAmALoopBreaker annotation, because we're -- about to re-generate it and it shouldn't be "sticky" | otherwise = setIdOccInfo bndr occ_info -- | Decide whether some bindings should be made into join points or not. -- Returns `False` if they can't be join points. Note that it's an -- all-or-nothing decision, as if multiple binders are given, they're -- assumed to be mutually recursive. -- -- It must, however, be a final decision. If we say "True" for 'f', -- and then subsequently decide /not/ make 'f' into a join point, then -- the decision about another binding 'g' might be invalidated if (say) -- 'f' tail-calls 'g'. -- -- See Note [Invariants on join points] in CoreSyn. decideJoinPointHood :: TopLevelFlag -> UsageDetails -> [CoreBndr] -> Bool decideJoinPointHood TopLevel _ _ = False decideJoinPointHood NotTopLevel usage bndrs | isJoinId (head bndrs) = WARN(not all_ok, text "OccurAnal failed to rediscover join point(s):" <+> ppr bndrs) all_ok | otherwise = all_ok where -- See Note [Invariants on join points]; invariants cited by number below. -- Invariant 2 is always satisfiable by the simplifier by eta expansion. all_ok = -- Invariant 3: Either all are join points or none are all ok bndrs ok bndr | -- Invariant 1: Only tail calls, all same join arity AlwaysTailCalled arity <- tailCallInfo (lookupDetails usage bndr) , -- Invariant 1 as applied to LHSes of rules all (ok_rule arity) (idCoreRules bndr) -- Invariant 2a: stable unfoldings -- See Note [Join points and INLINE pragmas] , ok_unfolding arity (realIdUnfolding bndr) -- Invariant 4: Satisfies polymorphism rule , isValidJoinPointType arity (idType bndr) = True | otherwise = False ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans ok_rule join_arity (Rule { ru_args = args }) = args `lengthIs` join_arity -- Invariant 1 as applied to LHSes of rules -- ok_unfolding returns False if we should /not/ convert a non-join-id -- into a join-id, even though it is AlwaysTailCalled ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs }) = not (isStableSource src && join_arity > joinRhsArity rhs) ok_unfolding _ (DFunUnfolding {}) = False ok_unfolding _ _ = True willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity willBeJoinId_maybe bndr = case tailCallInfo (idOccInfo bndr) of AlwaysTailCalled arity -> Just arity _ -> isJoinId_maybe bndr {- Note [Join points and INLINE pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider f x = let g = \x. not -- Arity 1 {-# INLINE g #-} in case x of A -> g True True B -> g True False C -> blah2 Here 'g' is always tail-called applied to 2 args, but the stable unfolding captured by the INLINE pragma has arity 1. If we try to convert g to be a join point, its unfolding will still have arity 1 (since it is stable, and we don't meddle with stable unfoldings), and Lint will complain (see Note [Invariants on join points], (2a), in CoreSyn. #13413. Moreover, since g is going to be inlined anyway, there is no benefit from making it a join point. If it is recursive, and uselessly marked INLINE, this will stop us making it a join point, which is annoying. But occasionally (notably in class methods; see Note [Instances and loop breakers] in TcInstDcls) we mark recursive things as INLINE but the recursion unravels; so ignoring INLINE pragmas on recursive things isn't good either. See Invariant 2a of Note [Invariants on join points] in CoreSyn ************************************************************************ * * \subsection{Operations over OccInfo} * * ************************************************************************ -} markMany, markInsideLam, markNonTailCalled :: OccInfo -> OccInfo markMany IAmDead = IAmDead markMany occ = ManyOccs { occ_tail = occ_tail occ } markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = True } markInsideLam occ = occ markNonTailCalled IAmDead = IAmDead markNonTailCalled occ = occ { occ_tail = NoTailCallInfo } addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` tailCallInfo a2 } -- Both branches are at least One -- (Argument is never IAmDead) -- (orOccInfo orig new) is used -- when combining occurrence info from branches of a case orOccInfo (OneOcc { occ_in_lam = in_lam1, occ_int_cxt = int_cxt1 , occ_tail = tail1 }) (OneOcc { occ_in_lam = in_lam2, occ_int_cxt = int_cxt2 , occ_tail = tail2 }) = OneOcc { occ_one_br = False -- False, because it occurs in both branches , occ_in_lam = in_lam1 || in_lam2 , occ_int_cxt = int_cxt1 && int_cxt2 , occ_tail = tail1 `andTailCallInfo` tail2 } orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` tailCallInfo a2 } andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2) | arity1 == arity2 = info andTailCallInfo _ _ = NoTailCallInfo ghc-lib-parser-8.10.2.20200808/compiler/types/OptCoercion.hs0000644000000000000000000012344713713635745021260 0ustar0000000000000000-- (c) The University of Glasgow 2006 {-# LANGUAGE CPP #-} module OptCoercion ( optCoercion, checkAxInstCo ) where #include "GhclibHsVersions.h" import GhcPrelude import DynFlags import TyCoRep import TyCoSubst import Coercion import Type hiding( substTyVarBndr, substTy ) import TcType ( exactTyCoVarsOfType ) import TyCon import CoAxiom import VarSet import VarEnv import Outputable import FamInstEnv ( flattenTys ) import Pair import ListSetOps ( getNth ) import Util import Unify import InstEnv import Control.Monad ( zipWithM ) {- %************************************************************************ %* * Optimising coercions %* * %************************************************************************ Note [Optimising coercion optimisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Looking up a coercion's role or kind is linear in the size of the coercion. Thus, doing this repeatedly during the recursive descent of coercion optimisation is disastrous. We must be careful to avoid doing this if at all possible. Because it is generally easy to know a coercion's components' roles from the role of the outer coercion, we pass down the known role of the input in the algorithm below. We also keep functions opt_co2 and opt_co3 separate from opt_co4, so that the former two do Phantom checks that opt_co4 can avoid. This is a big win because Phantom coercions rarely appear within non-phantom coercions -- only in some TyConAppCos and some AxiomInstCos. We handle these cases specially by calling opt_co2. Note [Optimising InstCo] ~~~~~~~~~~~~~~~~~~~~~~~~ (1) tv is a type variable When we have (InstCo (ForAllCo tv h g) g2), we want to optimise. Let's look at the typing rules. h : k1 ~ k2 tv:k1 |- g : t1 ~ t2 ----------------------------- ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h]) g1 : (all tv:k1.t1') ~ (all tv:k2.t2') g2 : s1 ~ s2 -------------------- InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2] We thus want some coercion proving this: (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h]) If we substitute the *type* tv for the *coercion* (g2 ; t2 ~ t2 |> sym h) in g, we'll get this result exactly. This is bizarre, though, because we're substituting a type variable with a coercion. However, this operation already exists: it's called *lifting*, and defined in Coercion. We just need to enhance the lifting operation to be able to deal with an ambient substitution, which is why a LiftingContext stores a TCvSubst. (2) cv is a coercion variable Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise. h : (t1 ~r t2) ~N (t3 ~r t4) cv : t1 ~r t2 |- g : t1' ~r2 t2' n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3 n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4 ------------------------------------------------ ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2 (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2]) g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2') g2 : h1 ~N h2 h1 : t1 ~r t2 h2 : t3 ~r t4 ------------------------------------------------ InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2] We thus want some coercion proving this: t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2] So we substitute the coercion variable c for the coercion (h1 ~N (n1; h2; sym n2)) in g. -} optCoercion :: DynFlags -> TCvSubst -> Coercion -> NormalCo -- ^ optCoercion applies a substitution to a coercion, -- *and* optimises it to reduce its size optCoercion dflags env co | hasNoOptCoercion dflags = substCo env co | otherwise = optCoercion' env co optCoercion' :: TCvSubst -> Coercion -> NormalCo optCoercion' env co | debugIsOn = let out_co = opt_co1 lc False co (Pair in_ty1 in_ty2, in_role) = coercionKindRole co (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co in ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 && substTyUnchecked env in_ty2 `eqType` out_ty2 && in_role == out_role , text "optCoercion changed types!" $$ hang (text "in_co:") 2 (ppr co) $$ hang (text "in_ty1:") 2 (ppr in_ty1) $$ hang (text "in_ty2:") 2 (ppr in_ty2) $$ hang (text "out_co:") 2 (ppr out_co) $$ hang (text "out_ty1:") 2 (ppr out_ty1) $$ hang (text "out_ty2:") 2 (ppr out_ty2) $$ hang (text "subst:") 2 (ppr env) ) out_co | otherwise = opt_co1 lc False co where lc = mkSubstLiftingContext env type NormalCo = Coercion -- Invariants: -- * The substitution has been fully applied -- * For trans coercions (co1 `trans` co2) -- co1 is not a trans, and neither co1 nor co2 is identity type NormalNonIdCo = NormalCo -- Extra invariant: not the identity -- | Do we apply a @sym@ to the result? type SymFlag = Bool -- | Do we force the result to be representational? type ReprFlag = Bool -- | Optimize a coercion, making no assumptions. All coercions in -- the lifting context are already optimized (and sym'd if nec'y) opt_co1 :: LiftingContext -> SymFlag -> Coercion -> NormalCo opt_co1 env sym co = opt_co2 env sym (coercionRole co) co -- See Note [Optimising coercion optimisation] -- | Optimize a coercion, knowing the coercion's role. No other assumptions. opt_co2 :: LiftingContext -> SymFlag -> Role -- ^ The role of the input coercion -> Coercion -> NormalCo opt_co2 env sym Phantom co = opt_phantom env sym co opt_co2 env sym r co = opt_co3 env sym Nothing r co -- See Note [Optimising coercion optimisation] -- | Optimize a coercion, knowing the coercion's non-Phantom role. opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True r co -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore opt_co3 env sym _ r co = opt_co4_wrap env sym False r co -- See Note [Optimising coercion optimisation] -- | Optimize a non-phantom coercion. opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo opt_co4_wrap = opt_co4 {- opt_co4_wrap env sym rep r co = pprTrace "opt_co4_wrap {" ( vcat [ text "Sym:" <+> ppr sym , text "Rep:" <+> ppr rep , text "Role:" <+> ppr r , text "Co:" <+> ppr co ]) $ ASSERT( r == coercionRole co ) let result = opt_co4 env sym rep r co in pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $ result -} opt_co4 env _ rep r (Refl ty) = ASSERT2( r == Nominal, text "Expected role:" <+> ppr r $$ text "Found role:" <+> ppr Nominal $$ text "Type:" <+> ppr ty ) liftCoSubst (chooseRole rep r) env ty opt_co4 env _ rep r (GRefl _r ty MRefl) = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ text "Found role:" <+> ppr _r $$ text "Type:" <+> ppr ty ) liftCoSubst (chooseRole rep r) env ty opt_co4 env sym rep r (GRefl _r ty (MCo co)) = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ text "Found role:" <+> ppr _r $$ text "Type:" <+> ppr ty ) if isGReflCo co || isGReflCo co' then liftCoSubst r' env ty else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty) where r' = chooseRole rep r ty' = substTy (lcSubstLeft env) ty co' = opt_co4 env False False Nominal co opt_co4 env sym rep r (SymCo co) = opt_co4_wrap env (not sym) rep r co -- surprisingly, we don't have to do anything to the env here. This is -- because any "lifting" substitutions in the env are tied to ForAllCos, -- which treat their left and right sides differently. We don't want to -- exchange them. opt_co4 env sym rep r g@(TyConAppCo _r tc cos) = ASSERT( r == _r ) case (rep, r) of (True, Nominal) -> mkTyConAppCo Representational tc (zipWith3 (opt_co3 env sym) (map Just (tyConRolesRepresentational tc)) (repeat Nominal) cos) (False, Nominal) -> mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos) (_, Representational) -> -- must use opt_co2 here, because some roles may be P -- See Note [Optimising coercion optimisation] mkTyConAppCo r tc (zipWith (opt_co2 env sym) (tyConRolesRepresentational tc) -- the current roles cos) (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) opt_co4 env sym rep r (AppCo co1 co2) = mkAppCo (opt_co4_wrap env sym rep r co1) (opt_co4_wrap env sym False Nominal co2) opt_co4 env sym rep r (ForAllCo tv k_co co) = case optForAllCoBndr env sym tv k_co of (env', tv', k_co') -> mkForAllCo tv' k_co' $ opt_co4_wrap env' sym rep r co -- Use the "mk" functions to check for nested Refls opt_co4 env sym rep r (FunCo _r co1 co2) = ASSERT( r == _r ) if rep then mkFunCo Representational co1' co2' else mkFunCo r co1' co2' where co1' = opt_co4_wrap env sym rep r co1 co2' = opt_co4_wrap env sym rep r co2 opt_co4 env sym rep r (CoVarCo cv) | Just co <- lookupCoVar (lcTCvSubst env) cv = opt_co4_wrap (zapLiftingContext env) sym rep r co | ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl] = mkReflCo (chooseRole rep r) ty1 | otherwise = ASSERT( isCoVar cv1 ) wrapRole rep r $ wrapSym sym $ CoVarCo cv1 where Pair ty1 ty2 = coVarTypes cv1 cv1 = case lookupInScope (lcInScopeSet env) cv of Just cv1 -> cv1 Nothing -> WARN( True, text "opt_co: not in scope:" <+> ppr cv $$ ppr env) cv -- cv1 might have a substituted kind! opt_co4 _ _ _ _ (HoleCo h) = pprPanic "opt_univ fell into a hole" (ppr h) opt_co4 env sym rep r (AxiomInstCo con ind cos) -- Do *not* push sym inside top-level axioms -- e.g. if g is a top-level axiom -- g a : f a ~ a -- then (sym (g ty)) /= g (sym ty) !! = ASSERT( r == coAxiomRole con ) wrapRole rep (coAxiomRole con) $ wrapSym sym $ -- some sub-cos might be P: use opt_co2 -- See Note [Optimising coercion optimisation] AxiomInstCo con ind (zipWith (opt_co2 env False) (coAxBranchRoles (coAxiomNthBranch con ind)) cos) -- Note that the_co does *not* have sym pushed into it opt_co4 env sym rep r (UnivCo prov _r t1 t2) = ASSERT( r == _r ) opt_univ env sym prov (chooseRole rep r) t1 t2 opt_co4 env sym rep r (TransCo co1 co2) -- sym (g `o` h) = sym h `o` sym g | sym = opt_trans in_scope co2' co1' | otherwise = opt_trans in_scope co1' co2' where co1' = opt_co4_wrap env sym rep r co1 co2' = opt_co4_wrap env sym rep r co2 in_scope = lcInScopeSet env opt_co4 env _sym rep r (NthCo _r n co) | Just (ty, _) <- isReflCo_maybe co , Just (_tc, args) <- ASSERT( r == _r ) splitTyConApp_maybe ty = liftCoSubst (chooseRole rep r) env (args `getNth` n) | Just (ty, _) <- isReflCo_maybe co , n == 0 , Just (tv, _) <- splitForAllTy_maybe ty -- works for both tyvar and covar = liftCoSubst (chooseRole rep r) env (varType tv) opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos)) = ASSERT( r == r1 ) opt_co4_wrap env sym rep r (cos `getNth` n) opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _)) -- works for both tyvar and covar = ASSERT( r == _r ) ASSERT( n == 0 ) opt_co4_wrap env sym rep Nominal eta opt_co4 env sym rep r (NthCo _r n co) | TyConAppCo _ _ cos <- co' , let nth_co = cos `getNth` n = if rep && (r == Nominal) -- keep propagating the SubCo then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co else nth_co | ForAllCo _ eta _ <- co' = if rep then opt_co4_wrap (zapLiftingContext env) False True Nominal eta else eta | otherwise = wrapRole rep r $ NthCo r n co' where co' = opt_co1 env sym co opt_co4 env sym rep r (LRCo lr co) | Just pr_co <- splitAppCo_maybe co = ASSERT( r == Nominal ) opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co) | Just pr_co <- splitAppCo_maybe co' = ASSERT( r == Nominal ) if rep then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co) else pick_lr lr pr_co | otherwise = wrapRole rep Nominal $ LRCo lr co' where co' = opt_co4_wrap env sym False Nominal co pick_lr CLeft (l, _) = l pick_lr CRight (_, r) = r -- See Note [Optimising InstCo] opt_co4 env sym rep r (InstCo co1 arg) -- forall over type... | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1 = opt_co4_wrap (extendLiftingContext env tv (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg)) -- mkSymCo kind_co :: k1 ~ k2 -- sym_arg :: (t1 :: k1) ~ (t2 :: k2) -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1) sym rep r co_body -- forall over coercion... | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1 , CoercionTy h1 <- t1 , CoercionTy h2 <- t2 = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2 in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body -- See if it is a forall after optimization -- If so, do an inefficient one-variable substitution, then re-optimize -- forall over type... | Just (tv', kind_co', co_body') <- splitForAllCo_ty_maybe co1' = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv' (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg')) False False r' co_body' -- forall over coercion... | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1' , CoercionTy h1' <- t1' , CoercionTy h2' <- t2' = let new_co = mk_new_co cv' kind_co' h1' h2' in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co) False False r' co_body' | otherwise = InstCo co1' arg' where co1' = opt_co4_wrap env sym rep r co1 r' = chooseRole rep r arg' = opt_co4_wrap env sym False Nominal arg sym_arg = wrapSym sym arg' -- Performance note: don't be alarmed by the two calls to coercionKind -- here, as only one call to coercionKind is actually demanded per guard. -- t1/t2 are used when checking if co1 is a forall, and t1'/t2' are used -- when checking if co1' (i.e., co1 post-optimization) is a forall. -- -- t1/t2 must come from sym_arg, not arg', since it's possible that arg' -- might have an extra Sym at the front (after being optimized) that co1 -- lacks, so we need to use sym_arg to balance the number of Syms. (#15725) Pair t1 t2 = coercionKind sym_arg Pair t1' t2' = coercionKind arg' mk_new_co cv kind_co h1 h2 = let -- h1 :: (t1 ~ t2) -- h2 :: (t3 ~ t4) -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4) -- n1 :: t1 ~ t3 -- n2 :: t2 ~ t4 -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2) r2 = coVarRole cv kind_co' = downgradeRole r2 Nominal kind_co n1 = mkNthCo r2 2 kind_co' n2 = mkNthCo r2 3 kind_co' in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1 (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2)) opt_co4 env sym _rep r (KindCo co) = ASSERT( r == Nominal ) let kco' = promoteCoercion co in case kco' of KindCo co' -> promoteCoercion (opt_co1 env sym co') _ -> opt_co4_wrap env sym False Nominal kco' -- This might be able to be optimized more to do the promotion -- and substitution/optimization at the same time opt_co4 env sym _ r (SubCo co) = ASSERT( r == Representational ) opt_co4_wrap env sym True Nominal co -- This could perhaps be optimized more. opt_co4 env sym rep r (AxiomRuleCo co cs) = ASSERT( r == coaxrRole co ) wrapRole rep r $ wrapSym sym $ AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) {- Note [Optimise CoVarCo to Refl] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have (c :: t~t) we can optimise it to Refl. That increases the chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t) We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo] in Coercion. -} ------------- -- | Optimize a phantom coercion. The input coercion may not necessarily -- be a phantom, but the output sure will be. opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo opt_phantom env sym co = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2 where Pair ty1 ty2 = coercionKind co {- Note [Differing kinds] ~~~~~~~~~~~~~~~~~~~~~~ The two types may not have the same kind (although that would be very unusual). But even if they have the same kind, and the same type constructor, the number of arguments in a `CoTyConApp` can differ. Consider Any :: forall k. k Any * Int :: * Any (*->*) Maybe Int :: * Hence the need to compare argument lengths; see #13658 -} opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role -> Type -> Type -> Coercion opt_univ env sym (PhantomProv h) _r ty1 ty2 | sym = mkPhantomCo h' ty2' ty1' | otherwise = mkPhantomCo h' ty1' ty2' where h' = opt_co4 env sym False Nominal h ty1' = substTy (lcSubstLeft env) ty1 ty2' = substTy (lcSubstRight env) ty2 opt_univ env sym prov role oty1 oty2 | Just (tc1, tys1) <- splitTyConApp_maybe oty1 , Just (tc2, tys2) <- splitTyConApp_maybe oty2 , tc1 == tc2 , equalLength tys1 tys2 -- see Note [Differing kinds] -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom); -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps = let roles = tyConRolesX role tc1 arg_cos = zipWith3 (mkUnivCo prov') roles tys1 tys2 arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos in mkTyConAppCo role tc1 arg_cos' -- can't optimize the AppTy case because we can't build the kind coercions. | Just (tv1, ty1) <- splitForAllTy_ty_maybe oty1 , Just (tv2, ty2) <- splitForAllTy_ty_maybe oty2 -- NB: prov isn't interesting here either = let k1 = tyVarKind tv1 k2 = tyVarKind tv2 eta = mkUnivCo prov' Nominal k1 k2 -- eta gets opt'ed soon, but not yet. ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2 (env', tv1', eta') = optForAllCoBndr env sym tv1 eta in mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2') | Just (cv1, ty1) <- splitForAllTy_co_maybe oty1 , Just (cv2, ty2) <- splitForAllTy_co_maybe oty2 -- NB: prov isn't interesting here either = let k1 = varType cv1 k2 = varType cv2 r' = coVarRole cv1 eta = mkUnivCo prov' Nominal k1 k2 eta_d = downgradeRole r' Nominal eta -- eta gets opt'ed soon, but not yet. n_co = (mkSymCo $ mkNthCo r' 2 eta_d) `mkTransCo` (mkCoVarCo cv1) `mkTransCo` (mkNthCo r' 3 eta_d) ty2' = substTyWithCoVars [cv2] [n_co] ty2 (env', cv1', eta') = optForAllCoBndr env sym cv1 eta in mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2') | otherwise = let ty1 = substTyUnchecked (lcSubstLeft env) oty1 ty2 = substTyUnchecked (lcSubstRight env) oty2 (a, b) | sym = (ty2, ty1) | otherwise = (ty1, ty2) in mkUnivCo prov' role a b where prov' = case prov of UnsafeCoerceProv -> prov PhantomProv kco -> PhantomProv $ opt_co4_wrap env sym False Nominal kco ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco PluginProv _ -> prov ------------- opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] opt_transList is = zipWith (opt_trans is) opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo opt_trans is co1 co2 | isReflCo co1 = co2 -- optimize when co1 is a Refl Co | otherwise = opt_trans1 is co1 co2 opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo -- First arg is not the identity opt_trans1 is co1 co2 | isReflCo co2 = co1 -- optimize when co2 is a Refl Co | otherwise = opt_trans2 is co1 co2 opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo -- Neither arg is the identity opt_trans2 is (TransCo co1a co1b) co2 -- Don't know whether the sub-coercions are the identity = opt_trans is co1a (opt_trans is co1b co2) opt_trans2 is co1 co2 | Just co <- opt_trans_rule is co1 co2 = co opt_trans2 is co1 (TransCo co2a co2b) | Just co1_2a <- opt_trans_rule is co1 co2a = if isReflCo co1_2a then co2b else opt_trans1 is co1_2a co2b opt_trans2 _ co1 co2 = mkTransCo co1 co2 ------ -- Optimize coercions with a top-level use of transitivity. opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2)) = ASSERT( r1 == r2 ) fireTransRule "GRefl" in_co1 in_co2 $ mkGReflRightCo r1 t1 (opt_trans is co1 co2) -- Push transitivity through matching destructors opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2) | d1 == d2 , coercionRole co1 == coercionRole co2 , co1 `compatible_co` co2 = ASSERT( r1 == r2 ) fireTransRule "PushNth" in_co1 in_co2 $ mkNthCo r1 d1 (opt_trans is co1 co2) opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) | d1 == d2 , co1 `compatible_co` co2 = fireTransRule "PushLR" in_co1 in_co2 $ mkLRCo d1 (opt_trans is co1 co2) -- Push transitivity inside instantiation opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) | ty1 `eqCoercion` ty2 , co1 `compatible_co` co2 = fireTransRule "TrPushInst" in_co1 in_co2 $ mkInstCo (opt_trans is co1 co2) ty1 opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1) in_co2@(UnivCo p2 r2 _tyl2 tyr2) | Just prov' <- opt_trans_prov p1 p2 = ASSERT( r1 == r2 ) fireTransRule "UnivCo" in_co1 in_co2 $ mkUnivCo prov' r1 tyl1 tyr2 where -- if the provenances are different, opt'ing will be very confusing opt_trans_prov UnsafeCoerceProv UnsafeCoerceProv = Just UnsafeCoerceProv opt_trans_prov (PhantomProv kco1) (PhantomProv kco2) = Just $ PhantomProv $ opt_trans is kco1 kco2 opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2) = Just $ ProofIrrelProv $ opt_trans is kco1 kco2 opt_trans_prov (PluginProv str1) (PluginProv str2) | str1 == str2 = Just p1 opt_trans_prov _ _ = Nothing -- Push transitivity down through matching top-level constructors. opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) | tc1 == tc2 = ASSERT( r1 == r2 ) fireTransRule "PushTyConApp" in_co1 in_co2 $ mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) opt_trans_rule is in_co1@(FunCo r1 co1a co1b) in_co2@(FunCo r2 co2a co2b) = ASSERT( r1 == r2 ) -- Just like the TyConAppCo/TyConAppCo case fireTransRule "PushFun" in_co1 in_co2 $ mkFunCo r1 (opt_trans is co1a co2a) (opt_trans is co1b co2b) opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) -- Must call opt_trans_rule_app; see Note [EtaAppCo] = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b] -- Eta rules opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 | Just cos2 <- etaTyConAppCo_maybe tc co2 = ASSERT( cos1 `equalLength` cos2 ) fireTransRule "EtaCompL" co1 co2 $ mkTyConAppCo r tc (opt_transList is cos1 cos2) opt_trans_rule is co1 co2@(TyConAppCo r tc cos2) | Just cos1 <- etaTyConAppCo_maybe tc co1 = ASSERT( cos1 `equalLength` cos2 ) fireTransRule "EtaCompR" co1 co2 $ mkTyConAppCo r tc (opt_transList is cos1 cos2) opt_trans_rule is co1@(AppCo co1a co1b) co2 | Just (co2a,co2b) <- etaAppCo_maybe co2 = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] opt_trans_rule is co1 co2@(AppCo co2a co2b) | Just (co1a,co1b) <- etaAppCo_maybe co1 = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] -- Push transitivity inside forall -- forall over types. opt_trans_rule is co1 co2 | Just (tv1, eta1, r1) <- splitForAllCo_ty_maybe co1 , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2 = push_trans tv1 eta1 r1 tv2 eta2 r2 | Just (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2 , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1 = push_trans tv1 eta1 r1 tv2 eta2 r2 where push_trans tv1 eta1 r1 tv2 eta2 r2 -- Given: -- co1 = /\ tv1 : eta1. r1 -- co2 = /\ tv2 : eta2. r2 -- Wanted: -- /\tv1 : (eta1;eta2). (r1; r2[tv2 |-> tv1 |> eta1]) = fireTransRule "EtaAllTy_ty" co1 co2 $ mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') where is' = is `extendInScopeSet` tv1 r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2 -- Push transitivity inside forall -- forall over coercions. opt_trans_rule is co1 co2 | Just (cv1, eta1, r1) <- splitForAllCo_co_maybe co1 , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2 = push_trans cv1 eta1 r1 cv2 eta2 r2 | Just (cv2, eta2, r2) <- splitForAllCo_co_maybe co2 , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1 = push_trans cv1 eta1 r1 cv2 eta2 r2 where push_trans cv1 eta1 r1 cv2 eta2 r2 -- Given: -- co1 = /\ cv1 : eta1. r1 -- co2 = /\ cv2 : eta2. r2 -- Wanted: -- n1 = nth 2 eta1 -- n2 = nth 3 eta1 -- nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2]) = fireTransRule "EtaAllTy_co" co1 co2 $ mkForAllCo cv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') where is' = is `extendInScopeSet` cv1 role = coVarRole cv1 eta1' = downgradeRole role Nominal eta1 n1 = mkNthCo role 2 eta1' n2 = mkNthCo role 3 eta1' r2' = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo` (mkCoVarCo cv1) `mkTransCo` n2]) r2 -- Push transitivity inside axioms opt_trans_rule is co1 co2 -- See Note [Why call checkAxInstCo during optimisation] -- TrPushSymAxR | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe , True <- sym , Just cos2 <- matchAxiom sym con ind co2 , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1) , Nothing <- checkAxInstCo newAxInst = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst -- TrPushAxR | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe , False <- sym , Just cos2 <- matchAxiom sym con ind co2 , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) , Nothing <- checkAxInstCo newAxInst = fireTransRule "TrPushAxR" co1 co2 newAxInst -- TrPushSymAxL | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe , True <- sym , Just cos1 <- matchAxiom (not sym) con ind co1 , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1)) , Nothing <- checkAxInstCo newAxInst = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst -- TrPushAxL | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe , False <- sym , Just cos1 <- matchAxiom (not sym) con ind co1 , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) , Nothing <- checkAxInstCo newAxInst = fireTransRule "TrPushAxL" co1 co2 newAxInst -- TrPushAxSym/TrPushSymAx | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe , con1 == con2 , ind1 == ind2 , sym1 == not sym2 , let branch = coAxiomNthBranch con1 ind1 qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch lhs = coAxNthLHS con1 ind1 rhs = coAxBranchRHS branch pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs) , all (`elemVarSet` pivot_tvs) qtvs = fireTransRule "TrPushAxSym" co1 co2 $ if sym2 -- TrPushAxSym then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs -- TrPushSymAx else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs where co1_is_axiom_maybe = isAxiom_maybe co1 co2_is_axiom_maybe = isAxiom_maybe co2 role = coercionRole co1 -- should be the same as coercionRole co2! opt_trans_rule _ co1 co2 -- Identity rule | (Pair ty1 _, r) <- coercionKindRole co1 , Pair _ ty2 <- coercionKind co2 , ty1 `eqType` ty2 = fireTransRule "RedTypeDirRefl" co1 co2 $ mkReflCo r ty2 opt_trans_rule _ _ _ = Nothing -- See Note [EtaAppCo] opt_trans_rule_app :: InScopeSet -> Coercion -- original left-hand coercion (printing only) -> Coercion -- original right-hand coercion (printing only) -> Coercion -- left-hand coercion "function" -> [Coercion] -- left-hand coercion "args" -> Coercion -- right-hand coercion "function" -> [Coercion] -- right-hand coercion "args" -> Maybe Coercion opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs | AppCo co1aa co1ab <- co1a , Just (co2aa, co2ab) <- etaAppCo_maybe co2a = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) | AppCo co2aa co2ab <- co2a , Just (co1aa, co1ab) <- etaAppCo_maybe co1a = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) | otherwise = ASSERT( co1bs `equalLength` co2bs ) fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $ let Pair _ rt1a = coercionKind co1a (Pair lt2a _, rt2a) = coercionKindRole co2a Pair _ rt1bs = traverse coercionKind co1bs Pair lt2bs _ = traverse coercionKind co2bs rt2bs = map coercionRole co2bs kcoa = mkKindCo $ buildCoercion lt2a rt1a kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs co2a' = mkCoherenceLeftCo rt2a lt2a kcoa co2a co2bs' = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs co2bs'' = zipWith mkTransCo co2bs' co2bs in mkAppCos (opt_trans is co1a co2a') (zipWith (opt_trans is) co1bs co2bs'') fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion fireTransRule _rule _co1 _co2 res = Just res {- Note [Conflict checking with AxiomInstCo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following type family and axiom: type family Equal (a :: k) (b :: k) :: Bool type instance where Equal a a = True Equal a b = False -- Equal :: forall k::*. k -> k -> Bool axEqual :: { forall k::*. forall a::k. Equal k a a ~ True ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False } We wish to disallow (axEqual[1] <*> ) :: (Equal * Int Int ~ False) and that all is OK. But, all is not OK: we want to use the first branch of the axiom in this case, not the second. The problem is that the parameters of the first branch can unify with the supplied coercions, thus meaning that the first branch should be taken. See also Note [Apartness] in types/FamInstEnv.hs. Note [Why call checkAxInstCo during optimisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is possible that otherwise-good-looking optimisations meet with disaster in the presence of axioms with multiple equations. Consider type family Equal (a :: *) (b :: *) :: Bool where Equal a a = True Equal a b = False type family Id (a :: *) :: * where Id a = a axEq :: { [a::*]. Equal a a ~ True ; [a::*, b::*]. Equal a b ~ False } axId :: [a::*]. Id a ~ a co1 = Equal (axId[0] Int) (axId[0] Bool) :: Equal (Id Int) (Id Bool) ~ Equal Int Bool co2 = axEq[1] :: Equal Int Bool ~ False We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what happens when we push the coercions inside? We get co3 = axEq[1] (axId[0] Int) (axId[0] Bool) :: Equal (Id Int) (Id Bool) ~ False which is bogus! This is because the type system isn't smart enough to know that (Id Int) and (Id Bool) are Surely Apart, as they're headed by type families. At the time of writing, I (Richard Eisenberg) couldn't think of a way of detecting this any more efficient than just building the optimised coercion and checking. Note [EtaAppCo] ~~~~~~~~~~~~~~~ Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that the resultant coercions might not be well kinded. Here is an example (things labeled with x don't matter in this example): k1 :: Type k2 :: Type a :: k1 -> Type b :: k1 h :: k1 ~ k2 co1a :: x1 ~ (a |> (h -> ) co1b :: x2 ~ (b |> h) co2a :: a ~ x3 co2b :: b ~ x4 First, convince yourself of the following: co1a co1b :: x1 x2 ~ (a |> (h -> )) (b |> h) co2a co2b :: a b ~ x3 x4 (a |> (h -> )) (b |> h) `eqType` a b That last fact is due to Note [Non-trivial definitional equality] in TyCoRep, where we ignore coercions in types as long as two types' kinds are the same. In our case, we meet this last condition, because (a |> (h -> )) (b |> h) :: Type and a b :: Type So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the kinds don't match up. The solution here is to twiddle the kinds in the output coercions. First, we need to find coercions ak :: kind(a |> (h -> )) ~ kind(a) bk :: kind(b |> h) ~ kind(b) This can be done with mkKindCo and buildCoercion. The latter assumes two types are identical modulo casts and builds a coercion between them. Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the output coercions. These are well-kinded. Also, note that all of this is done after accumulated any nested AppCo parameters. This step is to avoid quadratic behavior in calling coercionKind. The problem described here was first found in dependent/should_compile/dynamic-paper. -} -- | Check to make sure that an AxInstCo is internally consistent. -- Returns the conflicting branch, if it exists -- See Note [Conflict checking with AxiomInstCo] checkAxInstCo :: Coercion -> Maybe CoAxBranch -- defined here to avoid dependencies in Coercion -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] in CoreLint checkAxInstCo (AxiomInstCo ax ind cos) = let branch = coAxiomNthBranch ax ind tvs = coAxBranchTyVars branch cvs = coAxBranchCoVars branch incomps = coAxBranchIncomps branch (tys, cotys) = splitAtList tvs (map (pFst . coercionKind) cos) co_args = map stripCoercionTy cotys subst = zipTvSubst tvs tys `composeTCvSubst` zipCvSubst cvs co_args target = Type.substTys subst (coAxBranchLHS branch) in_scope = mkInScopeSet $ unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps) flattened_target = flattenTys in_scope target in check_no_conflict flattened_target incomps where check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch check_no_conflict _ [] = Nothing check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest) -- See Note [Apartness] in FamInstEnv | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp = check_no_conflict flat rest | otherwise = Just b checkAxInstCo _ = Nothing ----------- wrapSym :: SymFlag -> Coercion -> Coercion wrapSym sym co | sym = mkSymCo co | otherwise = co -- | Conditionally set a role to be representational wrapRole :: ReprFlag -> Role -- ^ current role -> Coercion -> Coercion wrapRole False _ = id wrapRole True current = downgradeRole Representational current -- | If we require a representational role, return that. Otherwise, -- return the "default" role provided. chooseRole :: ReprFlag -> Role -- ^ "default" role -> Role chooseRole True _ = Representational chooseRole _ r = r ----------- isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion]) isAxiom_maybe (SymCo co) | Just (sym, con, ind, cos) <- isAxiom_maybe co = Just (not sym, con, ind, cos) isAxiom_maybe (AxiomInstCo con ind cos) = Just (False, con, ind, cos) isAxiom_maybe _ = Nothing matchAxiom :: Bool -- True = match LHS, False = match RHS -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion] matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co | CoAxBranch { cab_tvs = qtvs , cab_cvs = [] -- can't infer these, so fail if there are any , cab_roles = roles , cab_lhs = lhs , cab_rhs = rhs } <- coAxiomNthBranch ax ind , Just subst <- liftCoMatch (mkVarSet qtvs) (if sym then (mkTyConApp tc lhs) else rhs) co , all (`isMappedByLC` subst) qtvs = zipWithM (liftCoSubstTyVar subst) roles qtvs | otherwise = Nothing ------------- compatible_co :: Coercion -> Coercion -> Bool -- Check whether (co1 . co2) will be well-kinded compatible_co co1 co2 = x1 `eqType` x2 where Pair _ x1 = coercionKind co1 Pair x2 _ = coercionKind co2 ------------- {- etaForAllCo ~~~~~~~~~~~~~~~~~ (1) etaForAllCo_ty_maybe Suppose we have g : all a1:k1.t1 ~ all a2:k2.t2 but g is *not* a ForAllCo. We want to eta-expand it. So, we do this: g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g)) Call the kind coercion h1 and the body coercion h2. We can see that h2 : t1 ~ t2[a2 |-> (a1 |> h1)] According to the typing rule for ForAllCo, we get that g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1]) or g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> a1]) as desired. (2) etaForAllCo_co_maybe Suppose we have g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2 Similarly, we do this g' = all c1:h1. h2 : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)] [c1 |-> eta1;c1;sym eta2] Here, h1 = mkNthCo Nominal 0 g :: (s1~s2)~(s3~s4) eta1 = mkNthCo r 2 h1 :: (s1 ~ s3) eta2 = mkNthCo r 3 h1 :: (s2 ~ s4) h2 = mkInstCo g (cv1 ~ (sym eta1;c1;eta2)) -} etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) -- Try to make the coercion be of form (forall tv:kind_co. co) etaForAllCo_ty_maybe co | Just (tv, kind_co, r) <- splitForAllCo_ty_maybe co = Just (tv, kind_co, r) | Pair ty1 ty2 <- coercionKind co , Just (tv1, _) <- splitForAllTy_ty_maybe ty1 , isForAllTy_ty ty2 , let kind_co = mkNthCo Nominal 0 co = Just ( tv1, kind_co , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co)) | otherwise = Nothing etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) -- Try to make the coercion be of form (forall cv:kind_co. co) etaForAllCo_co_maybe co | Just (cv, kind_co, r) <- splitForAllCo_co_maybe co = Just (cv, kind_co, r) | Pair ty1 ty2 <- coercionKind co , Just (cv1, _) <- splitForAllTy_co_maybe ty1 , isForAllTy_co ty2 = let kind_co = mkNthCo Nominal 0 co r = coVarRole cv1 l_co = mkCoVarCo cv1 kind_co' = downgradeRole r Nominal kind_co r_co = (mkSymCo (mkNthCo r 2 kind_co')) `mkTransCo` l_co `mkTransCo` (mkNthCo r 3 kind_co') in Just ( cv1, kind_co , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co)) | otherwise = Nothing etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) -- If possible, split a coercion -- g :: t1a t1b ~ t2a t2b -- into a pair of coercions (left g, right g) etaAppCo_maybe co | Just (co1,co2) <- splitAppCo_maybe co = Just (co1,co2) | (Pair ty1 ty2, Nominal) <- coercionKindRole co , Just (_,t1) <- splitAppTy_maybe ty1 , Just (_,t2) <- splitAppTy_maybe ty2 , let isco1 = isCoercionTy t1 , let isco2 = isCoercionTy t2 , isco1 == isco2 = Just (LRCo CLeft co, LRCo CRight co) | otherwise = Nothing etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] -- If possible, split a coercion -- g :: T s1 .. sn ~ T t1 .. tn -- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ] etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2) = ASSERT( tc == tc2 ) Just cos2 etaTyConAppCo_maybe tc co | not (mustBeSaturated tc) , (Pair ty1 ty2, r) <- coercionKindRole co , Just (tc1, tys1) <- splitTyConApp_maybe ty1 , Just (tc2, tys2) <- splitTyConApp_maybe ty2 , tc1 == tc2 , isInjectiveTyCon tc r -- See Note [NthCo and newtypes] in TyCoRep , let n = length tys1 , tys2 `lengthIs` n -- This can fail in an erroneous progam -- E.g. T a ~# T a b -- #14607 = ASSERT( tc == tc1 ) Just (decomposeCo n co (tyConRolesX r tc1)) -- NB: n might be <> tyConArity tc -- e.g. data family T a :: * -> * -- g :: T a b ~ T c d | otherwise = Nothing {- Note [Eta for AppCo] ~~~~~~~~~~~~~~~~~~~~ Suppose we have g :: s1 t1 ~ s2 t2 Then we can't necessarily make left g :: s1 ~ s2 right g :: t1 ~ t2 because it's possible that s1 :: * -> * t1 :: * s2 :: (*->*) -> * t2 :: * -> * and in that case (left g) does not have the same kind on either side. It's enough to check that kind t1 = kind t2 because if g is well-kinded then kind (s1 t2) = kind (s2 t2) and these two imply kind s1 = kind s2 -} optForAllCoBndr :: LiftingContext -> Bool -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion) optForAllCoBndr env sym = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env ghc-lib-parser-8.10.2.20200808/compiler/utils/OrdList.hs0000644000000000000000000001316213713635745020400 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1993-1998 This is useful, general stuff for the Native Code Generator. Provide trees (of instructions), so that lists of instructions can be appended in linear time. -} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE BangPatterns #-} module OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL, headOL, mapOL, fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse, strictlyEqOL, strictlyOrdOL ) where import GhcPrelude import Data.Foldable import Outputable import qualified Data.Semigroup as Semigroup infixl 5 `appOL` infixl 5 `snocOL` infixr 5 `consOL` data OrdList a = None | One a | Many [a] -- Invariant: non-empty | Cons a (OrdList a) | Snoc (OrdList a) a | Two (OrdList a) -- Invariant: non-empty (OrdList a) -- Invariant: non-empty deriving (Functor) instance Outputable a => Outputable (OrdList a) where ppr ol = ppr (fromOL ol) -- Convert to list and print that instance Semigroup (OrdList a) where (<>) = appOL instance Monoid (OrdList a) where mempty = nilOL mappend = (Semigroup.<>) mconcat = concatOL instance Foldable OrdList where foldr = foldrOL foldl' = foldlOL toList = fromOL null = isNilOL length = lengthOL instance Traversable OrdList where traverse f xs = toOL <$> traverse f (fromOL xs) nilOL :: OrdList a isNilOL :: OrdList a -> Bool unitOL :: a -> OrdList a snocOL :: OrdList a -> a -> OrdList a consOL :: a -> OrdList a -> OrdList a appOL :: OrdList a -> OrdList a -> OrdList a concatOL :: [OrdList a] -> OrdList a headOL :: OrdList a -> a lastOL :: OrdList a -> a lengthOL :: OrdList a -> Int nilOL = None unitOL as = One as snocOL as b = Snoc as b consOL a bs = Cons a bs concatOL aas = foldr appOL None aas headOL None = panic "headOL" headOL (One a) = a headOL (Many as) = head as headOL (Cons a _) = a headOL (Snoc as _) = headOL as headOL (Two as _) = headOL as lastOL None = panic "lastOL" lastOL (One a) = a lastOL (Many as) = last as lastOL (Cons _ as) = lastOL as lastOL (Snoc _ a) = a lastOL (Two _ as) = lastOL as lengthOL None = 0 lengthOL (One _) = 1 lengthOL (Many as) = length as lengthOL (Cons _ as) = 1 + length as lengthOL (Snoc as _) = 1 + length as lengthOL (Two as bs) = length as + length bs isNilOL None = True isNilOL _ = False None `appOL` b = b a `appOL` None = a One a `appOL` b = Cons a b a `appOL` One b = Snoc a b a `appOL` b = Two a b fromOL :: OrdList a -> [a] fromOL a = go a [] where go None acc = acc go (One a) acc = a : acc go (Cons a b) acc = a : go b acc go (Snoc a b) acc = go a (b:acc) go (Two a b) acc = go a (go b acc) go (Many xs) acc = xs ++ acc fromOLReverse :: OrdList a -> [a] fromOLReverse a = go a [] -- acc is already in reverse order where go :: OrdList a -> [a] -> [a] go None acc = acc go (One a) acc = a : acc go (Cons a b) acc = go b (a : acc) go (Snoc a b) acc = b : go a acc go (Two a b) acc = go b (go a acc) go (Many xs) acc = reverse xs ++ acc mapOL :: (a -> b) -> OrdList a -> OrdList b mapOL = fmap foldrOL :: (a->b->b) -> b -> OrdList a -> b foldrOL _ z None = z foldrOL k z (One x) = k x z foldrOL k z (Cons x xs) = k x (foldrOL k z xs) foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1 foldrOL k z (Many xs) = foldr k z xs -- | Strict left fold. foldlOL :: (b->a->b) -> b -> OrdList a -> b foldlOL _ z None = z foldlOL k z (One x) = k z x foldlOL k z (Cons x xs) = let !z' = (k z x) in foldlOL k z' xs foldlOL k z (Snoc xs x) = let !z' = (foldlOL k z xs) in k z' x foldlOL k z (Two b1 b2) = let !z' = (foldlOL k z b1) in foldlOL k z' b2 foldlOL k z (Many xs) = foldl' k z xs toOL :: [a] -> OrdList a toOL [] = None toOL [x] = One x toOL xs = Many xs reverseOL :: OrdList a -> OrdList a reverseOL None = None reverseOL (One x) = One x reverseOL (Cons a b) = Snoc (reverseOL b) a reverseOL (Snoc a b) = Cons b (reverseOL a) reverseOL (Two a b) = Two (reverseOL b) (reverseOL a) reverseOL (Many xs) = Many (reverse xs) -- | Compare not only the values but also the structure of two lists strictlyEqOL :: Eq a => OrdList a -> OrdList a -> Bool strictlyEqOL None None = True strictlyEqOL (One x) (One y) = x == y strictlyEqOL (Cons a as) (Cons b bs) = a == b && as `strictlyEqOL` bs strictlyEqOL (Snoc as a) (Snoc bs b) = a == b && as `strictlyEqOL` bs strictlyEqOL (Two a1 a2) (Two b1 b2) = a1 `strictlyEqOL` b1 && a2 `strictlyEqOL` b2 strictlyEqOL (Many as) (Many bs) = as == bs strictlyEqOL _ _ = False -- | Compare not only the values but also the structure of two lists strictlyOrdOL :: Ord a => OrdList a -> OrdList a -> Ordering strictlyOrdOL None None = EQ strictlyOrdOL None _ = LT strictlyOrdOL (One x) (One y) = compare x y strictlyOrdOL (One _) _ = LT strictlyOrdOL (Cons a as) (Cons b bs) = compare a b `mappend` strictlyOrdOL as bs strictlyOrdOL (Cons _ _) _ = LT strictlyOrdOL (Snoc as a) (Snoc bs b) = compare a b `mappend` strictlyOrdOL as bs strictlyOrdOL (Snoc _ _) _ = LT strictlyOrdOL (Two a1 a2) (Two b1 b2) = (strictlyOrdOL a1 b1) `mappend` (strictlyOrdOL a2 b2) strictlyOrdOL (Two _ _) _ = LT strictlyOrdOL (Many as) (Many bs) = compare as bs strictlyOrdOL (Many _ ) _ = GT ghc-lib-parser-8.10.2.20200808/compiler/utils/Outputable.hs0000644000000000000000000013200513713635745021142 0ustar0000000000000000{- (c) The University of Glasgow 2006-2012 (c) The GRASP Project, Glasgow University, 1992-1998 -} -- | This module defines classes and functions for pretty-printing. It also -- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'. -- -- The interface to this module is very similar to the standard Hughes-PJ pretty printing -- module, except that it exports a number of additional functions that are rarely used, -- and works over the 'SDoc' type. module Outputable ( -- * Type classes Outputable(..), OutputableBndr(..), -- * Pretty printing combinators SDoc, runSDoc, initSDocContext, docToSDoc, interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, pprWithBars, empty, isEmpty, nest, char, text, ftext, ptext, ztext, int, intWithCommas, integer, word, float, double, rational, doublePrec, parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, semi, comma, colon, dcolon, space, equals, dot, vbar, arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, blankLine, forAllLit, kindType, bullet, (<>), (<+>), hcat, hsep, ($$), ($+$), vcat, sep, cat, fsep, fcat, hang, hangNotEmpty, punctuate, ppWhen, ppUnless, speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes, unicodeSyntax, coloured, keyword, -- * Converting 'SDoc' into strings and outputing it printSDoc, printSDocLn, printForUser, printForUserPartWay, printForC, bufLeftRenderSDoc, pprCode, mkCodeStyle, showSDoc, showSDocUnsafe, showSDocOneLine, showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, showSDocUnqual, showPpr, renderWithStyle, pprInfixVar, pprPrefixVar, pprHsChar, pprHsString, pprHsBytes, primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix, primInt64Suffix, primWord64Suffix, primIntSuffix, pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64, pprFastFilePath, pprFilePathString, -- * Controlling the style in which output is printed BindingSite(..), PprStyle, CodeStyle(..), PrintUnqualified(..), QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, reallyAlwaysQualify, reallyAlwaysQualifyNames, alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, neverQualify, neverQualifyNames, neverQualifyModules, alwaysQualifyPackages, neverQualifyPackages, QualifyName(..), queryQual, sdocWithDynFlags, sdocWithPlatform, updSDocDynFlags, getPprStyle, withPprStyle, withPprStyleDoc, setStyleColoured, pprDeeper, pprDeeperList, pprSetDepth, codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, qualName, qualModule, qualPackage, mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, mkUserStyle, cmdlineParserStyle, Depth(..), ifPprDebug, whenPprDebug, getPprDebug, -- * Error handling and debugging utilities pprPanic, pprSorry, assertPprPanic, pprPgmError, pprTrace, pprTraceDebug, pprTraceWith, pprTraceIt, warnPprTrace, pprSTrace, pprTraceException, pprTraceM, trace, pgmError, panic, sorry, assertPanic, pprDebugAndThen, callStackDoc, ) where import GhcPrelude import {-# SOURCE #-} DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput, targetPlatform, pprUserLength, pprCols, useUnicode, useUnicodeSyntax, useStarIsType, shouldUseColor, unsafeGlobalDynFlags, shouldUseHexWordLiterals ) import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName ) import {-# SOURCE #-} OccName( OccName ) import BufWrite (BufHandle) import FastString import qualified Pretty import Util import GHC.Platform import qualified PprColour as Col import Pretty ( Doc, Mode(..) ) import Panic import GHC.Serialized import GHC.LanguageExtensions (Extension) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Char import qualified Data.Map as M import Data.Int import qualified Data.IntMap as IM import Data.Set (Set) import qualified Data.Set as Set import Data.String import Data.Word import System.IO ( Handle ) import System.FilePath import Text.Printf import Numeric (showFFloat) import Data.Graph (SCC(..)) import Data.List (intersperse) import GHC.Fingerprint import GHC.Show ( showMultiLineString ) import GHC.Stack ( callStack, prettyCallStack ) import Control.Monad.IO.Class import Exception {- ************************************************************************ * * \subsection{The @PprStyle@ data type} * * ************************************************************************ -} data PprStyle = PprUser PrintUnqualified Depth Coloured -- Pretty-print in a way that will make sense to the -- ordinary user; must be very close to Haskell -- syntax, etc. -- Assumes printing tidied code: non-system names are -- printed without uniques. | PprDump PrintUnqualified -- For -ddump-foo; less verbose than PprDebug, but more than PprUser -- Does not assume tidied code: non-external names -- are printed with uniques. | PprDebug -- Full debugging output | PprCode CodeStyle -- Print code; either C or assembler data CodeStyle = CStyle -- The format of labels differs for C and assembler | AsmStyle data Depth = AllTheWay | PartWay Int -- 0 => stop data Coloured = Uncoloured | Coloured -- ----------------------------------------------------------------------------- -- Printing original names -- | When printing code that contains original names, we need to map the -- original names back to something the user understands. This is the -- purpose of the triple of functions that gets passed around -- when rendering 'SDoc'. data PrintUnqualified = QueryQualify { queryQualifyName :: QueryQualifyName, queryQualifyModule :: QueryQualifyModule, queryQualifyPackage :: QueryQualifyPackage } -- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify -- it. type QueryQualifyName = Module -> OccName -> QualifyName -- | For a given module, we need to know whether to print it with -- a package name to disambiguate it. type QueryQualifyModule = Module -> Bool -- | For a given package, we need to know whether to print it with -- the component id to disambiguate it. type QueryQualifyPackage = UnitId -> Bool -- See Note [Printing original names] in HscTypes data QualifyName -- Given P:M.T = NameUnqual -- It's in scope unqualified as "T" -- OR nothing called "T" is in scope | NameQual ModuleName -- It's in scope qualified as "X.T" | NameNotInScope1 -- It's not in scope at all, but M.T is not bound -- in the current scope, so we can refer to it as "M.T" | NameNotInScope2 -- It's not in scope at all, and M.T is already bound in -- the current scope, so we must refer to it as "P:M.T" instance Outputable QualifyName where ppr NameUnqual = text "NameUnqual" ppr (NameQual _mod) = text "NameQual" -- can't print the mod without module loops :( ppr NameNotInScope1 = text "NameNotInScope1" ppr NameNotInScope2 = text "NameNotInScope2" reallyAlwaysQualifyNames :: QueryQualifyName reallyAlwaysQualifyNames _ _ = NameNotInScope2 -- | NB: This won't ever show package IDs alwaysQualifyNames :: QueryQualifyName alwaysQualifyNames m _ = NameQual (moduleName m) neverQualifyNames :: QueryQualifyName neverQualifyNames _ _ = NameUnqual alwaysQualifyModules :: QueryQualifyModule alwaysQualifyModules _ = True neverQualifyModules :: QueryQualifyModule neverQualifyModules _ = False alwaysQualifyPackages :: QueryQualifyPackage alwaysQualifyPackages _ = True neverQualifyPackages :: QueryQualifyPackage neverQualifyPackages _ = False reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified reallyAlwaysQualify = QueryQualify reallyAlwaysQualifyNames alwaysQualifyModules alwaysQualifyPackages alwaysQualify = QueryQualify alwaysQualifyNames alwaysQualifyModules alwaysQualifyPackages neverQualify = QueryQualify neverQualifyNames neverQualifyModules neverQualifyPackages defaultUserStyle :: DynFlags -> PprStyle defaultUserStyle dflags = mkUserStyle dflags neverQualify AllTheWay defaultDumpStyle :: DynFlags -> PprStyle -- Print without qualifiers to reduce verbosity, unless -dppr-debug defaultDumpStyle dflags | hasPprDebug dflags = PprDebug | otherwise = PprDump neverQualify mkDumpStyle :: DynFlags -> PrintUnqualified -> PprStyle mkDumpStyle dflags print_unqual | hasPprDebug dflags = PprDebug | otherwise = PprDump print_unqual defaultErrStyle :: DynFlags -> PprStyle -- Default style for error messages, when we don't know PrintUnqualified -- It's a bit of a hack because it doesn't take into account what's in scope -- Only used for desugarer warnings, and typechecker errors in interface sigs -- NB that -dppr-debug will still get into PprDebug style defaultErrStyle dflags = mkErrStyle dflags neverQualify -- | Style for printing error messages mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle mkErrStyle dflags qual = mkUserStyle dflags qual (PartWay (pprUserLength dflags)) cmdlineParserStyle :: DynFlags -> PprStyle cmdlineParserStyle dflags = mkUserStyle dflags alwaysQualify AllTheWay mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle mkUserStyle dflags unqual depth | hasPprDebug dflags = PprDebug | otherwise = PprUser unqual depth Uncoloured setStyleColoured :: Bool -> PprStyle -> PprStyle setStyleColoured col style = case style of PprUser q d _ -> PprUser q d c _ -> style where c | col = Coloured | otherwise = Uncoloured instance Outputable PprStyle where ppr (PprUser {}) = text "user-style" ppr (PprCode {}) = text "code-style" ppr (PprDump {}) = text "dump-style" ppr (PprDebug {}) = text "debug-style" {- Orthogonal to the above printing styles are (possibly) some command-line flags that affect printing (often carried with the style). The most likely ones are variations on how much type info is shown. The following test decides whether or not we are actually generating code (either C or assembly), or generating interface files. ************************************************************************ * * \subsection{The @SDoc@ data type} * * ************************************************************************ -} -- | Represents a pretty-printable document. -- -- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc', -- or 'renderWithStyle'. Avoid calling 'runSDoc' directly as it breaks the -- abstraction layer. newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc } data SDocContext = SDC { sdocStyle :: !PprStyle , sdocLastColour :: !Col.PprColour -- ^ The most recently used colour. This allows nesting colours. , sdocDynFlags :: !DynFlags } instance IsString SDoc where fromString = text -- The lazy programmer's friend. instance Outputable SDoc where ppr = id initSDocContext :: DynFlags -> PprStyle -> SDocContext initSDocContext dflags sty = SDC { sdocStyle = sty , sdocLastColour = Col.colReset , sdocDynFlags = dflags } withPprStyle :: PprStyle -> SDoc -> SDoc withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} -- | This is not a recommended way to render 'SDoc', since it breaks the -- abstraction layer of 'SDoc'. Prefer to use 'printSDoc', 'printSDocLn', -- 'bufLeftRenderSDoc', or 'renderWithStyle' instead. withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty) pprDeeper :: SDoc -> SDoc pprDeeper d = SDoc $ \ctx -> case ctx of SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..." SDC{sdocStyle=PprUser q (PartWay n) c} -> runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c} _ -> runSDoc d ctx -- | Truncate a list that is longer than the current depth. pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc pprDeeperList f ds | null ds = f [] | otherwise = SDoc work where work ctx@SDC{sdocStyle=PprUser q (PartWay n) c} | n==0 = Pretty.text "..." | otherwise = runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c} where go _ [] = [] go i (d:ds) | i >= n = [text "...."] | otherwise = d : go (i+1) ds work other_ctx = runSDoc (f ds) other_ctx pprSetDepth :: Depth -> SDoc -> SDoc pprSetDepth depth doc = SDoc $ \ctx -> case ctx of SDC{sdocStyle=PprUser q _ c} -> runSDoc doc ctx{sdocStyle = PprUser q depth c} _ -> runSDoc doc ctx getPprStyle :: (PprStyle -> SDoc) -> SDoc getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx sdocWithPlatform :: (Platform -> SDoc) -> SDoc sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) updSDocDynFlags :: (DynFlags -> DynFlags) -> SDoc -> SDoc updSDocDynFlags upd doc = SDoc $ \ctx -> runSDoc doc (ctx { sdocDynFlags = upd (sdocDynFlags ctx) }) qualName :: PprStyle -> QueryQualifyName qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ qualName (PprDump q) mod occ = queryQualifyName q mod occ qualName _other mod _ = NameQual (moduleName mod) qualModule :: PprStyle -> QueryQualifyModule qualModule (PprUser q _ _) m = queryQualifyModule q m qualModule (PprDump q) m = queryQualifyModule q m qualModule _other _m = True qualPackage :: PprStyle -> QueryQualifyPackage qualPackage (PprUser q _ _) m = queryQualifyPackage q m qualPackage (PprDump q) m = queryQualifyPackage q m qualPackage _other _m = True queryQual :: PprStyle -> PrintUnqualified queryQual s = QueryQualify (qualName s) (qualModule s) (qualPackage s) codeStyle :: PprStyle -> Bool codeStyle (PprCode _) = True codeStyle _ = False asmStyle :: PprStyle -> Bool asmStyle (PprCode AsmStyle) = True asmStyle _other = False dumpStyle :: PprStyle -> Bool dumpStyle (PprDump {}) = True dumpStyle _other = False debugStyle :: PprStyle -> Bool debugStyle PprDebug = True debugStyle _other = False userStyle :: PprStyle -> Bool userStyle (PprUser {}) = True userStyle _other = False getPprDebug :: (Bool -> SDoc) -> SDoc getPprDebug d = getPprStyle $ \ sty -> d (debugStyle sty) ifPprDebug :: SDoc -> SDoc -> SDoc -- ^ Says what to do with and without -dppr-debug ifPprDebug yes no = getPprDebug $ \ dbg -> if dbg then yes else no whenPprDebug :: SDoc -> SDoc -- Empty for non-debug style -- ^ Says what to do with -dppr-debug; without, return empty whenPprDebug d = ifPprDebug d empty -- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the -- terminal doesn't get screwed up by the ANSI color codes if an exception -- is thrown during pretty-printing. printSDoc :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO () printSDoc mode dflags handle sty doc = Pretty.printDoc_ mode cols handle (runSDoc doc ctx) `finally` Pretty.printDoc_ mode cols handle (runSDoc (coloured Col.colReset empty) ctx) where cols = pprCols dflags ctx = initSDocContext dflags sty -- | Like 'printSDoc' but appends an extra newline. printSDocLn :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO () printSDocLn mode dflags handle sty doc = printSDoc mode dflags handle sty (doc $$ text "") printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO () printForUser dflags handle unqual doc = printSDocLn PageMode dflags handle (mkUserStyle dflags unqual AllTheWay) doc printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc -> IO () printForUserPartWay dflags handle d unqual doc = printSDocLn PageMode dflags handle (mkUserStyle dflags unqual (PartWay d)) doc -- | Like 'printSDocLn' but specialized with 'LeftMode' and -- @'PprCode' 'CStyle'@. This is typically used to output C-- code. printForC :: DynFlags -> Handle -> SDoc -> IO () printForC dflags handle doc = printSDocLn LeftMode dflags handle (PprCode CStyle) doc -- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that -- outputs to a 'BufHandle'. bufLeftRenderSDoc :: DynFlags -> BufHandle -> PprStyle -> SDoc -> IO () bufLeftRenderSDoc dflags bufHandle sty doc = Pretty.bufLeftRender bufHandle (runSDoc doc (initSDocContext dflags sty)) pprCode :: CodeStyle -> SDoc -> SDoc pprCode cs d = withPprStyle (PprCode cs) d mkCodeStyle :: CodeStyle -> PprStyle mkCodeStyle = PprCode -- Can't make SDoc an instance of Show because SDoc is just a function type -- However, Doc *is* an instance of Show -- showSDoc just blasts it out as a string showSDoc :: DynFlags -> SDoc -> String showSDoc dflags sdoc = renderWithStyle dflags sdoc (defaultUserStyle dflags) -- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be -- initialised yet. showSDocUnsafe :: SDoc -> String showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc showPpr :: Outputable a => DynFlags -> a -> String showPpr dflags thing = showSDoc dflags (ppr thing) showSDocUnqual :: DynFlags -> SDoc -> String -- Only used by Haddock showSDocUnqual dflags sdoc = showSDoc dflags sdoc showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String -- Allows caller to specify the PrintUnqualified to use showSDocForUser dflags unqual doc = renderWithStyle dflags doc (mkUserStyle dflags unqual AllTheWay) showSDocDump :: DynFlags -> SDoc -> String showSDocDump dflags d = renderWithStyle dflags d (defaultDumpStyle dflags) showSDocDebug :: DynFlags -> SDoc -> String showSDocDebug dflags d = renderWithStyle dflags d PprDebug renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String renderWithStyle dflags sdoc sty = let s = Pretty.style{ Pretty.mode = PageMode, Pretty.lineLength = pprCols dflags } in Pretty.renderStyle s $ runSDoc sdoc (initSDocContext dflags sty) -- This shows an SDoc, but on one line only. It's cheaper than a full -- showSDoc, designed for when we're getting results like "Foo.bar" -- and "foo{uniq strictness}" so we don't want fancy layout anyway. showSDocOneLine :: DynFlags -> SDoc -> String showSDocOneLine dflags d = let s = Pretty.style{ Pretty.mode = OneLineMode, Pretty.lineLength = pprCols dflags } in Pretty.renderStyle s $ runSDoc d (initSDocContext dflags (defaultUserStyle dflags)) showSDocDumpOneLine :: DynFlags -> SDoc -> String showSDocDumpOneLine dflags d = let s = Pretty.style{ Pretty.mode = OneLineMode, Pretty.lineLength = irrelevantNCols } in Pretty.renderStyle s $ runSDoc d (initSDocContext dflags (defaultDumpStyle dflags)) irrelevantNCols :: Int -- Used for OneLineMode and LeftMode when number of cols isn't used irrelevantNCols = 1 isEmpty :: DynFlags -> SDoc -> Bool isEmpty dflags sdoc = Pretty.isEmpty $ runSDoc sdoc dummySDocContext where dummySDocContext = initSDocContext dflags PprDebug docToSDoc :: Doc -> SDoc docToSDoc d = SDoc (\_ -> d) empty :: SDoc char :: Char -> SDoc text :: String -> SDoc ftext :: FastString -> SDoc ptext :: PtrString -> SDoc ztext :: FastZString -> SDoc int :: Int -> SDoc integer :: Integer -> SDoc word :: Integer -> SDoc float :: Float -> SDoc double :: Double -> SDoc rational :: Rational -> SDoc empty = docToSDoc $ Pretty.empty char c = docToSDoc $ Pretty.char c text s = docToSDoc $ Pretty.text s {-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire ftext s = docToSDoc $ Pretty.ftext s ptext s = docToSDoc $ Pretty.ptext s ztext s = docToSDoc $ Pretty.ztext s int n = docToSDoc $ Pretty.int n integer n = docToSDoc $ Pretty.integer n float n = docToSDoc $ Pretty.float n double n = docToSDoc $ Pretty.double n rational n = docToSDoc $ Pretty.rational n word n = sdocWithDynFlags $ \dflags -> -- See Note [Print Hexadecimal Literals] in Pretty.hs if shouldUseHexWordLiterals dflags then docToSDoc $ Pretty.hex n else docToSDoc $ Pretty.integer n -- | @doublePrec p n@ shows a floating point number @n@ with @p@ -- digits of precision after the decimal point. doublePrec :: Int -> Double -> SDoc doublePrec p n = text (showFFloat (Just p) n "") parens, braces, brackets, quotes, quote, doubleQuotes, angleBrackets :: SDoc -> SDoc parens d = SDoc $ Pretty.parens . runSDoc d braces d = SDoc $ Pretty.braces . runSDoc d brackets d = SDoc $ Pretty.brackets . runSDoc d quote d = SDoc $ Pretty.quote . runSDoc d doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d angleBrackets d = char '<' <> d <> char '>' cparen :: Bool -> SDoc -> SDoc cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d -- 'quotes' encloses something in single quotes... -- but it omits them if the thing begins or ends in a single quote -- so that we don't get `foo''. Instead we just have foo'. quotes d = sdocWithDynFlags $ \dflags -> if useUnicode dflags then char '‘' <> d <> char '’' else SDoc $ \sty -> let pp_d = runSDoc d sty str = show pp_d in case (str, lastMaybe str) of (_, Just '\'') -> pp_d ('\'' : _, _) -> pp_d _other -> Pretty.quotes pp_d semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc blankLine = docToSDoc $ Pretty.text "" dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-") darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>") arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-") larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<") arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-") larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<") semi = docToSDoc $ Pretty.semi comma = docToSDoc $ Pretty.comma colon = docToSDoc $ Pretty.colon equals = docToSDoc $ Pretty.equals space = docToSDoc $ Pretty.space underscore = char '_' dot = char '.' vbar = char '|' lparen = docToSDoc $ Pretty.lparen rparen = docToSDoc $ Pretty.rparen lbrack = docToSDoc $ Pretty.lbrack rbrack = docToSDoc $ Pretty.rbrack lbrace = docToSDoc $ Pretty.lbrace rbrace = docToSDoc $ Pretty.rbrace forAllLit :: SDoc forAllLit = unicodeSyntax (char '∀') (text "forall") kindType :: SDoc kindType = sdocWithDynFlags $ \dflags -> if useStarIsType dflags then unicodeSyntax (char '★') (char '*') else text "Type" bullet :: SDoc bullet = unicode (char '•') (char '*') unicodeSyntax :: SDoc -> SDoc -> SDoc unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags -> if useUnicode dflags && useUnicodeSyntax dflags then unicode else plain unicode :: SDoc -> SDoc -> SDoc unicode unicode plain = sdocWithDynFlags $ \dflags -> if useUnicode dflags then unicode else plain nest :: Int -> SDoc -> SDoc -- ^ Indent 'SDoc' some specified amount (<>) :: SDoc -> SDoc -> SDoc -- ^ Join two 'SDoc' together horizontally without a gap (<+>) :: SDoc -> SDoc -> SDoc -- ^ Join two 'SDoc' together horizontally with a gap between them ($$) :: SDoc -> SDoc -> SDoc -- ^ Join two 'SDoc' together vertically; if there is -- no vertical overlap it "dovetails" the two onto one line ($+$) :: SDoc -> SDoc -> SDoc -- ^ Join two 'SDoc' together vertically nest n d = SDoc $ Pretty.nest n . runSDoc d (<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty) (<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty) ($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty) ($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty) hcat :: [SDoc] -> SDoc -- ^ Concatenate 'SDoc' horizontally hsep :: [SDoc] -> SDoc -- ^ Concatenate 'SDoc' horizontally with a space between each one vcat :: [SDoc] -> SDoc -- ^ Concatenate 'SDoc' vertically with dovetailing sep :: [SDoc] -> SDoc -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits cat :: [SDoc] -> SDoc -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits fsep :: [SDoc] -> SDoc -- ^ A paragraph-fill combinator. It's much like sep, only it -- keeps fitting things on one line until it can't fit any more. fcat :: [SDoc] -> SDoc -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds] hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds] vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds] sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds] cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds] fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds] fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds] hang :: SDoc -- ^ The header -> Int -- ^ Amount to indent the hung body -> SDoc -- ^ The hung body, indented and placed below the header -> SDoc hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty) -- | This behaves like 'hang', but does not indent the second document -- when the header is empty. hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc hangNotEmpty d1 n d2 = SDoc $ \sty -> Pretty.hangNotEmpty (runSDoc d1 sty) n (runSDoc d2 sty) punctuate :: SDoc -- ^ The punctuation -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements -> [SDoc] -- ^ Punctuated list punctuate _ [] = [] punctuate p (d:ds) = go d ds where go d [] = [d] go d (e:es) = (d <> p) : go e es ppWhen, ppUnless :: Bool -> SDoc -> SDoc ppWhen True doc = doc ppWhen False _ = empty ppUnless True _ = empty ppUnless False doc = doc -- | Apply the given colour\/style for the argument. -- -- Only takes effect if colours are enabled. coloured :: Col.PprColour -> SDoc -> SDoc coloured col sdoc = sdocWithDynFlags $ \dflags -> if shouldUseColor dflags then SDoc $ \ctx@SDC{ sdocLastColour = lastCol } -> case ctx of SDC{ sdocStyle = PprUser _ _ Coloured } -> let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in Pretty.zeroWidthText (Col.renderColour col) Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol) _ -> runSDoc sdoc ctx else sdoc keyword :: SDoc -> SDoc keyword = coloured Col.colBold {- ************************************************************************ * * \subsection[Outputable-class]{The @Outputable@ class} * * ************************************************************************ -} -- | Class designating that some type has an 'SDoc' representation class Outputable a where ppr :: a -> SDoc pprPrec :: Rational -> a -> SDoc -- 0 binds least tightly -- We use Rational because there is always a -- Rational between any other two Rationals ppr = pprPrec 0 pprPrec _ = ppr instance Outputable Char where ppr c = text [c] instance Outputable Bool where ppr True = text "True" ppr False = text "False" instance Outputable Ordering where ppr LT = text "LT" ppr EQ = text "EQ" ppr GT = text "GT" instance Outputable Int32 where ppr n = integer $ fromIntegral n instance Outputable Int64 where ppr n = integer $ fromIntegral n instance Outputable Int where ppr n = int n instance Outputable Integer where ppr n = integer n instance Outputable Word16 where ppr n = integer $ fromIntegral n instance Outputable Word32 where ppr n = integer $ fromIntegral n instance Outputable Word where ppr n = integer $ fromIntegral n instance Outputable Float where ppr f = float f instance Outputable Double where ppr f = double f instance Outputable () where ppr _ = text "()" instance (Outputable a) => Outputable [a] where ppr xs = brackets (fsep (punctuate comma (map ppr xs))) instance (Outputable a) => Outputable (Set a) where ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) instance (Outputable a, Outputable b) => Outputable (a, b) where ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) instance Outputable a => Outputable (Maybe a) where ppr Nothing = text "Nothing" ppr (Just x) = text "Just" <+> ppr x instance (Outputable a, Outputable b) => Outputable (Either a b) where ppr (Left x) = text "Left" <+> ppr x ppr (Right y) = text "Right" <+> ppr y -- ToDo: may not be used instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where ppr (x,y,z) = parens (sep [ppr x <> comma, ppr y <> comma, ppr z ]) instance (Outputable a, Outputable b, Outputable c, Outputable d) => Outputable (a, b, c, d) where ppr (a,b,c,d) = parens (sep [ppr a <> comma, ppr b <> comma, ppr c <> comma, ppr d]) instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) => Outputable (a, b, c, d, e) where ppr (a,b,c,d,e) = parens (sep [ppr a <> comma, ppr b <> comma, ppr c <> comma, ppr d <> comma, ppr e]) instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) => Outputable (a, b, c, d, e, f) where ppr (a,b,c,d,e,f) = parens (sep [ppr a <> comma, ppr b <> comma, ppr c <> comma, ppr d <> comma, ppr e <> comma, ppr f]) instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) => Outputable (a, b, c, d, e, f, g) where ppr (a,b,c,d,e,f,g) = parens (sep [ppr a <> comma, ppr b <> comma, ppr c <> comma, ppr d <> comma, ppr e <> comma, ppr f <> comma, ppr g]) instance Outputable FastString where ppr fs = ftext fs -- Prints an unadorned string, -- no double quotes or anything instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where ppr m = ppr (M.toList m) instance (Outputable elt) => Outputable (IM.IntMap elt) where ppr m = ppr (IM.toList m) instance Outputable Fingerprint where ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2) instance Outputable a => Outputable (SCC a) where ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) instance Outputable Serialized where ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type) instance Outputable Extension where ppr = text . show {- ************************************************************************ * * \subsection{The @OutputableBndr@ class} * * ************************************************************************ -} -- | 'BindingSite' is used to tell the thing that prints binder what -- language construct is binding the identifier. This can be used -- to decide how much info to print. -- Also see Note [Binding-site specific printing] in PprCore data BindingSite = LambdaBind -- ^ The x in (\x. e) | CaseBind -- ^ The x in case scrut of x { (y,z) -> ... } | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... } | LetBind -- ^ The x in (let x = rhs in e) -- | When we print a binder, we often want to print its type too. -- The @OutputableBndr@ class encapsulates this idea. class Outputable a => OutputableBndr a where pprBndr :: BindingSite -> a -> SDoc pprBndr _b x = ppr x pprPrefixOcc, pprInfixOcc :: a -> SDoc -- Print an occurrence of the name, suitable either in the -- prefix position of an application, thus (f a b) or ((+) x) -- or infix position, thus (a `f` b) or (x + y) bndrIsJoin_maybe :: a -> Maybe Int bndrIsJoin_maybe _ = Nothing -- When pretty-printing we sometimes want to find -- whether the binder is a join point. You might think -- we could have a function of type (a->Var), but Var -- isn't available yet, alas {- ************************************************************************ * * \subsection{Random printing helpers} * * ************************************************************************ -} -- We have 31-bit Chars and will simply use Show instances of Char and String. -- | Special combinator for showing character literals. pprHsChar :: Char -> SDoc pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) | otherwise = text (show c) -- | Special combinator for showing string literals. pprHsString :: FastString -> SDoc pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs))) -- | Special combinator for showing bytestring literals. pprHsBytes :: ByteString -> SDoc pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs in vcat (map text (showMultiLineString escaped)) <> char '#' where escape :: Word8 -> String escape w = let c = chr (fromIntegral w) in if isAscii c then [c] else '\\' : show w -- Postfix modifiers for unboxed literals. -- See Note [Printing of literals in Core] in `basicTypes/Literal.hs`. primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc primCharSuffix = char '#' primFloatSuffix = char '#' primIntSuffix = char '#' primDoubleSuffix = text "##" primWordSuffix = text "##" primInt64Suffix = text "L#" primWord64Suffix = text "L##" -- | Special combinator for showing unboxed literals. pprPrimChar :: Char -> SDoc pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc pprPrimChar c = pprHsChar c <> primCharSuffix pprPrimInt i = integer i <> primIntSuffix pprPrimWord w = word w <> primWordSuffix pprPrimInt64 i = integer i <> primInt64Suffix pprPrimWord64 w = word w <> primWord64Suffix --------------------- -- Put a name in parens if it's an operator pprPrefixVar :: Bool -> SDoc -> SDoc pprPrefixVar is_operator pp_v | is_operator = parens pp_v | otherwise = pp_v -- Put a name in backquotes if it's not an operator pprInfixVar :: Bool -> SDoc -> SDoc pprInfixVar is_operator pp_v | is_operator = pp_v | otherwise = char '`' <> pp_v <> char '`' --------------------- pprFastFilePath :: FastString -> SDoc pprFastFilePath path = text $ normalise $ unpackFS path -- | Normalise, escape and render a string representing a path -- -- e.g. "c:\\whatever" pprFilePathString :: FilePath -> SDoc pprFilePathString path = doubleQuotes $ text (escape (normalise path)) where escape [] = [] escape ('\\':xs) = '\\':'\\':escape xs escape (x:xs) = x:escape xs {- ************************************************************************ * * \subsection{Other helper functions} * * ************************************************************************ -} pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use -> [a] -- ^ The things to be pretty printed -> SDoc -- ^ 'SDoc' where the things have been pretty printed, -- comma-separated and finally packed into a paragraph. pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use -> [a] -- ^ The things to be pretty printed -> SDoc -- ^ 'SDoc' where the things have been pretty printed, -- bar-separated and finally packed into a paragraph. pprWithBars pp xs = fsep (intersperse vbar (map pp xs)) -- | Returns the separated concatenation of the pretty printed things. interppSP :: Outputable a => [a] -> SDoc interppSP xs = sep (map ppr xs) -- | Returns the comma-separated concatenation of the pretty printed things. interpp'SP :: Outputable a => [a] -> SDoc interpp'SP xs = sep (punctuate comma (map ppr xs)) -- | Returns the comma-separated concatenation of the quoted pretty printed things. -- -- > [x,y,z] ==> `x', `y', `z' pprQuotedList :: Outputable a => [a] -> SDoc pprQuotedList = quotedList . map ppr quotedList :: [SDoc] -> SDoc quotedList xs = fsep (punctuate comma (map quotes xs)) quotedListWithOr :: [SDoc] -> SDoc -- [x,y,z] ==> `x', `y' or `z' quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> text "or" <+> quotes (last xs) quotedListWithOr xs = quotedList xs quotedListWithNor :: [SDoc] -> SDoc -- [x,y,z] ==> `x', `y' nor `z' quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs) quotedListWithNor xs = quotedList xs {- ************************************************************************ * * \subsection{Printing numbers verbally} * * ************************************************************************ -} intWithCommas :: Integral a => a -> SDoc -- Prints a big integer with commas, eg 345,821 intWithCommas n | n < 0 = char '-' <> intWithCommas (-n) | q == 0 = int (fromIntegral r) | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r) where (q,r) = n `quotRem` 1000 zeroes | r >= 100 = empty | r >= 10 = char '0' | otherwise = text "00" -- | Converts an integer to a verbal index: -- -- > speakNth 1 = text "first" -- > speakNth 5 = text "fifth" -- > speakNth 21 = text "21st" speakNth :: Int -> SDoc speakNth 1 = text "first" speakNth 2 = text "second" speakNth 3 = text "third" speakNth 4 = text "fourth" speakNth 5 = text "fifth" speakNth 6 = text "sixth" speakNth n = hcat [ int n, text suffix ] where suffix | n <= 20 = "th" -- 11,12,13 are non-std | last_dig == 1 = "st" | last_dig == 2 = "nd" | last_dig == 3 = "rd" | otherwise = "th" last_dig = n `rem` 10 -- | Converts an integer to a verbal multiplicity: -- -- > speakN 0 = text "none" -- > speakN 5 = text "five" -- > speakN 10 = text "10" speakN :: Int -> SDoc speakN 0 = text "none" -- E.g. "he has none" speakN 1 = text "one" -- E.g. "he has one" speakN 2 = text "two" speakN 3 = text "three" speakN 4 = text "four" speakN 5 = text "five" speakN 6 = text "six" speakN n = int n -- | Converts an integer and object description to a statement about the -- multiplicity of those objects: -- -- > speakNOf 0 (text "melon") = text "no melons" -- > speakNOf 1 (text "melon") = text "one melon" -- > speakNOf 3 (text "melon") = text "three melons" speakNOf :: Int -> SDoc -> SDoc speakNOf 0 d = text "no" <+> d <> char 's' speakNOf 1 d = text "one" <+> d -- E.g. "one argument" speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" -- | Determines the pluralisation suffix appropriate for the length of a list: -- -- > plural [] = char 's' -- > plural ["Hello"] = empty -- > plural ["Hello", "World"] = char 's' plural :: [a] -> SDoc plural [_] = empty -- a bit frightening, but there you are plural _ = char 's' -- | Determines the form of to be appropriate for the length of a list: -- -- > isOrAre [] = text "are" -- > isOrAre ["Hello"] = text "is" -- > isOrAre ["Hello", "World"] = text "are" isOrAre :: [a] -> SDoc isOrAre [_] = text "is" isOrAre _ = text "are" -- | Determines the form of to do appropriate for the length of a list: -- -- > doOrDoes [] = text "do" -- > doOrDoes ["Hello"] = text "does" -- > doOrDoes ["Hello", "World"] = text "do" doOrDoes :: [a] -> SDoc doOrDoes [_] = text "does" doOrDoes _ = text "do" {- ************************************************************************ * * \subsection{Error handling} * * ************************************************************************ -} callStackDoc :: HasCallStack => SDoc callStackDoc = hang (text "Call stack:") 4 (vcat $ map text $ lines (prettyCallStack callStack)) pprPanic :: HasCallStack => String -> SDoc -> a -- ^ Throw an exception saying "bug in GHC" pprPanic s doc = panicDoc s (doc $$ callStackDoc) pprSorry :: String -> SDoc -> a -- ^ Throw an exception saying "this isn't finished yet" pprSorry = sorryDoc pprPgmError :: String -> SDoc -> a -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) pprPgmError = pgmErrorDoc pprTraceDebug :: String -> SDoc -> a -> a pprTraceDebug str doc x | debugIsOn && hasPprDebug unsafeGlobalDynFlags = pprTrace str doc x | otherwise = x pprTrace :: String -> SDoc -> a -> a -- ^ If debug output is on, show some 'SDoc' on the screen pprTrace str doc x | hasNoDebugOutput unsafeGlobalDynFlags = x | otherwise = pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x pprTraceM :: Applicative f => String -> SDoc -> f () pprTraceM str doc = pprTrace str doc (pure ()) -- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@. -- This allows you to print details from the returned value as well as from -- ambient variables. pprTraceWith :: String -> (a -> SDoc) -> a -> a pprTraceWith desc f x = pprTrace desc (f x) x -- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@ pprTraceIt :: Outputable a => String -> a -> a pprTraceIt desc x = pprTraceWith desc ppr x -- | @pprTraceException desc x action@ runs action, printing a message -- if it throws an exception. pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a pprTraceException heading doc = handleGhcException $ \exc -> liftIO $ do putStrLn $ showSDocDump unsafeGlobalDynFlags (sep [text heading, nest 2 doc]) throwGhcExceptionIO exc -- | If debug output is on, show some 'SDoc' on the screen along -- with a call stack when available. pprSTrace :: HasCallStack => SDoc -> a -> a pprSTrace doc = pprTrace "" (doc $$ callStackDoc) warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a -- ^ Just warn about an assertion failure, recording the given file and line number. -- Should typically be accessed with the WARN macros warnPprTrace _ _ _ _ x | not debugIsOn = x warnPprTrace _ _file _line _msg x | hasNoDebugOutput unsafeGlobalDynFlags = x warnPprTrace False _file _line _msg x = x warnPprTrace True file line msg x = pprDebugAndThen unsafeGlobalDynFlags trace heading (msg $$ callStackDoc ) x where heading = hsep [text "WARNING: file", text file <> comma, text "line", int line] -- | Panic with an assertation failure, recording the given file and -- line number. Should typically be accessed with the ASSERT family of macros assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a assertPprPanic _file _line msg = pprPanic "ASSERT failed!" msg pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a pprDebugAndThen dflags cont heading pretty_msg = cont (showSDocDump dflags doc) where doc = sep [heading, nest 2 pretty_msg] ghc-lib-parser-8.10.2.20200808/compiler/main/PackageConfig.hs0000644000000000000000000001276013713635745021270 0ustar0000000000000000{-# LANGUAGE CPP, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-} -- | -- Package configuration information: essentially the interface to Cabal, with -- some utilities -- -- (c) The University of Glasgow, 2004 -- module PackageConfig ( -- $package_naming -- * UnitId packageConfigId, expandedPackageConfigId, definitePackageConfigId, installedPackageConfigId, -- * The PackageConfig type: information about a package PackageConfig, InstalledPackageInfo(..), ComponentId(..), SourcePackageId(..), PackageName(..), Version(..), defaultPackageConfig, sourcePackageIdString, packageNameString, pprPackageConfig, ) where #include "GhclibHsVersions.h" import GhcPrelude import GHC.PackageDb import Data.Version import FastString import Outputable import Module import Unique -- ----------------------------------------------------------------------------- -- Our PackageConfig type is the InstalledPackageInfo from ghc-boot, -- which is similar to a subset of the InstalledPackageInfo type from Cabal. type PackageConfig = InstalledPackageInfo ComponentId SourcePackageId PackageName Module.InstalledUnitId Module.UnitId Module.ModuleName Module.Module -- TODO: there's no need for these to be FastString, as we don't need the uniq -- feature, but ghc doesn't currently have convenient support for any -- other compact string types, e.g. plain ByteString or Text. newtype SourcePackageId = SourcePackageId FastString deriving (Eq, Ord) newtype PackageName = PackageName FastString deriving (Eq, Ord) instance BinaryStringRep SourcePackageId where fromStringRep = SourcePackageId . mkFastStringByteString toStringRep (SourcePackageId s) = bytesFS s instance BinaryStringRep PackageName where fromStringRep = PackageName . mkFastStringByteString toStringRep (PackageName s) = bytesFS s instance Uniquable SourcePackageId where getUnique (SourcePackageId n) = getUnique n instance Uniquable PackageName where getUnique (PackageName n) = getUnique n instance Outputable SourcePackageId where ppr (SourcePackageId str) = ftext str instance Outputable PackageName where ppr (PackageName str) = ftext str defaultPackageConfig :: PackageConfig defaultPackageConfig = emptyInstalledPackageInfo sourcePackageIdString :: PackageConfig -> String sourcePackageIdString pkg = unpackFS str where SourcePackageId str = sourcePackageId pkg packageNameString :: PackageConfig -> String packageNameString pkg = unpackFS str where PackageName str = packageName pkg pprPackageConfig :: PackageConfig -> SDoc pprPackageConfig InstalledPackageInfo {..} = vcat [ field "name" (ppr packageName), field "version" (text (showVersion packageVersion)), field "id" (ppr unitId), field "exposed" (ppr exposed), field "exposed-modules" (ppr exposedModules), field "hidden-modules" (fsep (map ppr hiddenModules)), field "trusted" (ppr trusted), field "import-dirs" (fsep (map text importDirs)), field "library-dirs" (fsep (map text libraryDirs)), field "dynamic-library-dirs" (fsep (map text libraryDynDirs)), field "hs-libraries" (fsep (map text hsLibraries)), field "extra-libraries" (fsep (map text extraLibraries)), field "extra-ghci-libraries" (fsep (map text extraGHCiLibraries)), field "include-dirs" (fsep (map text includeDirs)), field "includes" (fsep (map text includes)), field "depends" (fsep (map ppr depends)), field "cc-options" (fsep (map text ccOptions)), field "ld-options" (fsep (map text ldOptions)), field "framework-dirs" (fsep (map text frameworkDirs)), field "frameworks" (fsep (map text frameworks)), field "haddock-interfaces" (fsep (map text haddockInterfaces)), field "haddock-html" (fsep (map text haddockHTMLs)) ] where field name body = text name <> colon <+> nest 4 body -- ----------------------------------------------------------------------------- -- UnitId (package names, versions and dep hash) -- $package_naming -- #package_naming# -- Mostly the compiler deals in terms of 'UnitId's, which are md5 hashes -- of a package ID, keys of its dependencies, and Cabal flags. You're expected -- to pass in the unit id in the @-this-unit-id@ flag. However, for -- wired-in packages like @base@ & @rts@, we don't necessarily know what the -- version is, so these are handled specially; see #wired_in_packages#. -- | Get the GHC 'UnitId' right out of a Cabalish 'PackageConfig' installedPackageConfigId :: PackageConfig -> InstalledUnitId installedPackageConfigId = unitId packageConfigId :: PackageConfig -> UnitId packageConfigId p = if indefinite p then newUnitId (componentId p) (instantiatedWith p) else DefiniteUnitId (DefUnitId (unitId p)) expandedPackageConfigId :: PackageConfig -> UnitId expandedPackageConfigId p = newUnitId (componentId p) (instantiatedWith p) definitePackageConfigId :: PackageConfig -> Maybe DefUnitId definitePackageConfigId p = case packageConfigId p of DefiniteUnitId def_uid -> Just def_uid _ -> Nothing ghc-lib-parser-8.10.2.20200808/compiler/main/Packages.hs0000644000000000000000000030163213713635745020324 0ustar0000000000000000-- (c) The University of Glasgow, 2006 {-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-} -- | Package manipulation module Packages ( module PackageConfig, -- * Reading the package config, and processing cmdline args PackageState(preloadPackages, explicitPackages, moduleToPkgConfAll, requirementContext), PackageConfigMap, emptyPackageState, initPackages, readPackageConfigs, getPackageConfRefs, resolvePackageConfig, readPackageConfig, listPackageConfigMap, -- * Querying the package config lookupPackage, lookupPackage', lookupInstalledPackage, lookupPackageName, improveUnitId, searchPackageId, getPackageDetails, getInstalledPackageDetails, componentIdString, displayInstalledUnitId, listVisibleModuleNames, lookupModuleInAllPackages, lookupModuleWithSuggestions, lookupPluginModuleWithSuggestions, LookupResult(..), ModuleSuggestion(..), ModuleOrigin(..), UnusablePackageReason(..), pprReason, -- * Inspecting the set of packages in scope getPackageIncludePath, getPackageLibraryPath, getPackageLinkOpts, getPackageExtraCcOpts, getPackageFrameworkPath, getPackageFrameworks, getPackageConfigMap, getPreloadPackagesAnd, collectArchives, collectIncludeDirs, collectLibraryPaths, collectLinkOpts, packageHsLibs, getLibs, -- * Utils unwireUnitId, pprFlag, pprPackages, pprPackagesSimple, pprModuleMap, isIndefinite, isDllName ) where #include "GhclibHsVersions.h" import GhcPrelude import GHC.PackageDb import PackageConfig import DynFlags import Name ( Name, nameModule_maybe ) import UniqFM import UniqDFM import UniqSet import Module import Util import Panic import GHC.Platform import Outputable import Maybes import CmdLineParser import System.Environment ( getEnv ) import FastString import ErrUtils ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, compilationProgressMsg, withTiming ) import Exception import System.Directory import System.FilePath as FilePath import qualified System.FilePath.Posix as FilePath.Posix import System.IO.Error ( isDoesNotExistError ) import Control.Monad import Data.Graph (stronglyConnComp, SCC(..)) import Data.Char ( toUpper ) import Data.List as List import Data.Map (Map) import Data.Set (Set) import Data.Monoid (First(..)) import qualified Data.Semigroup as Semigroup import qualified Data.Map as Map import qualified Data.Map.Strict as MapStrict import qualified Data.Set as Set import Data.Version -- --------------------------------------------------------------------------- -- The Package state -- | Package state is all stored in 'DynFlags', including the details of -- all packages, which packages are exposed, and which modules they -- provide. -- -- The package state is computed by 'initPackages', and kept in DynFlags. -- It is influenced by various package flags: -- -- * @-package @ and @-package-id @ cause @@ to become exposed. -- If @-hide-all-packages@ was not specified, these commands also cause -- all other packages with the same name to become hidden. -- -- * @-hide-package @ causes @@ to become hidden. -- -- * (there are a few more flags, check below for their semantics) -- -- The package state has the following properties. -- -- * Let @exposedPackages@ be the set of packages thus exposed. -- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of -- their dependencies. -- -- * When searching for a module from a preload import declaration, -- only the exposed modules in @exposedPackages@ are valid. -- -- * When searching for a module from an implicit import, all modules -- from @depExposedPackages@ are valid. -- -- * When linking in a compilation manager mode, we link in packages the -- program depends on (the compiler knows this list by the -- time it gets to the link step). Also, we link in all packages -- which were mentioned with preload @-package@ flags on the command-line, -- or are a transitive dependency of same, or are \"base\"\/\"rts\". -- The reason for this is that we might need packages which don't -- contain any Haskell modules, and therefore won't be discovered -- by the normal mechanism of dependency tracking. -- Notes on DLLs -- ~~~~~~~~~~~~~ -- When compiling module A, which imports module B, we need to -- know whether B will be in the same DLL as A. -- If it's in the same DLL, we refer to B_f_closure -- If it isn't, we refer to _imp__B_f_closure -- When compiling A, we record in B's Module value whether it's -- in a different DLL, by setting the DLL flag. -- | Given a module name, there may be multiple ways it came into scope, -- possibly simultaneously. This data type tracks all the possible ways -- it could have come into scope. Warning: don't use the record functions, -- they're partial! data ModuleOrigin = -- | Module is hidden, and thus never will be available for import. -- (But maybe the user didn't realize), so we'll still keep track -- of these modules.) ModHidden -- | Module is unavailable because the package is unusable. | ModUnusable UnusablePackageReason -- | Module is public, and could have come from some places. | ModOrigin { -- | @Just False@ means that this module is in -- someone's @exported-modules@ list, but that package is hidden; -- @Just True@ means that it is available; @Nothing@ means neither -- applies. fromOrigPackage :: Maybe Bool -- | Is the module available from a reexport of an exposed package? -- There could be multiple. , fromExposedReexport :: [PackageConfig] -- | Is the module available from a reexport of a hidden package? , fromHiddenReexport :: [PackageConfig] -- | Did the module export come from a package flag? (ToDo: track -- more information. , fromPackageFlag :: Bool } instance Outputable ModuleOrigin where ppr ModHidden = text "hidden module" ppr (ModUnusable _) = text "unusable module" ppr (ModOrigin e res rhs f) = sep (punctuate comma ( (case e of Nothing -> [] Just False -> [text "hidden package"] Just True -> [text "exposed package"]) ++ (if null res then [] else [text "reexport by" <+> sep (map (ppr . packageConfigId) res)]) ++ (if null rhs then [] else [text "hidden reexport by" <+> sep (map (ppr . packageConfigId) res)]) ++ (if f then [text "package flag"] else []) )) -- | Smart constructor for a module which is in @exposed-modules@. Takes -- as an argument whether or not the defining package is exposed. fromExposedModules :: Bool -> ModuleOrigin fromExposedModules e = ModOrigin (Just e) [] [] False -- | Smart constructor for a module which is in @reexported-modules@. Takes -- as an argument whether or not the reexporting package is expsed, and -- also its 'PackageConfig'. fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False -- | Smart constructor for a module which was bound by a package flag. fromFlag :: ModuleOrigin fromFlag = ModOrigin Nothing [] [] True instance Semigroup ModuleOrigin where ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' = ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') where g (Just b) (Just b') | b == b' = Just b | otherwise = panic "ModOrigin: package both exposed/hidden" g Nothing x = x g x Nothing = x _x <> _y = panic "ModOrigin: hidden module redefined" instance Monoid ModuleOrigin where mempty = ModOrigin Nothing [] [] False mappend = (Semigroup.<>) -- | Is the name from the import actually visible? (i.e. does it cause -- ambiguity, or is it only relevant when we're making suggestions?) originVisible :: ModuleOrigin -> Bool originVisible ModHidden = False originVisible (ModUnusable _) = False originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f -- | Are there actually no providers for this module? This will never occur -- except when we're filtering based on package imports. originEmpty :: ModuleOrigin -> Bool originEmpty (ModOrigin Nothing [] [] False) = True originEmpty _ = False -- | 'UniqFM' map from 'InstalledUnitId' type InstalledUnitIdMap = UniqDFM -- | 'UniqFM' map from 'UnitId' to 'PackageConfig', plus -- the transitive closure of preload packages. data PackageConfigMap = PackageConfigMap { unPackageConfigMap :: InstalledUnitIdMap PackageConfig, -- | The set of transitively reachable packages according -- to the explicitly provided command line arguments. -- See Note [UnitId to InstalledUnitId improvement] preloadClosure :: UniqSet InstalledUnitId } -- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'. type VisibilityMap = Map UnitId UnitVisibility -- | 'UnitVisibility' records the various aspects of visibility of a particular -- 'UnitId'. data UnitVisibility = UnitVisibility { uv_expose_all :: Bool -- ^ Should all modules in exposed-modules should be dumped into scope? , uv_renamings :: [(ModuleName, ModuleName)] -- ^ Any custom renamings that should bring extra 'ModuleName's into -- scope. , uv_package_name :: First FastString -- ^ The package name is associated with the 'UnitId'. This is used -- to implement legacy behavior where @-package foo-0.1@ implicitly -- hides any packages named @foo@ , uv_requirements :: Map ModuleName (Set IndefModule) -- ^ The signatures which are contributed to the requirements context -- from this unit ID. , uv_explicit :: Bool -- ^ Whether or not this unit was explicitly brought into scope, -- as opposed to implicitly via the 'exposed' fields in the -- package database (when @-hide-all-packages@ is not passed.) } instance Outputable UnitVisibility where ppr (UnitVisibility { uv_expose_all = b, uv_renamings = rns, uv_package_name = First mb_pn, uv_requirements = reqs, uv_explicit = explicit }) = ppr (b, rns, mb_pn, reqs, explicit) instance Semigroup UnitVisibility where uv1 <> uv2 = UnitVisibility { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2) , uv_explicit = uv_explicit uv1 || uv_explicit uv2 } instance Monoid UnitVisibility where mempty = UnitVisibility { uv_expose_all = False , uv_renamings = [] , uv_package_name = First Nothing , uv_requirements = Map.empty , uv_explicit = False } mappend = (Semigroup.<>) type WiredUnitId = DefUnitId type PreloadUnitId = InstalledUnitId -- | Map from 'ModuleName' to 'Module' to all the origins of the bindings -- in scope. The 'PackageConf' is not cached, mostly for convenience reasons -- (since this is the slow path, we'll just look it up again). type ModuleToPkgConfAll = Map ModuleName (Map Module ModuleOrigin) data PackageState = PackageState { -- | A mapping of 'UnitId' to 'PackageConfig'. This list is adjusted -- so that only valid packages are here. 'PackageConfig' reflects -- what was stored *on disk*, except for the 'trusted' flag, which -- is adjusted at runtime. (In particular, some packages in this map -- may have the 'exposed' flag be 'False'.) pkgIdMap :: PackageConfigMap, -- | A mapping of 'PackageName' to 'ComponentId'. This is used when -- users refer to packages in Backpack includes. packageNameMap :: Map PackageName ComponentId, -- | A mapping from wired in names to the original names from the -- package database. unwireMap :: Map WiredUnitId WiredUnitId, -- | The packages we're going to link in eagerly. This list -- should be in reverse dependency order; that is, a package -- is always mentioned before the packages it depends on. preloadPackages :: [PreloadUnitId], -- | Packages which we explicitly depend on (from a command line flag). -- We'll use this to generate version macros. explicitPackages :: [UnitId], -- | This is a full map from 'ModuleName' to all modules which may possibly -- be providing it. These providers may be hidden (but we'll still want -- to report them in error messages), or it may be an ambiguous import. moduleToPkgConfAll :: !ModuleToPkgConfAll, -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility. pluginModuleToPkgConfAll :: !ModuleToPkgConfAll, -- | A map saying, for each requirement, what interfaces must be merged -- together when we use them. For example, if our dependencies -- are @p[A=]@ and @q[A=,B=r[C=]:B]@, then the interfaces -- to merge for A are @p[A=]:A@, @q[A=,B=r[C=]:B]:A@ -- and @r[C=]:C@. -- -- There's an entry in this map for each hole in our home library. requirementContext :: Map ModuleName [IndefModule] } emptyPackageState :: PackageState emptyPackageState = PackageState { pkgIdMap = emptyPackageConfigMap, packageNameMap = Map.empty, unwireMap = Map.empty, preloadPackages = [], explicitPackages = [], moduleToPkgConfAll = Map.empty, pluginModuleToPkgConfAll = Map.empty, requirementContext = Map.empty } type InstalledPackageIndex = Map InstalledUnitId PackageConfig -- | Empty package configuration map emptyPackageConfigMap :: PackageConfigMap emptyPackageConfigMap = PackageConfigMap emptyUDFM emptyUniqSet -- | Find the package we know about with the given unit id, if any lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (pkgState dflags)) -- | A more specialized interface, which takes a boolean specifying -- whether or not to look for on-the-fly renamed interfaces, and -- just a 'PackageConfigMap' rather than a 'DynFlags' (so it can -- be used while we're initializing 'DynFlags' lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig lookupPackage' False (PackageConfigMap pkg_map _) uid = lookupUDFM pkg_map uid lookupPackage' True m@(PackageConfigMap pkg_map _) uid = case splitUnitIdInsts uid of (iuid, Just indef) -> fmap (renamePackage m (indefUnitIdInsts indef)) (lookupUDFM pkg_map iuid) (_, Nothing) -> lookupUDFM pkg_map uid {- -- | Find the indefinite package for a given 'ComponentId'. -- The way this works is just by fiat'ing that every indefinite package's -- unit key is precisely its component ID; and that they share uniques. lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs where PackageConfigMap pkg_map = pkgIdMap (pkgState dflags) -} -- | Find the package we know about with the given package name (e.g. @foo@), if any -- (NB: there might be a locally defined unit name which overrides this) lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags)) -- | Search for packages with a given package ID (e.g. \"foo-0.1\") searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig] searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) (listPackageConfigMap dflags) -- | Extends the package configuration map with a list of package configs. extendPackageConfigMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs = PackageConfigMap (foldl' add pkg_map new_pkgs) closure -- We also add the expanded version of the packageConfigId, so that -- 'improveUnitId' can find it. where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p) (installedPackageConfigId p) p -- | Looks up the package with the given id in the package state, panicing if it is -- not found getPackageDetails :: DynFlags -> UnitId -> PackageConfig getPackageDetails dflags pid = expectJust "getPackageDetails" (lookupPackage dflags pid) lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig lookupInstalledPackage dflags uid = lookupInstalledPackage' (pkgIdMap (pkgState dflags)) uid lookupInstalledPackage' :: PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig lookupInstalledPackage' (PackageConfigMap db _) uid = lookupUDFM db uid getInstalledPackageDetails :: DynFlags -> InstalledUnitId -> PackageConfig getInstalledPackageDetails dflags uid = expectJust "getInstalledPackageDetails" $ lookupInstalledPackage dflags uid -- | Get a list of entries from the package database. NB: be careful with -- this function, although all packages in this map are "visible", this -- does not imply that the exposed-modules of the package are available -- (they may have been thinned or renamed). listPackageConfigMap :: DynFlags -> [PackageConfig] listPackageConfigMap dflags = eltsUDFM pkg_map where PackageConfigMap pkg_map _ = pkgIdMap (pkgState dflags) -- ---------------------------------------------------------------------------- -- Loading the package db files and building up the package state -- | Call this after 'DynFlags.parseDynFlags'. It reads the package -- database files, and sets up various internal tables of package -- information, according to the package-related flags on the -- command-line (@-package@, @-hide-package@ etc.) -- -- Returns a list of packages to link in if we're doing dynamic linking. -- This list contains the packages that the user explicitly mentioned with -- @-package@ flags. -- -- 'initPackages' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'pkgState' in 'DynFlags' and return a list of packages to -- link in. initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId]) initPackages dflags0 = withTiming dflags0 (text "initializing package database") forcePkgDb $ do dflags <- interpretPackageEnv dflags0 pkg_db <- case pkgDatabase dflags of Nothing -> readPackageConfigs dflags Just db -> return $ map (\(p, pkgs) -> (p, setBatchPackageFlags dflags pkgs)) db (pkg_state, preload, insts) <- mkPackageState dflags pkg_db [] return (dflags{ pkgDatabase = Just pkg_db, pkgState = pkg_state, thisUnitIdInsts_ = insts }, preload) where forcePkgDb (dflags, _) = pkgIdMap (pkgState dflags) `seq` () -- ----------------------------------------------------------------------------- -- Reading the package database(s) readPackageConfigs :: DynFlags -> IO [(FilePath, [PackageConfig])] readPackageConfigs dflags = do conf_refs <- getPackageConfRefs dflags confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs mapM (readPackageConfig dflags) confs getPackageConfRefs :: DynFlags -> IO [PkgConfRef] getPackageConfRefs dflags = do let system_conf_refs = [UserPkgConf, GlobalPkgConf] e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH") let base_conf_refs = case e_pkg_path of Left _ -> system_conf_refs Right path | not (null path) && isSearchPathSeparator (last path) -> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs | otherwise -> map PkgConfFile (splitSearchPath path) -- Apply the package DB-related flags from the command line to get the -- final list of package DBs. -- -- Notes on ordering: -- * The list of flags is reversed (later ones first) -- * We work with the package DB list in "left shadows right" order -- * and finally reverse it at the end, to get "right shadows left" -- return $ reverse (foldr doFlag base_conf_refs (packageDBFlags dflags)) where doFlag (PackageDB p) dbs = p : dbs doFlag NoUserPackageDB dbs = filter isNotUser dbs doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs doFlag ClearPackageDBs _ = [] isNotUser UserPkgConf = False isNotUser _ = True isNotGlobal GlobalPkgConf = False isNotGlobal _ = True resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath) resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags) -- NB: This logic is reimplemented in Cabal, so if you change it, -- make sure you update Cabal. (Or, better yet, dump it in the -- compiler info so Cabal can use the info.) resolvePackageConfig dflags UserPkgConf = runMaybeT $ do dir <- versionedAppDir dflags let pkgconf = dir "package.conf.d" exist <- tryMaybeT $ doesDirectoryExist pkgconf if exist then return pkgconf else mzero resolvePackageConfig _ (PkgConfFile name) = return $ Just name readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig]) readPackageConfig dflags conf_file = do isdir <- doesDirectoryExist conf_file proto_pkg_configs <- if isdir then readDirStylePackageConfig conf_file else do isfile <- doesFileExist conf_file if isfile then do mpkgs <- tryReadOldFileStylePackageConfig case mpkgs of Just pkgs -> return pkgs Nothing -> throwGhcExceptionIO $ InstallationError $ "ghc no longer supports single-file style package " ++ "databases (" ++ conf_file ++ ") use 'ghc-pkg init' to create the database with " ++ "the correct format." else throwGhcExceptionIO $ InstallationError $ "can't find a package database at " ++ conf_file let -- Fix #16360: remove trailing slash from conf_file before calculting pkgroot conf_file' = dropTrailingPathSeparator conf_file top_dir = topDir dflags pkgroot = takeDirectory conf_file' pkg_configs1 = map (mungePackageConfig top_dir pkgroot) proto_pkg_configs pkg_configs2 = setBatchPackageFlags dflags pkg_configs1 -- return (conf_file', pkg_configs2) where readDirStylePackageConfig conf_dir = do let filename = conf_dir "package.cache" cache_exists <- doesFileExist filename if cache_exists then do debugTraceMsg dflags 2 $ text "Using binary package database:" <+> text filename readPackageDbForGhc filename else do -- If there is no package.cache file, we check if the database is not -- empty by inspecting if the directory contains any .conf file. If it -- does, something is wrong and we fail. Otherwise we assume that the -- database is empty. debugTraceMsg dflags 2 $ text "There is no package.cache in" <+> text conf_dir <> text ", checking if the database is empty" db_empty <- all (not . isSuffixOf ".conf") <$> getDirectoryContents conf_dir if db_empty then do debugTraceMsg dflags 3 $ text "There are no .conf files in" <+> text conf_dir <> text ", treating" <+> text "package database as empty" return [] else do throwGhcExceptionIO $ InstallationError $ "there is no package.cache in " ++ conf_dir ++ " even though package database is not empty" -- Single-file style package dbs have been deprecated for some time, but -- it turns out that Cabal was using them in one place. So this is a -- workaround to allow older Cabal versions to use this newer ghc. -- We check if the file db contains just "[]" and if so, we look for a new -- dir-style db in conf_file.d/, ie in a dir next to the given file. -- We cannot just replace the file with a new dir style since Cabal still -- assumes it's a file and tries to overwrite with 'writeFile'. -- ghc-pkg also cooperates with this workaround. tryReadOldFileStylePackageConfig = do content <- readFile conf_file `catchIO` \_ -> return "" if take 2 content == "[]" then do let conf_dir = conf_file <.> "d" direxists <- doesDirectoryExist conf_dir if direxists then do debugTraceMsg dflags 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir) liftM Just (readDirStylePackageConfig conf_dir) else return (Just []) -- ghc-pkg will create it when it's updated else return Nothing setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig] setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs where maybeDistrustAll pkgs' | gopt Opt_DistrustAllPackages dflags = map distrust pkgs' | otherwise = pkgs' distrust pkg = pkg{ trusted = False } mungePackageConfig :: FilePath -> FilePath -> PackageConfig -> PackageConfig mungePackageConfig top_dir pkgroot = mungeDynLibFields . mungePackagePaths top_dir pkgroot mungeDynLibFields :: PackageConfig -> PackageConfig mungeDynLibFields pkg = pkg { libraryDynDirs = libraryDynDirs pkg `orIfNull` libraryDirs pkg } where orIfNull [] flags = flags orIfNull flags _ = flags -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. -- The "pkgroot" is the directory containing the package database. -- -- Also perform a similar substitution for the older GHC-specific -- "$topdir" variable. The "topdir" is the location of the ghc -- installation (obtained from the -B option). mungePackagePaths top_dir pkgroot pkg = pkg { importDirs = munge_paths (importDirs pkg), includeDirs = munge_paths (includeDirs pkg), libraryDirs = munge_paths (libraryDirs pkg), libraryDynDirs = munge_paths (libraryDynDirs pkg), frameworkDirs = munge_paths (frameworkDirs pkg), haddockInterfaces = munge_paths (haddockInterfaces pkg), haddockHTMLs = munge_urls (haddockHTMLs pkg) } where munge_paths = map munge_path munge_urls = map munge_url munge_path p | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' | otherwise = p munge_url p | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' | otherwise = p toUrlPath r p = "file:///" -- URLs always use posix style '/' separators: ++ FilePath.Posix.joinPath (r : -- We need to drop a leading "/" or "\\" -- if there is one: dropWhile (all isPathSeparator) (FilePath.splitDirectories p)) -- We could drop the separator here, and then use above. However, -- by leaving it in and using ++ we keep the same path separator -- rather than letting FilePath change it to use \ as the separator stripVarPrefix var path = case stripPrefix var path of Just [] -> Just [] Just cs@(c : _) | isPathSeparator c -> Just cs _ -> Nothing -- ----------------------------------------------------------------------------- -- Modify our copy of the package database based on trust flags, -- -trust and -distrust. applyTrustFlag :: DynFlags -> PackagePrecedenceIndex -> UnusablePackages -> [PackageConfig] -> TrustFlag -> IO [PackageConfig] applyTrustFlag dflags prec_map unusable pkgs flag = case flag of -- we trust all matching packages. Maybe should only trust first one? -- and leave others the same or set them untrusted TrustPackage str -> case selectPackages prec_map (PackageArg str) pkgs unusable of Left ps -> trustFlagErr dflags flag ps Right (ps,qs) -> return (map trust ps ++ qs) where trust p = p {trusted=True} DistrustPackage str -> case selectPackages prec_map (PackageArg str) pkgs unusable of Left ps -> trustFlagErr dflags flag ps Right (ps,qs) -> return (map distrust ps ++ qs) where distrust p = p {trusted=False} -- | A little utility to tell if the 'thisPackage' is indefinite -- (if it is not, we should never use on-the-fly renaming.) isIndefinite :: DynFlags -> Bool isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags)) applyPackageFlag :: DynFlags -> PackagePrecedenceIndex -> PackageConfigMap -> UnusablePackages -> Bool -- if False, if you expose a package, it implicitly hides -- any previously exposed packages with the same name -> [PackageConfig] -> VisibilityMap -- Initially exposed -> PackageFlag -- flag to apply -> IO VisibilityMap -- Now exposed applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag = case flag of ExposePackage _ arg (ModRenaming b rns) -> case findPackages prec_map pkg_db arg pkgs unusable of Left ps -> packageFlagErr dflags flag ps Right (p:_) -> return vm' where n = fsPackageName p -- If a user says @-unit-id p[A=]@, this imposes -- a requirement on us: whatever our signature A is, -- it must fulfill all of p[A=]:A's requirements. -- This method is responsible for computing what our -- inherited requirements are. reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid | otherwise = Map.empty collectHoles uid = case splitUnitIdInsts uid of (_, Just indef) -> let local = [ Map.singleton (moduleName mod) (Set.singleton $ IndefModule indef mod_name) | (mod_name, mod) <- indefUnitIdInsts indef , isHoleModule mod ] recurse = [ collectHoles (moduleUnitId mod) | (_, mod) <- indefUnitIdInsts indef ] in Map.unionsWith Set.union $ local ++ recurse -- Other types of unit identities don't have holes (_, Nothing) -> Map.empty uv = UnitVisibility { uv_expose_all = b , uv_renamings = rns , uv_package_name = First (Just n) , uv_requirements = reqs , uv_explicit = True } vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared -- In the old days, if you said `ghc -package p-0.1 -package p-0.2` -- (or if p-0.1 was registered in the pkgdb as exposed: True), -- the second package flag would override the first one and you -- would only see p-0.2 in exposed modules. This is good for -- usability. -- -- However, with thinning and renaming (or Backpack), there might be -- situations where you legitimately want to see two versions of a -- package at the same time, and this behavior would make it -- impossible to do so. So we decided that if you pass -- -hide-all-packages, this should turn OFF the overriding behavior -- where an exposed package hides all other packages with the same -- name. This should not affect Cabal at all, which only ever -- exposes one package at a time. -- -- NB: Why a variable no_hide_others? We have to apply this logic to -- -plugin-package too, and it's more consistent if the switch in -- behavior is based off of -- -hide-all-packages/-hide-all-plugin-packages depending on what -- flag is in question. vm_cleared | no_hide_others = vm -- NB: renamings never clear | (_:_) <- rns = vm | otherwise = Map.filterWithKey (\k uv -> k == packageConfigId p || First (Just n) /= uv_package_name uv) vm _ -> panic "applyPackageFlag" HidePackage str -> case findPackages prec_map pkg_db (PackageArg str) pkgs unusable of Left ps -> packageFlagErr dflags flag ps Right ps -> return vm' where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps) -- | Like 'selectPackages', but doesn't return a list of unmatched -- packages. Furthermore, any packages it returns are *renamed* -- if the 'UnitArg' has a renaming associated with it. findPackages :: PackagePrecedenceIndex -> PackageConfigMap -> PackageArg -> [PackageConfig] -> UnusablePackages -> Either [(PackageConfig, UnusablePackageReason)] [PackageConfig] findPackages prec_map pkg_db arg pkgs unusable = let ps = mapMaybe (finder arg) pkgs in if null ps then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) (Map.elems unusable)) else Right (sortByPreference prec_map ps) where finder (PackageArg str) p = if str == sourcePackageIdString p || str == packageNameString p then Just p else Nothing finder (UnitIdArg uid) p = let (iuid, mb_indef) = splitUnitIdInsts uid in if iuid == installedPackageConfigId p then Just (case mb_indef of Nothing -> p Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p) else Nothing selectPackages :: PackagePrecedenceIndex -> PackageArg -> [PackageConfig] -> UnusablePackages -> Either [(PackageConfig, UnusablePackageReason)] ([PackageConfig], [PackageConfig]) selectPackages prec_map arg pkgs unusable = let matches = matching arg (ps,rest) = partition matches pkgs in if null ps then Left (filter (matches.fst) (Map.elems unusable)) else Right (sortByPreference prec_map ps, rest) -- | Rename a 'PackageConfig' according to some module instantiation. renamePackage :: PackageConfigMap -> [(ModuleName, Module)] -> PackageConfig -> PackageConfig renamePackage pkg_map insts conf = let hsubst = listToUFM insts smod = renameHoleModule' pkg_map hsubst new_insts = map (\(k,v) -> (k,smod v)) (instantiatedWith conf) in conf { instantiatedWith = new_insts, exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) (exposedModules conf) } -- A package named on the command line can either include the -- version, or just the name if it is unambiguous. matchingStr :: String -> PackageConfig -> Bool matchingStr str p = str == sourcePackageIdString p || str == packageNameString p matchingId :: InstalledUnitId -> PackageConfig -> Bool matchingId uid p = uid == installedPackageConfigId p matching :: PackageArg -> PackageConfig -> Bool matching (PackageArg str) = matchingStr str matching (UnitIdArg (DefiniteUnitId (DefUnitId uid))) = matchingId uid matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case -- | This sorts a list of packages, putting "preferred" packages first. -- See 'compareByPreference' for the semantics of "preference". sortByPreference :: PackagePrecedenceIndex -> [PackageConfig] -> [PackageConfig] sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) -- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking -- which should be "active". Here is the order of preference: -- -- 1. First, prefer the latest version -- 2. If the versions are the same, prefer the package that -- came in the latest package database. -- -- Pursuant to #12518, we could change this policy to, for example, remove -- the version preference, meaning that we would always prefer the packages -- in later package database. -- -- Instead, we use that preference based policy only when one of the packages -- is integer-gmp and the other is integer-simple. -- This currently only happens when we're looking up which concrete -- package to use in place of @integer-wired-in@ and that two different -- package databases supply a different integer library. For more about -- the fake @integer-wired-in@ package, see Note [The integer library] -- in the @PrelNames@ module. compareByPreference :: PackagePrecedenceIndex -> PackageConfig -> PackageConfig -> Ordering compareByPreference prec_map pkg pkg' | Just prec <- Map.lookup (unitId pkg) prec_map , Just prec' <- Map.lookup (unitId pkg') prec_map , differentIntegerPkgs pkg pkg' = compare prec prec' | otherwise = case comparing packageVersion pkg pkg' of GT -> GT EQ | Just prec <- Map.lookup (unitId pkg) prec_map , Just prec' <- Map.lookup (unitId pkg') prec_map -- Prefer the package from the later DB flag (i.e., higher -- precedence) -> compare prec prec' | otherwise -> EQ LT -> LT where isIntegerPkg p = packageNameString p `elem` ["integer-simple", "integer-gmp"] differentIntegerPkgs p p' = isIntegerPkg p && isIntegerPkg p' && (packageName p /= packageName p') comparing :: Ord a => (t -> a) -> t -> t -> Ordering comparing f a b = f a `compare` f b packageFlagErr :: DynFlags -> PackageFlag -> [(PackageConfig, UnusablePackageReason)] -> IO a packageFlagErr dflags flag reasons = packageFlagErr' dflags (pprFlag flag) reasons trustFlagErr :: DynFlags -> TrustFlag -> [(PackageConfig, UnusablePackageReason)] -> IO a trustFlagErr dflags flag reasons = packageFlagErr' dflags (pprTrustFlag flag) reasons packageFlagErr' :: DynFlags -> SDoc -> [(PackageConfig, UnusablePackageReason)] -> IO a packageFlagErr' dflags flag_doc reasons = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err)) where err = text "cannot satisfy " <> flag_doc <> (if null reasons then Outputable.empty else text ": ") $$ nest 4 (ppr_reasons $$ text "(use -v for more information)") ppr_reasons = vcat (map ppr_reason reasons) ppr_reason (p, reason) = pprReason (ppr (unitId p) <+> text "is") reason pprFlag :: PackageFlag -> SDoc pprFlag flag = case flag of HidePackage p -> text "-hide-package " <> text p ExposePackage doc _ _ -> text doc pprTrustFlag :: TrustFlag -> SDoc pprTrustFlag flag = case flag of TrustPackage p -> text "-trust " <> text p DistrustPackage p -> text "-distrust " <> text p -- ----------------------------------------------------------------------------- -- Wired-in packages -- -- See Note [Wired-in packages] in Module type WiredInUnitId = String type WiredPackagesMap = Map WiredUnitId WiredUnitId wired_in_pkgids :: [WiredInUnitId] wired_in_pkgids = map unitIdString wiredInUnitIds findWiredInPackages :: DynFlags -> PackagePrecedenceIndex -> [PackageConfig] -- database -> VisibilityMap -- info on what packages are visible -- for wired in selection -> IO ([PackageConfig], -- package database updated for wired in WiredPackagesMap) -- map from unit id to wired identity findWiredInPackages dflags prec_map pkgs vis_map = do -- Now we must find our wired-in packages, and rename them to -- their canonical names (eg. base-1.0 ==> base), as described -- in Note [Wired-in packages] in Module let matches :: PackageConfig -> WiredInUnitId -> Bool pc `matches` pid -- See Note [The integer library] in PrelNames | pid == unitIdString integerUnitId = packageNameString pc `elem` ["integer-gmp", "integer-simple"] pc `matches` pid = packageNameString pc == pid -- find which package corresponds to each wired-in package -- delete any other packages with the same name -- update the package and any dependencies to point to the new -- one. -- -- When choosing which package to map to a wired-in package -- name, we try to pick the latest version of exposed packages. -- However, if there are no exposed wired in packages available -- (e.g. -hide-all-packages was used), we can't bail: we *have* -- to assign a package for the wired-in package: so we try again -- with hidden packages included to (and pick the latest -- version). -- -- You can also override the default choice by using -ignore-package: -- this works even when there is no exposed wired in package -- available. -- findWiredInPackage :: [PackageConfig] -> WiredInUnitId -> IO (Maybe (WiredInUnitId, PackageConfig)) findWiredInPackage pkgs wired_pkg = let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] all_exposed_ps = [ p | p <- all_ps , Map.member (packageConfigId p) vis_map ] in case all_exposed_ps of [] -> case all_ps of [] -> notfound many -> pick (head (sortByPreference prec_map many)) many -> pick (head (sortByPreference prec_map many)) where notfound = do debugTraceMsg dflags 2 $ text "wired-in package " <> text wired_pkg <> text " not found." return Nothing pick :: PackageConfig -> IO (Maybe (WiredInUnitId, PackageConfig)) pick pkg = do debugTraceMsg dflags 2 $ text "wired-in package " <> text wired_pkg <> text " mapped to " <> ppr (unitId pkg) return (Just (wired_pkg, pkg)) mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids let wired_in_pkgs = catMaybes mb_wired_in_pkgs -- this is old: we used to assume that if there were -- multiple versions of wired-in packages installed that -- they were mutually exclusive. Now we're assuming that -- you have one "main" version of each wired-in package -- (the latest version), and the others are backward-compat -- wrappers that depend on this one. e.g. base-4.0 is the -- latest, base-3.0 is a compat wrapper depending on base-4.0. {- deleteOtherWiredInPackages pkgs = filterOut bad pkgs where bad p = any (p `matches`) wired_in_pkgids && package p `notElem` map fst wired_in_ids -} wiredInMap :: Map WiredUnitId WiredUnitId wiredInMap = Map.fromList [ (key, DefUnitId (stringToInstalledUnitId wiredInUnitId)) | (wiredInUnitId, pkg) <- wired_in_pkgs , Just key <- pure $ definitePackageConfigId pkg ] updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs where upd_pkg pkg | Just def_uid <- definitePackageConfigId pkg , Just wiredInUnitId <- Map.lookup def_uid wiredInMap = let fs = installedUnitIdFS (unDefUnitId wiredInUnitId) in pkg { unitId = fsToInstalledUnitId fs, componentId = ComponentId fs } | otherwise = pkg upd_deps pkg = pkg { -- temporary harmless DefUnitId invariant violation depends = map (unDefUnitId . upd_wired_in wiredInMap . DefUnitId) (depends pkg), exposedModules = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) (exposedModules pkg) } return (updateWiredInDependencies pkgs, wiredInMap) -- Helper functions for rewiring Module and UnitId. These -- rewrite UnitIds of modules in wired-in packages to the form known to the -- compiler, as described in Note [Wired-in packages] in Module. -- -- For instance, base-4.9.0.0 will be rewritten to just base, to match -- what appears in PrelNames. upd_wired_in_mod :: WiredPackagesMap -> Module -> Module upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m upd_wired_in_uid :: WiredPackagesMap -> UnitId -> UnitId upd_wired_in_uid wiredInMap (DefiniteUnitId def_uid) = DefiniteUnitId (upd_wired_in wiredInMap def_uid) upd_wired_in_uid wiredInMap (IndefiniteUnitId indef_uid) = IndefiniteUnitId $ newIndefUnitId (indefUnitIdComponentId indef_uid) (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (indefUnitIdInsts indef_uid)) upd_wired_in :: WiredPackagesMap -> DefUnitId -> DefUnitId upd_wired_in wiredInMap key | Just key' <- Map.lookup key wiredInMap = key' | otherwise = key updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap) where f vm (from, to) = case Map.lookup (DefiniteUnitId from) vis_map of Nothing -> vm Just r -> Map.insert (DefiniteUnitId to) r (Map.delete (DefiniteUnitId from) vm) -- ---------------------------------------------------------------------------- -- | The reason why a package is unusable. data UnusablePackageReason = -- | We ignored it explicitly using @-ignore-package@. IgnoredWithFlag -- | This package transitively depends on a package that was never present -- in any of the provided databases. | BrokenDependencies [InstalledUnitId] -- | This package transitively depends on a package involved in a cycle. -- Note that the list of 'InstalledUnitId' reports the direct dependencies -- of this package that (transitively) depended on the cycle, and not -- the actual cycle itself (which we report separately at high verbosity.) | CyclicDependencies [InstalledUnitId] -- | This package transitively depends on a package which was ignored. | IgnoredDependencies [InstalledUnitId] -- | This package transitively depends on a package which was -- shadowed by an ABI-incompatible package. | ShadowedDependencies [InstalledUnitId] instance Outputable UnusablePackageReason where ppr IgnoredWithFlag = text "[ignored with flag]" ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) type UnusablePackages = Map InstalledUnitId (PackageConfig, UnusablePackageReason) pprReason :: SDoc -> UnusablePackageReason -> SDoc pprReason pref reason = case reason of IgnoredWithFlag -> pref <+> text "ignored due to an -ignore-package flag" BrokenDependencies deps -> pref <+> text "unusable due to missing dependencies:" $$ nest 2 (hsep (map ppr deps)) CyclicDependencies deps -> pref <+> text "unusable due to cyclic dependencies:" $$ nest 2 (hsep (map ppr deps)) IgnoredDependencies deps -> pref <+> text ("unusable because the -ignore-package flag was used to " ++ "ignore at least one of its dependencies:") $$ nest 2 (hsep (map ppr deps)) ShadowedDependencies deps -> pref <+> text "unusable due to shadowed dependencies:" $$ nest 2 (hsep (map ppr deps)) reportCycles :: DynFlags -> [SCC PackageConfig] -> IO () reportCycles dflags sccs = mapM_ report sccs where report (AcyclicSCC _) = return () report (CyclicSCC vs) = debugTraceMsg dflags 2 $ text "these packages are involved in a cycle:" $$ nest 2 (hsep (map (ppr . unitId) vs)) reportUnusable :: DynFlags -> UnusablePackages -> IO () reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) where report (ipid, (_, reason)) = debugTraceMsg dflags 2 $ pprReason (text "package" <+> ppr ipid <+> text "is") reason -- ---------------------------------------------------------------------------- -- -- Utilities on the database -- -- | A reverse dependency index, mapping an 'InstalledUnitId' to -- the 'InstalledUnitId's which have a dependency on it. type RevIndex = Map InstalledUnitId [InstalledUnitId] -- | Compute the reverse dependency index of a package database. reverseDeps :: InstalledPackageIndex -> RevIndex reverseDeps db = Map.foldl' go Map.empty db where go r pkg = foldl' (go' (unitId pkg)) r (depends pkg) go' from r to = Map.insertWith (++) to [from] r -- | Given a list of 'InstalledUnitId's to remove, a database, -- and a reverse dependency index (as computed by 'reverseDeps'), -- remove those packages, plus any packages which depend on them. -- Returns the pruned database, as well as a list of 'PackageConfig's -- that was removed. removePackages :: [InstalledUnitId] -> RevIndex -> InstalledPackageIndex -> (InstalledPackageIndex, [PackageConfig]) removePackages uids index m = go uids (m,[]) where go [] (m,pkgs) = (m,pkgs) go (uid:uids) (m,pkgs) | Just pkg <- Map.lookup uid m = case Map.lookup uid index of Nothing -> go uids (Map.delete uid m, pkg:pkgs) Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs) | otherwise = go uids (m,pkgs) -- | Given a 'PackageConfig' from some 'InstalledPackageIndex', -- return all entries in 'depends' which correspond to packages -- that do not exist in the index. depsNotAvailable :: InstalledPackageIndex -> PackageConfig -> [InstalledUnitId] depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (depends pkg) -- | Given a 'PackageConfig' from some 'InstalledPackageIndex' -- return all entries in 'abiDepends' which correspond to packages -- that do not exist, OR have mismatching ABIs. depsAbiMismatch :: InstalledPackageIndex -> PackageConfig -> [InstalledUnitId] depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ abiDepends pkg where abiMatch (dep_uid, abi) | Just dep_pkg <- Map.lookup dep_uid pkg_map = abiHash dep_pkg == abi | otherwise = False -- ----------------------------------------------------------------------------- -- Ignore packages ignorePackages :: [IgnorePackageFlag] -> [PackageConfig] -> UnusablePackages ignorePackages flags pkgs = Map.fromList (concatMap doit flags) where doit (IgnorePackage str) = case partition (matchingStr str) pkgs of (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) | p <- ps ] -- missing package is not an error for -ignore-package, -- because a common usage is to -ignore-package P as -- a preventative measure just in case P exists. -- ---------------------------------------------------------------------------- -- -- Merging databases -- -- | For each package, a mapping from uid -> i indicates that this -- package was brought into GHC by the ith @-package-db@ flag on -- the command line. We use this mapping to make sure we prefer -- packages that were defined later on the command line, if there -- is an ambiguity. type PackagePrecedenceIndex = Map InstalledUnitId Int -- | Given a list of databases, merge them together, where -- packages with the same unit id in later databases override -- earlier ones. This does NOT check if the resulting database -- makes sense (that's done by 'validateDatabase'). mergeDatabases :: DynFlags -> [(FilePath, [PackageConfig])] -> IO (InstalledPackageIndex, PackagePrecedenceIndex) mergeDatabases dflags = foldM merge (Map.empty, Map.empty) . zip [1..] where merge (pkg_map, prec_map) (i, (db_path, db)) = do debugTraceMsg dflags 2 $ text "loading package database" <+> text db_path forM_ (Set.toList override_set) $ \pkg -> debugTraceMsg dflags 2 $ text "package" <+> ppr pkg <+> text "overrides a previously defined package" return (pkg_map', prec_map') where db_map = mk_pkg_map db mk_pkg_map = Map.fromList . map (\p -> (unitId p, p)) -- The set of UnitIds which appear in both db and pkgs. These are the -- ones that get overridden. Compute this just to give some -- helpful debug messages at -v2 override_set :: Set InstalledUnitId override_set = Set.intersection (Map.keysSet db_map) (Map.keysSet pkg_map) -- Now merge the sets together (NB: in case of duplicate, -- first argument preferred) pkg_map' :: InstalledPackageIndex pkg_map' = Map.union db_map pkg_map prec_map' :: PackagePrecedenceIndex prec_map' = Map.union (Map.map (const i) db_map) prec_map -- | Validates a database, removing unusable packages from it -- (this includes removing packages that the user has explicitly -- ignored.) Our general strategy: -- -- 1. Remove all broken packages (dangling dependencies) -- 2. Remove all packages that are cyclic -- 3. Apply ignore flags -- 4. Remove all packages which have deps with mismatching ABIs -- validateDatabase :: DynFlags -> InstalledPackageIndex -> (InstalledPackageIndex, UnusablePackages, [SCC PackageConfig]) validateDatabase dflags pkg_map1 = (pkg_map5, unusable, sccs) where ignore_flags = reverse (ignorePackageFlags dflags) -- Compute the reverse dependency index index = reverseDeps pkg_map1 -- Helper function mk_unusable mk_err dep_matcher m uids = Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) | pkg <- uids ] -- Find broken packages directly_broken = filter (not . null . depsNotAvailable pkg_map1) (Map.elems pkg_map1) (pkg_map2, broken) = removePackages (map unitId directly_broken) index pkg_map1 unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken -- Find recursive packages sccs = stronglyConnComp [ (pkg, unitId pkg, depends pkg) | pkg <- Map.elems pkg_map2 ] getCyclicSCC (CyclicSCC vs) = map unitId vs getCyclicSCC (AcyclicSCC _) = [] (pkg_map3, cyclic) = removePackages (concatMap getCyclicSCC sccs) index pkg_map2 unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic -- Apply ignore flags directly_ignored = ignorePackages ignore_flags (Map.elems pkg_map3) (pkg_map4, ignored) = removePackages (Map.keys directly_ignored) index pkg_map3 unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored -- Knock out packages whose dependencies don't agree with ABI -- (i.e., got invalidated due to shadowing) directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) (Map.elems pkg_map4) (pkg_map5, shadowed) = removePackages (map unitId directly_shadowed) index pkg_map4 unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed unusable = directly_ignored `Map.union` unusable_ignored `Map.union` unusable_broken `Map.union` unusable_cyclic `Map.union` unusable_shadowed -- ----------------------------------------------------------------------------- -- When all the command-line options are in, we can process our package -- settings and populate the package state. mkPackageState :: DynFlags -- initial databases, in the order they were specified on -- the command line (later databases shadow earlier ones) -> [(FilePath, [PackageConfig])] -> [PreloadUnitId] -- preloaded packages -> IO (PackageState, [PreloadUnitId], -- new packages to preload Maybe [(ModuleName, Module)]) mkPackageState dflags dbs preload0 = do {- Plan. There are two main steps for making the package state: 1. We want to build a single, unified package database based on all of the input databases, which upholds the invariant that there is only one package per any UnitId and there are no dangling dependencies. We'll do this by merging, and then successively filtering out bad dependencies. a) Merge all the databases together. If an input database defines unit ID that is already in the unified database, that package SHADOWS the existing package in the current unified database. Note that order is important: packages defined later in the list of command line arguments shadow those defined earlier. b) Remove all packages with missing dependencies, or mutually recursive dependencies. b) Remove packages selected by -ignore-package from input database c) Remove all packages which depended on packages that are now shadowed by an ABI-incompatible package d) report (with -v) any packages that were removed by steps 1-3 2. We want to look at the flags controlling package visibility, and build a mapping of what module names are in scope and where they live. a) on the final, unified database, we apply -trust/-distrust flags directly, modifying the database so that the 'trusted' field has the correct value. b) we use the -package/-hide-package flags to compute a visibility map, stating what packages are "exposed" for the purposes of computing the module map. * if any flag refers to a package which was removed by 1-5, then we can give an error message explaining why * if -hide-all-packages what not specified, this step also hides packages which are superseded by later exposed packages * this step is done TWICE if -plugin-package/-hide-all-plugin-packages are used c) based on the visibility map, we pick wired packages and rewrite them to have the expected unitId. d) finally, using the visibility map and the package database, we build a mapping saying what every in scope module name points to. -} -- This, and the other reverse's that you will see, are due to the face that -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order -- than they are on the command line. let other_flags = reverse (packageFlags dflags) debugTraceMsg dflags 2 $ text "package flags" <+> ppr other_flags -- Merge databases together, without checking validity (pkg_map1, prec_map) <- mergeDatabases dflags dbs -- Now that we've merged everything together, prune out unusable -- packages. let (pkg_map2, unusable, sccs) = validateDatabase dflags pkg_map1 reportCycles dflags sccs reportUnusable dflags unusable -- Apply trust flags (these flags apply regardless of whether -- or not packages are visible or not) pkgs1 <- foldM (applyTrustFlag dflags prec_map unusable) (Map.elems pkg_map2) (reverse (trustFlags dflags)) let prelim_pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs1 -- -- Calculate the initial set of units from package databases, prior to any package flags. -- -- Conceptually, we select the latest versions of all valid (not unusable) *packages* -- (not units). This is empty if we have -hide-all-packages. -- -- Then we create an initial visibility map with default visibilities for all -- exposed, definite units which belong to the latest valid packages. -- let preferLater unit unit' = case compareByPreference prec_map unit unit' of GT -> unit _ -> unit' addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit -- This is the set of maximally preferable packages. In fact, it is a set of -- most preferable *units* keyed by package name, which act as stand-ins in -- for "a package in a database". We use units here because we don't have -- "a package in a database" as a type currently. mostPreferablePackageReps = if gopt Opt_HideAllPackages dflags then emptyUDFM else foldl' addIfMorePreferable emptyUDFM pkgs1 -- When exposing units, we want to consider all of those in the most preferable -- packages. We can implement that by looking for units that are equi-preferable -- with the most preferable unit for package. Being equi-preferable means that -- they must be in the same database, with the same version, and the same pacakge name. -- -- We must take care to consider all these units and not just the most -- preferable one, otherwise we can end up with problems like #16228. mostPreferable u = case lookupUDFM mostPreferablePackageReps (fsPackageName u) of Nothing -> False Just u' -> compareByPreference prec_map u u' == EQ vis_map1 = foldl' (\vm p -> -- Note: we NEVER expose indefinite packages by -- default, because it's almost assuredly not -- what you want (no mix-in linking has occurred). if exposed p && unitIdIsDefinite (packageConfigId p) && mostPreferable p then Map.insert (packageConfigId p) UnitVisibility { uv_expose_all = True, uv_renamings = [], uv_package_name = First (Just (fsPackageName p)), uv_requirements = Map.empty, uv_explicit = False } vm else vm) Map.empty pkgs1 -- -- Compute a visibility map according to the command-line flags (-package, -- -hide-package). This needs to know about the unusable packages, since if a -- user tries to enable an unusable package, we should let them know. -- vis_map2 <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable (gopt Opt_HideAllPackages dflags) pkgs1) vis_map1 other_flags -- -- Sort out which packages are wired in. This has to be done last, since -- it modifies the unit ids of wired in packages, but when we process -- package arguments we need to key against the old versions. -- (pkgs2, wired_map) <- findWiredInPackages dflags prec_map pkgs1 vis_map2 let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2 -- Update the visibility map, so we treat wired packages as visible. let vis_map = updateVisibilityMap wired_map vis_map2 let hide_plugin_pkgs = gopt Opt_HideAllPluginPackages dflags plugin_vis_map <- case pluginPackageFlags dflags of -- common case; try to share the old vis_map [] | not hide_plugin_pkgs -> return vis_map | otherwise -> return Map.empty _ -> do let plugin_vis_map1 | hide_plugin_pkgs = Map.empty -- Use the vis_map PRIOR to wired in, -- because otherwise applyPackageFlag -- won't work. | otherwise = vis_map2 plugin_vis_map2 <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable (gopt Opt_HideAllPluginPackages dflags) pkgs1) plugin_vis_map1 (reverse (pluginPackageFlags dflags)) -- Updating based on wired in packages is mostly -- good hygiene, because it won't matter: no wired in -- package has a compiler plugin. -- TODO: If a wired in package had a compiler plugin, -- and you tried to pick different wired in packages -- with the plugin flags and the normal flags... what -- would happen? I don't know! But this doesn't seem -- likely to actually happen. return (updateVisibilityMap wired_map plugin_vis_map2) -- -- Here we build up a set of the packages mentioned in -package -- flags on the command line; these are called the "preload" -- packages. we link these packages in eagerly. The preload set -- should contain at least rts & base, which is why we pretend that -- the command line contains -package rts & -package base. -- -- NB: preload IS important even for type-checking, because we -- need the correct include path to be set. -- let preload1 = Map.keys (Map.filter uv_explicit vis_map) let pkgname_map = foldl' add Map.empty pkgs2 where add pn_map p = Map.insert (packageName p) (componentId p) pn_map -- The explicitPackages accurately reflects the set of packages we have turned -- on; as such, it also is the only way one can come up with requirements. -- The requirement context is directly based off of this: we simply -- look for nested unit IDs that are directly fed holes: the requirements -- of those units are precisely the ones we need to track let explicit_pkgs = Map.keys vis_map req_ctx = Map.map (Set.toList) $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map)) let preload2 = preload1 let -- add base & rts to the preload packages basicLinkedPackages | gopt Opt_AutoLinkPackages dflags = filter (flip elemUDFM (unPackageConfigMap pkg_db)) [baseUnitId, rtsUnitId] | otherwise = [] -- but in any case remove the current package from the set of -- preloaded packages so that base/rts does not end up in the -- set up preloaded package when we are just building it -- (NB: since this is only relevant for base/rts it doesn't matter -- that thisUnitIdInsts_ is not wired yet) -- preload3 = ordNub $ filter (/= thisPackage dflags) $ (basicLinkedPackages ++ preload2) -- Close the preload packages with their dependencies dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload let mod_map1 = mkModuleToPkgConfAll dflags pkg_db vis_map mod_map2 = mkUnusableModuleToPkgConfAll unusable mod_map = Map.union mod_map1 mod_map2 dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Mod Map" (pprModuleMap mod_map) -- Force pstate to avoid leaking the dflags0 passed to mkPackageState let !pstate = PackageState{ preloadPackages = dep_preload, explicitPackages = explicit_pkgs, pkgIdMap = pkg_db, moduleToPkgConfAll = mod_map, pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map, packageNameMap = pkgname_map, unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ], requirementContext = req_ctx } let new_insts = fmap (map (fmap (upd_wired_in_mod wired_map))) (thisUnitIdInsts_ dflags) return (pstate, new_dep_preload, new_insts) -- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId' -- that it was recorded as in the package database. unwireUnitId :: DynFlags -> UnitId -> UnitId unwireUnitId dflags uid@(DefiniteUnitId def_uid) = maybe uid DefiniteUnitId (Map.lookup def_uid (unwireMap (pkgState dflags))) unwireUnitId _ uid = uid -- ----------------------------------------------------------------------------- -- | Makes the mapping from module to package info -- Slight irritation: we proceed by leafing through everything -- in the installed package database, which makes handling indefinite -- packages a bit bothersome. mkModuleToPkgConfAll :: DynFlags -> PackageConfigMap -> VisibilityMap -> ModuleToPkgConfAll mkModuleToPkgConfAll dflags pkg_db vis_map = -- What should we fold on? Both situations are awkward: -- -- * Folding on the visibility map means that we won't create -- entries for packages that aren't mentioned in vis_map -- (e.g., hidden packages, causing #14717) -- -- * Folding on pkg_db is awkward because if we have an -- Backpack instantiation, we need to possibly add a -- package from pkg_db multiple times to the actual -- ModuleToPkgConfAll. Also, we don't really want -- definite package instantiations to show up in the -- list of possibilities. -- -- So what will we do instead? We'll extend vis_map with -- entries for every definite (for non-Backpack) and -- indefinite (for Backpack) package, so that we get the -- hidden entries we need. Map.foldlWithKey extend_modmap emptyMap vis_map_extended where vis_map_extended = Map.union vis_map {- preferred -} default_vis default_vis = Map.fromList [ (packageConfigId pkg, mempty) | pkg <- eltsUDFM (unPackageConfigMap pkg_db) -- Exclude specific instantiations of an indefinite -- package , indefinite pkg || null (instantiatedWith pkg) ] emptyMap = Map.empty setOrigins m os = fmap (const os) m extend_modmap modmap uid UnitVisibility { uv_expose_all = b, uv_renamings = rns } = addListTo modmap theBindings where pkg = pkg_lookup uid theBindings :: [(ModuleName, Map Module ModuleOrigin)] theBindings = newBindings b rns newBindings :: Bool -> [(ModuleName, ModuleName)] -> [(ModuleName, Map Module ModuleOrigin)] newBindings e rns = es e ++ hiddens ++ map rnBinding rns rnBinding :: (ModuleName, ModuleName) -> (ModuleName, Map Module ModuleOrigin) rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) where origEntry = case lookupUFM esmap orig of Just r -> r Nothing -> throwGhcException (CmdLineError (showSDoc dflags (text "package flag: could not find module name" <+> ppr orig <+> text "in package" <+> ppr pk))) es :: Bool -> [(ModuleName, Map Module ModuleOrigin)] es e = do (m, exposedReexport) <- exposed_mods let (pk', m', origin') = case exposedReexport of Nothing -> (pk, m, fromExposedModules e) Just (Module pk' m') -> let pkg' = pkg_lookup pk' in (pk', m', fromReexportedModules e pkg') return (m, mkModMap pk' m' origin') esmap :: UniqFM (Map Module ModuleOrigin) esmap = listToUFM (es False) -- parameter here doesn't matter, orig will -- be overwritten hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] pk = packageConfigId pkg pkg_lookup uid = lookupPackage' (isIndefinite dflags) pkg_db uid `orElse` pprPanic "pkg_lookup" (ppr uid) exposed_mods = exposedModules pkg hidden_mods = hiddenModules pkg -- | Make a 'ModuleToPkgConfAll' covering a set of unusable packages. mkUnusableModuleToPkgConfAll :: UnusablePackages -> ModuleToPkgConfAll mkUnusableModuleToPkgConfAll unusables = Map.foldl' extend_modmap Map.empty unusables where extend_modmap modmap (pkg, reason) = addListTo modmap bindings where bindings :: [(ModuleName, Map Module ModuleOrigin)] bindings = exposed ++ hidden origin = ModUnusable reason pkg_id = packageConfigId pkg exposed = map get_exposed exposed_mods hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods] get_exposed (mod, Just mod') = (mod, Map.singleton mod' origin) get_exposed (mod, _) = (mod, mkModMap pkg_id mod origin) exposed_mods = exposedModules pkg hidden_mods = hiddenModules pkg -- | Add a list of key/value pairs to a nested map. -- -- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks -- when reloading modules in GHCi (see #4029). This ensures that each -- value is forced before installing into the map. addListTo :: (Monoid a, Ord k1, Ord k2) => Map k1 (Map k2 a) -> [(k1, Map k2 a)] -> Map k1 (Map k2 a) addListTo = foldl' merge where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m -- | Create a singleton module mapping mkModMap :: UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin mkModMap pkg mod = Map.singleton (mkModule pkg mod) -- ----------------------------------------------------------------------------- -- Extracting information from the packages in scope -- Many of these functions take a list of packages: in those cases, -- the list is expected to contain the "dependent packages", -- i.e. those packages that were found to be depended on by the -- current module/program. These can be auto or non-auto packages, it -- doesn't really matter. The list is always combined with the list -- of preload (command-line) packages to determine which packages to -- use. -- | Find all the include directories in these and the preload packages getPackageIncludePath :: DynFlags -> [PreloadUnitId] -> IO [String] getPackageIncludePath dflags pkgs = collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs collectIncludeDirs :: [PackageConfig] -> [FilePath] collectIncludeDirs ps = ordNub (filter notNull (concatMap includeDirs ps)) -- | Find all the library paths in these and the preload packages getPackageLibraryPath :: DynFlags -> [PreloadUnitId] -> IO [String] getPackageLibraryPath dflags pkgs = collectLibraryPaths dflags `fmap` getPreloadPackagesAnd dflags pkgs collectLibraryPaths :: DynFlags -> [PackageConfig] -> [FilePath] collectLibraryPaths dflags = ordNub . filter notNull . concatMap (libraryDirsForWay dflags) -- | Find all the link options in these and the preload packages, -- returning (package hs lib options, extra library options, other flags) getPackageLinkOpts :: DynFlags -> [PreloadUnitId] -> IO ([String], [String], [String]) getPackageLinkOpts dflags pkgs = collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String]) collectLinkOpts dflags ps = ( concatMap (map ("-l" ++) . packageHsLibs dflags) ps, concatMap (map ("-l" ++) . extraLibraries) ps, concatMap ldOptions ps ) collectArchives :: DynFlags -> PackageConfig -> IO [FilePath] collectArchives dflags pc = filterM doesFileExist [ searchPath ("lib" ++ lib ++ ".a") | searchPath <- searchPaths , lib <- libs ] where searchPaths = ordNub . filter notNull . libraryDirsForWay dflags $ pc libs = packageHsLibs dflags pc ++ extraLibraries pc getLibs :: DynFlags -> [PreloadUnitId] -> IO [(String,String)] getLibs dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs fmap concat . forM ps $ \p -> do let candidates = [ (l f, f) | l <- collectLibraryPaths dflags [p] , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ] filterM (doesFileExist . fst) candidates packageHsLibs :: DynFlags -> PackageConfig -> [String] packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) where ways0 = ways dflags ways1 = filter (/= WayDyn) ways0 -- the name of a shared library is libHSfoo-ghc.so -- we leave out the _dyn, because it is superfluous -- debug and profiled RTSs include support for -eventlog ways2 | WayDebug `elem` ways1 || WayProf `elem` ways1 = filter (/= WayEventLog) ways1 | otherwise = ways1 tag = mkBuildTag (filter (not . wayRTSOnly) ways2) rts_tag = mkBuildTag ways2 mkDynName x | WayDyn `notElem` ways dflags = x | "HS" `isPrefixOf` x = x ++ '-':programName dflags ++ projectVersion dflags -- For non-Haskell libraries, we use the name "Cfoo". The .a -- file is libCfoo.a, and the .so is libfoo.so. That way the -- linker knows what we mean for the vanilla (-lCfoo) and dyn -- (-lfoo) ways. We therefore need to strip the 'C' off here. | Just x' <- stripPrefix "C" x = x' | otherwise = panic ("Don't understand library name " ++ x) -- Add _thr and other rts suffixes to packages named -- `rts` or `rts-1.0`. Why both? Traditionally the rts -- package is called `rts` only. However the tooling -- usually expects a package name to have a version. -- As such we will gradually move towards the `rts-1.0` -- package name, at which point the `rts` package name -- will eventually be unused. -- -- This change elevates the need to add custom hooks -- and handling specifically for the `rts` package for -- example in ghc-cabal. addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) addSuffix rts@"HSrts-1.0"= rts ++ (expandTag rts_tag) addSuffix other_lib = other_lib ++ (expandTag tag) expandTag t | null t = "" | otherwise = '_':t -- | Either the 'libraryDirs' or 'libraryDynDirs' as appropriate for the way. libraryDirsForWay :: DynFlags -> PackageConfig -> [String] libraryDirsForWay dflags | WayDyn `elem` ways dflags = libraryDynDirs | otherwise = libraryDirs -- | Find all the C-compiler options in these and the preload packages getPackageExtraCcOpts :: DynFlags -> [PreloadUnitId] -> IO [String] getPackageExtraCcOpts dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (concatMap ccOptions ps) -- | Find all the package framework paths in these and the preload packages getPackageFrameworkPath :: DynFlags -> [PreloadUnitId] -> IO [String] getPackageFrameworkPath dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (ordNub (filter notNull (concatMap frameworkDirs ps))) -- | Find all the package frameworks in these and the preload packages getPackageFrameworks :: DynFlags -> [PreloadUnitId] -> IO [String] getPackageFrameworks dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (concatMap frameworks ps) -- ----------------------------------------------------------------------------- -- Package Utils -- | Takes a 'ModuleName', and if the module is in any package returns -- list of modules which take that name. lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(Module, PackageConfig)] lookupModuleInAllPackages dflags m = case lookupModuleWithSuggestions dflags m Nothing of LookupFound a b -> [(a,b)] LookupMultiple rs -> map f rs where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags (moduleUnitId m))) _ -> [] -- | The result of performing a lookup data LookupResult = -- | Found the module uniquely, nothing else to do LookupFound Module PackageConfig -- | Multiple modules with the same name in scope | LookupMultiple [(Module, ModuleOrigin)] -- | No modules found, but there were some hidden ones with -- an exact name match. First is due to package hidden, second -- is due to module being hidden | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)] -- | No modules found, but there were some unusable ones with -- an exact name match | LookupUnusable [(Module, ModuleOrigin)] -- | Nothing found, here are some suggested different names | LookupNotFound [ModuleSuggestion] -- suggestions data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin | SuggestHidden ModuleName Module ModuleOrigin lookupModuleWithSuggestions :: DynFlags -> ModuleName -> Maybe FastString -> LookupResult lookupModuleWithSuggestions dflags = lookupModuleWithSuggestions' dflags (moduleToPkgConfAll (pkgState dflags)) lookupPluginModuleWithSuggestions :: DynFlags -> ModuleName -> Maybe FastString -> LookupResult lookupPluginModuleWithSuggestions dflags = lookupModuleWithSuggestions' dflags (pluginModuleToPkgConfAll (pkgState dflags)) lookupModuleWithSuggestions' :: DynFlags -> ModuleToPkgConfAll -> ModuleName -> Maybe FastString -> LookupResult lookupModuleWithSuggestions' dflags mod_map m mb_pn = case Map.lookup m mod_map of Nothing -> LookupNotFound suggestions Just xs -> case foldl' classify ([],[],[], []) (Map.toList xs) of ([], [], [], []) -> LookupNotFound suggestions (_, _, _, [(m, _)]) -> LookupFound m (mod_pkg m) (_, _, _, exposed@(_:_)) -> LookupMultiple exposed ([], [], unusable@(_:_), []) -> LookupUnusable unusable (hidden_pkg, hidden_mod, _, []) -> LookupHidden hidden_pkg hidden_mod where classify (hidden_pkg, hidden_mod, unusable, exposed) (m, origin0) = let origin = filterOrigin mb_pn (mod_pkg m) origin0 x = (m, origin) in case origin of ModHidden -> (hidden_pkg, x:hidden_mod, unusable, exposed) ModUnusable _ -> (hidden_pkg, hidden_mod, x:unusable, exposed) _ | originEmpty origin -> (hidden_pkg, hidden_mod, unusable, exposed) | originVisible origin -> (hidden_pkg, hidden_mod, unusable, x:exposed) | otherwise -> (x:hidden_pkg, hidden_mod, unusable, exposed) pkg_lookup p = lookupPackage dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m) mod_pkg = pkg_lookup . moduleUnitId -- Filters out origins which are not associated with the given package -- qualifier. No-op if there is no package qualifier. Test if this -- excluded all origins with 'originEmpty'. filterOrigin :: Maybe FastString -> PackageConfig -> ModuleOrigin -> ModuleOrigin filterOrigin Nothing _ o = o filterOrigin (Just pn) pkg o = case o of ModHidden -> if go pkg then ModHidden else mempty (ModUnusable _) -> if go pkg then o else mempty ModOrigin { fromOrigPackage = e, fromExposedReexport = res, fromHiddenReexport = rhs } -> ModOrigin { fromOrigPackage = if go pkg then e else Nothing , fromExposedReexport = filter go res , fromHiddenReexport = filter go rhs , fromPackageFlag = False -- always excluded } where go pkg = pn == fsPackageName pkg suggestions | gopt Opt_HelpfulErrors dflags = fuzzyLookup (moduleNameString m) all_mods | otherwise = [] all_mods :: [(String, ModuleSuggestion)] -- All modules all_mods = sortBy (comparing fst) $ [ (moduleNameString m, suggestion) | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags)) , suggestion <- map (getSuggestion m) (Map.toList e) ] getSuggestion name (mod, origin) = (if originVisible origin then SuggestVisible else SuggestHidden) name mod origin listVisibleModuleNames :: DynFlags -> [ModuleName] listVisibleModuleNames dflags = map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags)))) where visible (_, ms) = any originVisible (Map.elems ms) -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of -- 'PackageConfig's getPreloadPackagesAnd :: DynFlags -> [PreloadUnitId] -> IO [PackageConfig] getPreloadPackagesAnd dflags pkgids0 = let pkgids = pkgids0 ++ -- An indefinite package will have insts to HOLE, -- which is not a real package. Don't look it up. -- Fixes #14525 if isIndefinite dflags then [] else map (toInstalledUnitId . moduleUnitId . snd) (thisUnitIdInsts dflags) state = pkgState dflags pkg_map = pkgIdMap state preload = preloadPackages state pairs = zip pkgids (repeat Nothing) in do all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs) return (map (getInstalledPackageDetails dflags) all_pkgs) -- Takes a list of packages, and returns the list with dependencies included, -- in reverse dependency order (a package appears before those it depends on). closeDeps :: DynFlags -> PackageConfigMap -> [(InstalledUnitId, Maybe InstalledUnitId)] -> IO [InstalledUnitId] closeDeps dflags pkg_map ps = throwErr dflags (closeDepsErr dflags pkg_map ps) throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a throwErr dflags m = case m of Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e)) Succeeded r -> return r closeDepsErr :: DynFlags -> PackageConfigMap -> [(InstalledUnitId,Maybe InstalledUnitId)] -> MaybeErr MsgDoc [InstalledUnitId] closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps -- internal helper add_package :: DynFlags -> PackageConfigMap -> [PreloadUnitId] -> (PreloadUnitId,Maybe PreloadUnitId) -> MaybeErr MsgDoc [PreloadUnitId] add_package dflags pkg_db ps (p, mb_parent) | p `elem` ps = return ps -- Check if we've already added this package | otherwise = case lookupInstalledPackage' pkg_db p of Nothing -> Failed (missingPackageMsg p <> missingDependencyMsg mb_parent) Just pkg -> do -- Add the package's dependents also ps' <- foldM add_unit_key ps (depends pkg) return (p : ps') where add_unit_key ps key = add_package dflags pkg_db ps (key, Just p) missingPackageMsg :: Outputable pkgid => pkgid -> SDoc missingPackageMsg p = text "unknown package:" <+> ppr p missingDependencyMsg :: Maybe InstalledUnitId -> SDoc missingDependencyMsg Nothing = Outputable.empty missingDependencyMsg (Just parent) = space <> parens (text "dependency of" <+> ftext (installedUnitIdFS parent)) -- ----------------------------------------------------------------------------- componentIdString :: DynFlags -> ComponentId -> Maybe String componentIdString dflags cid = do conf <- lookupInstalledPackage dflags (componentIdToInstalledUnitId cid) return $ case sourceLibName conf of Nothing -> sourcePackageIdString conf Just (PackageName libname) -> packageNameString conf ++ "-" ++ showVersion (packageVersion conf) ++ ":" ++ unpackFS libname displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String displayInstalledUnitId dflags uid = fmap sourcePackageIdString (lookupInstalledPackage dflags uid) -- | Will the 'Name' come from a dynamically linked library? isDllName :: DynFlags -> Module -> Name -> Bool -- Despite the "dll", I think this function just means that -- the symbol comes from another dynamically-linked package, -- and applies on all platforms, not just Windows isDllName dflags this_mod name | not (gopt Opt_ExternalDynamicRefs dflags) = False | Just mod <- nameModule_maybe name -- Issue #8696 - when GHC is dynamically linked, it will attempt -- to load the dynamic dependencies of object files at compile -- time for things like QuasiQuotes or -- TemplateHaskell. Unfortunately, this interacts badly with -- intra-package linking, because we don't generate indirect -- (dynamic) symbols for intra-package calls. This means that if a -- module with an intra-package call is loaded without its -- dependencies, then GHC fails to link. This is the cause of # -- -- In the mean time, always force dynamic indirections to be -- generated: when the module name isn't the module being -- compiled, references are dynamic. = case platformOS $ targetPlatform dflags of -- On Windows the hack for #8696 makes it unlinkable. -- As the entire setup of the code from Cmm down to the RTS expects -- the use of trampolines for the imported functions only when -- doing intra-package linking, e.g. refering to a symbol defined in the same -- package should not use a trampoline. -- I much rather have dynamic TH not supported than the entire Dynamic linking -- not due to a hack. -- Also not sure this would break on Windows anyway. OSMinGW32 -> moduleUnitId mod /= moduleUnitId this_mod -- For the other platforms, still perform the hack _ -> mod /= this_mod | otherwise = False -- no, it is not even an external name -- ----------------------------------------------------------------------------- -- Displaying packages -- | Show (very verbose) package info pprPackages :: DynFlags -> SDoc pprPackages = pprPackagesWith pprPackageConfig pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc pprPackagesWith pprIPI dflags = vcat (intersperse (text "---") (map pprIPI (listPackageConfigMap dflags))) -- | Show simplified package info. -- -- The idea is to only print package id, and any information that might -- be different from the package databases (exposure, trust) pprPackagesSimple :: DynFlags -> SDoc pprPackagesSimple = pprPackagesWith pprIPI where pprIPI ipi = let i = installedUnitIdFS (unitId ipi) e = if exposed ipi then text "E" else text " " t = if trusted ipi then text "T" else text " " in e <> t <> text " " <> ftext i -- | Show the mapping of modules to where they come from. pprModuleMap :: ModuleToPkgConfAll -> SDoc pprModuleMap mod_map = vcat (map pprLine (Map.toList mod_map)) where pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc pprEntry m (m',o) | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o) | otherwise = ppr m' <+> parens (ppr o) fsPackageName :: PackageConfig -> FastString fsPackageName = mkFastString . packageNameString -- | Given a fully instantiated 'UnitId', improve it into a -- 'InstalledUnitId' if we can find it in the package database. improveUnitId :: PackageConfigMap -> UnitId -> UnitId improveUnitId _ uid@(DefiniteUnitId _) = uid -- short circuit improveUnitId pkg_map uid = -- Do NOT lookup indefinite ones, they won't be useful! case lookupPackage' False pkg_map uid of Nothing -> uid Just pkg -> -- Do NOT improve if the indefinite unit id is not -- part of the closure unique set. See -- Note [UnitId to InstalledUnitId improvement] if installedPackageConfigId pkg `elementOfUniqSet` preloadClosure pkg_map then packageConfigId pkg else uid -- | Retrieve the 'PackageConfigMap' from 'DynFlags'; used -- in the @hs-boot@ loop-breaker. getPackageConfigMap :: DynFlags -> PackageConfigMap getPackageConfigMap = pkgIdMap . pkgState -- ----------------------------------------------------------------------------- -- | Find the package environment (if one exists) -- -- We interpret the package environment as a set of package flags; to be -- specific, if we find a package environment file like -- -- > clear-package-db -- > global-package-db -- > package-db blah/package.conf.d -- > package-id id1 -- > package-id id2 -- -- we interpret this as -- -- > [ -hide-all-packages -- > , -clear-package-db -- > , -global-package-db -- > , -package-db blah/package.conf.d -- > , -package-id id1 -- > , -package-id id2 -- > ] -- -- There's also an older syntax alias for package-id, which is just an -- unadorned package id -- -- > id1 -- > id2 -- interpretPackageEnv :: DynFlags -> IO DynFlags interpretPackageEnv dflags = do mPkgEnv <- runMaybeT $ msum $ [ getCmdLineArg >>= \env -> msum [ probeNullEnv env , probeEnvFile env , probeEnvName env , cmdLineError env ] , getEnvVar >>= \env -> msum [ probeNullEnv env , probeEnvFile env , probeEnvName env , envError env ] , notIfHideAllPackages >> msum [ findLocalEnvFile >>= probeEnvFile , probeEnvName defaultEnvName ] ] case mPkgEnv of Nothing -> -- No environment found. Leave DynFlags unchanged. return dflags Just "-" -> do -- Explicitly disabled environment file. Leave DynFlags unchanged. return dflags Just envfile -> do content <- readFile envfile compilationProgressMsg dflags ("Loaded package environment from " ++ envfile) let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags return dflags' where -- Loading environments (by name or by location) namedEnvPath :: String -> MaybeT IO FilePath namedEnvPath name = do appdir <- versionedAppDir dflags return $ appdir "environments" name probeEnvName :: String -> MaybeT IO FilePath probeEnvName name = probeEnvFile =<< namedEnvPath name probeEnvFile :: FilePath -> MaybeT IO FilePath probeEnvFile path = do guard =<< liftMaybeT (doesFileExist path) return path probeNullEnv :: FilePath -> MaybeT IO FilePath probeNullEnv "-" = return "-" probeNullEnv _ = mzero -- Various ways to define which environment to use getCmdLineArg :: MaybeT IO String getCmdLineArg = MaybeT $ return $ packageEnv dflags getEnvVar :: MaybeT IO String getEnvVar = do mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT" case mvar of Right var -> return var Left err -> if isDoesNotExistError err then mzero else liftMaybeT $ throwIO err notIfHideAllPackages :: MaybeT IO () notIfHideAllPackages = guard (not (gopt Opt_HideAllPackages dflags)) defaultEnvName :: String defaultEnvName = "default" -- e.g. .ghc.environment.x86_64-linux-7.6.3 localEnvFileName :: FilePath localEnvFileName = ".ghc.environment" <.> versionedFilePath dflags -- Search for an env file, starting in the current dir and looking upwards. -- Fail if we get to the users home dir or the filesystem root. That is, -- we don't look for an env file in the user's home dir. The user-wide -- env lives in ghc's versionedAppDir/environments/default findLocalEnvFile :: MaybeT IO FilePath findLocalEnvFile = do curdir <- liftMaybeT getCurrentDirectory homedir <- tryMaybeT getHomeDirectory let probe dir | isDrive dir || dir == homedir = mzero probe dir = do let file = dir localEnvFileName exists <- liftMaybeT (doesFileExist file) if exists then return file else probe (takeDirectory dir) probe curdir -- Error reporting cmdLineError :: String -> MaybeT IO a cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ "Package environment " ++ show env ++ " not found" envError :: String -> MaybeT IO a envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ "Package environment " ++ show env ++ " (specified in GHC_ENVIRONMENT) not found" ghc-lib-parser-8.10.2.20200808/compiler/utils/Pair.hs0000644000000000000000000000277713713635745017725 0ustar0000000000000000{- A simple homogeneous pair type with useful Functor, Applicative, and Traversable instances. -} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} module Pair ( Pair(..), unPair, toPair, swap, pLiftFst, pLiftSnd ) where #include "GhclibHsVersions.h" import GhcPrelude import Outputable import qualified Data.Semigroup as Semi data Pair a = Pair { pFst :: a, pSnd :: a } deriving (Functor) -- Note that Pair is a *unary* type constructor -- whereas (,) is binary -- The important thing about Pair is that it has a *homogeneous* -- Functor instance, so you can easily apply the same function -- to both components instance Applicative Pair where pure x = Pair x x (Pair f g) <*> (Pair x y) = Pair (f x) (g y) instance Foldable Pair where foldMap f (Pair x y) = f x `mappend` f y instance Traversable Pair where traverse f (Pair x y) = Pair <$> f x <*> f y instance Semi.Semigroup a => Semi.Semigroup (Pair a) where Pair a1 b1 <> Pair a2 b2 = Pair (a1 Semi.<> a2) (b1 Semi.<> b2) instance (Semi.Semigroup a, Monoid a) => Monoid (Pair a) where mempty = Pair mempty mempty mappend = (Semi.<>) instance Outputable a => Outputable (Pair a) where ppr (Pair a b) = ppr a <+> char '~' <+> ppr b unPair :: Pair a -> (a,a) unPair (Pair x y) = (x,y) toPair :: (a,a) -> Pair a toPair (x,y) = Pair x y swap :: Pair a -> Pair a swap (Pair x y) = Pair y x pLiftFst :: (a -> a) -> Pair a -> Pair a pLiftFst f (Pair a b) = Pair (f a) b pLiftSnd :: (a -> a) -> Pair a -> Pair a pLiftSnd f (Pair a b) = Pair a (f b) ghc-lib-parser-8.10.2.20200808/compiler/utils/Panic.hs0000644000000000000000000002212013713635745020044 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP Project, Glasgow University, 1992-2000 Defines basic functions for printing error messages. It's hard to put these functions anywhere else without causing some unnecessary loops in the module dependency graph. -} {-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-} module Panic ( GhcException(..), showGhcException, throwGhcException, throwGhcExceptionIO, handleGhcException, PlainPanic.progName, pgmError, panic, sorry, assertPanic, trace, panicDoc, sorryDoc, pgmErrorDoc, cmdLineError, cmdLineErrorIO, Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo, withSignalHandlers, ) where import GhcPrelude import {-# SOURCE #-} Outputable (SDoc, showSDocUnsafe) import PlainPanic import Exception import Control.Monad.IO.Class import Control.Concurrent import Data.Typeable ( cast ) import Debug.Trace ( trace ) import System.IO.Unsafe #if !defined(mingw32_HOST_OS) import System.Posix.Signals as S #endif #if defined(mingw32_HOST_OS) import GHC.ConsoleHandler as S #endif import System.Mem.Weak ( deRefWeak ) -- | GHC's own exception type -- error messages all take the form: -- -- @ -- : -- @ -- -- If the location is on the command line, or in GHC itself, then -- ="ghc". All of the error types below correspond to -- a of "ghc", except for ProgramError (where the string is -- assumed to contain a location already, so we don't print one). data GhcException -- | Some other fatal signal (SIGHUP,SIGTERM) = Signal Int -- | Prints the short usage msg after the error | UsageError String -- | A problem with the command line arguments, but don't print usage. | CmdLineError String -- | The 'impossible' happened. | Panic String | PprPanic String SDoc -- | The user tickled something that's known not to work yet, -- but we're not counting it as a bug. | Sorry String | PprSorry String SDoc -- | An installation problem. | InstallationError String -- | An error in the user's code, probably. | ProgramError String | PprProgramError String SDoc instance Exception GhcException where fromException (SomeException e) | Just ge <- cast e = Just ge | Just pge <- cast e = Just $ case pge of PlainSignal n -> Signal n PlainUsageError str -> UsageError str PlainCmdLineError str -> CmdLineError str PlainPanic str -> Panic str PlainSorry str -> Sorry str PlainInstallationError str -> InstallationError str PlainProgramError str -> ProgramError str | otherwise = Nothing instance Show GhcException where showsPrec _ e@(ProgramError _) = showGhcException e showsPrec _ e@(CmdLineError _) = showString ": " . showGhcException e showsPrec _ e = showString progName . showString ": " . showGhcException e -- | Show an exception as a string. showException :: Exception e => e -> String showException = show -- | Show an exception which can possibly throw other exceptions. -- Used when displaying exception thrown within TH code. safeShowException :: Exception e => e -> IO String safeShowException e = do -- ensure the whole error message is evaluated inside try r <- try (return $! forceList (showException e)) case r of Right msg -> return msg Left e' -> safeShowException (e' :: SomeException) where forceList [] = [] forceList xs@(x : xt) = x `seq` forceList xt `seq` xs -- | Append a description of the given exception to this string. -- -- Note that this uses 'DynFlags.unsafeGlobalDynFlags', which may have some -- uninitialized fields if invoked before 'GHC.initGhcMonad' has been called. -- If the error message to be printed includes a pretty-printer document -- which forces one of these fields this call may bottom. showGhcException :: GhcException -> ShowS showGhcException = showPlainGhcException . \case Signal n -> PlainSignal n UsageError str -> PlainUsageError str CmdLineError str -> PlainCmdLineError str Panic str -> PlainPanic str Sorry str -> PlainSorry str InstallationError str -> PlainInstallationError str ProgramError str -> PlainProgramError str PprPanic str sdoc -> PlainPanic $ concat [str, "\n\n", showSDocUnsafe sdoc] PprSorry str sdoc -> PlainProgramError $ concat [str, "\n\n", showSDocUnsafe sdoc] PprProgramError str sdoc -> PlainProgramError $ concat [str, "\n\n", showSDocUnsafe sdoc] throwGhcException :: GhcException -> a throwGhcException = Exception.throw throwGhcExceptionIO :: GhcException -> IO a throwGhcExceptionIO = Exception.throwIO handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a handleGhcException = ghandle panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a panicDoc x doc = throwGhcException (PprPanic x doc) sorryDoc x doc = throwGhcException (PprSorry x doc) pgmErrorDoc x doc = throwGhcException (PprProgramError x doc) -- | Like try, but pass through UserInterrupt and Panic exceptions. -- Used when we want soft failures when reading interface files, for example. -- TODO: I'm not entirely sure if this is catching what we really want to catch tryMost :: IO a -> IO (Either SomeException a) tryMost action = do r <- try action case r of Left se -> case fromException se of -- Some GhcException's we rethrow, Just (Signal _) -> throwIO se Just (Panic _) -> throwIO se -- others we return Just _ -> return (Left se) Nothing -> case fromException se of -- All IOExceptions are returned Just (_ :: IOException) -> return (Left se) -- Anything else is rethrown Nothing -> throwIO se Right v -> return (Right v) -- | We use reference counting for signal handlers {-# NOINLINE signalHandlersRefCount #-} #if !defined(mingw32_HOST_OS) signalHandlersRefCount :: MVar (Word, Maybe (S.Handler,S.Handler ,S.Handler,S.Handler)) #else signalHandlersRefCount :: MVar (Word, Maybe S.Handler) #endif signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing) -- | Temporarily install standard signal handlers for catching ^C, which just -- throw an exception in the current thread. withSignalHandlers :: (ExceptionMonad m, MonadIO m) => m a -> m a withSignalHandlers act = do main_thread <- liftIO myThreadId wtid <- liftIO (mkWeakThreadId main_thread) let interrupt = do r <- deRefWeak wtid case r of Nothing -> return () Just t -> throwTo t UserInterrupt #if !defined(mingw32_HOST_OS) let installHandlers = do let installHandler' a b = installHandler a b Nothing hdlQUIT <- installHandler' sigQUIT (Catch interrupt) hdlINT <- installHandler' sigINT (Catch interrupt) -- see #3656; in the future we should install these automatically for -- all Haskell programs in the same way that we install a ^C handler. let fatal_signal n = throwTo main_thread (Signal (fromIntegral n)) hdlHUP <- installHandler' sigHUP (Catch (fatal_signal sigHUP)) hdlTERM <- installHandler' sigTERM (Catch (fatal_signal sigTERM)) return (hdlQUIT,hdlINT,hdlHUP,hdlTERM) let uninstallHandlers (hdlQUIT,hdlINT,hdlHUP,hdlTERM) = do _ <- installHandler sigQUIT hdlQUIT Nothing _ <- installHandler sigINT hdlINT Nothing _ <- installHandler sigHUP hdlHUP Nothing _ <- installHandler sigTERM hdlTERM Nothing return () #else -- GHC 6.3+ has support for console events on Windows -- NOTE: running GHCi under a bash shell for some reason requires -- you to press Ctrl-Break rather than Ctrl-C to provoke -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know -- why --SDM 17/12/2004 let sig_handler ControlC = interrupt sig_handler Break = interrupt sig_handler _ = return () let installHandlers = installHandler (Catch sig_handler) let uninstallHandlers = installHandler -- directly install the old handler #endif -- install signal handlers if necessary let mayInstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case (0,Nothing) -> do hdls <- installHandlers return (1,Just hdls) (c,oldHandlers) -> return (c+1,oldHandlers) -- uninstall handlers if necessary let mayUninstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case (1,Just hdls) -> do _ <- uninstallHandlers hdls return (0,Nothing) (c,oldHandlers) -> return (c-1,oldHandlers) mayInstallHandlers act `gfinally` mayUninstallHandlers ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/PatSyn.hs0000644000000000000000000004121113713635744021177 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1998 \section[PatSyn]{@PatSyn@: Pattern synonyms} -} {-# LANGUAGE CPP #-} module PatSyn ( -- * Main data types PatSyn, mkPatSyn, -- ** Type deconstruction patSynName, patSynArity, patSynIsInfix, patSynArgs, patSynMatcher, patSynBuilder, patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig, patSynInstArgTys, patSynInstResTy, patSynFieldLabels, patSynFieldType, updatePatSynIds, pprPatSynType ) where #include "GhclibHsVersions.h" import GhcPrelude import Type import TyCoPpr import Name import Outputable import Unique import Util import BasicTypes import Var import FieldLabel import qualified Data.Data as Data import Data.Function import Data.List (find) {- ************************************************************************ * * \subsection{Pattern synonyms} * * ************************************************************************ -} -- | Pattern Synonym -- -- See Note [Pattern synonym representation] -- See Note [Pattern synonym signature contexts] data PatSyn = MkPatSyn { psName :: Name, psUnique :: Unique, -- Cached from Name psArgs :: [Type], psArity :: Arity, -- == length psArgs psInfix :: Bool, -- True <=> declared infix psFieldLabels :: [FieldLabel], -- List of fields for a -- record pattern synonym -- INVARIANT: either empty if no -- record pat syn or same length as -- psArgs -- Universally-quantified type variables psUnivTyVars :: [TyVarBinder], -- Required dictionaries (may mention psUnivTyVars) psReqTheta :: ThetaType, -- Existentially-quantified type vars psExTyVars :: [TyVarBinder], -- Provided dictionaries (may mention psUnivTyVars or psExTyVars) psProvTheta :: ThetaType, -- Result type psResultTy :: Type, -- Mentions only psUnivTyVars -- See Note [Pattern synonym result type] -- See Note [Matchers and builders for pattern synonyms] psMatcher :: (Id, Bool), -- Matcher function. -- If Bool is True then prov_theta and arg_tys are empty -- and type is -- forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs. -- req_theta -- => res_ty -- -> (forall ex_tvs. Void# -> r) -- -> (Void# -> r) -- -> r -- -- Otherwise type is -- forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs. -- req_theta -- => res_ty -- -> (forall ex_tvs. prov_theta => arg_tys -> r) -- -> (Void# -> r) -- -> r psBuilder :: Maybe (Id, Bool) -- Nothing => uni-directional pattern synonym -- Just (builder, is_unlifted) => bi-directional -- Builder function, of type -- forall univ_tvs, ex_tvs. (req_theta, prov_theta) -- => arg_tys -> res_ty -- See Note [Builder for pattern synonyms with unboxed type] } {- Note [Pattern synonym signature contexts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In a pattern synonym signature we write pattern P :: req => prov => t1 -> ... tn -> res_ty Note that the "required" context comes first, then the "provided" context. Moreover, the "required" context must not mention existentially-bound type variables; that is, ones not mentioned in res_ty. See lots of discussion in #10928. If there is no "provided" context, you can omit it; but you can't omit the "required" part (unless you omit both). Example 1: pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b) pattern P1 x = Just (3,x) We require (Num a, Eq a) to match the 3; there is no provided context. Example 2: data T2 where MkT2 :: (Num a, Eq a) => a -> a -> T2 pattern P2 :: () => (Num a, Eq a) => a -> T2 pattern P2 x = MkT2 3 x When we match against P2 we get a Num dictionary provided. We can use that to check the match against 3. Example 3: pattern P3 :: Eq a => a -> b -> T3 b This signature is illegal because the (Eq a) is a required constraint, but it mentions the existentially-bound variable 'a'. You can see it's existential because it doesn't appear in the result type (T3 b). Note [Pattern synonym result type] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T a b = MkT b a pattern P :: a -> T [a] Bool pattern P x = MkT True [x] P's psResultTy is (T a Bool), and it really only matches values of type (T [a] Bool). For example, this is ill-typed f :: T p q -> String f (P x) = "urk" This is different to the situation with GADTs: data S a where MkS :: Int -> S Bool Now MkS (and pattern synonyms coming from MkS) can match a value of type (S a), not just (S Bool); we get type refinement. That in turn means that if you have a pattern P x :: T [ty] Bool it's not entirely straightforward to work out the instantiation of P's universal tyvars. You have to /match/ the type of the pattern, (T [ty] Bool) against the psResultTy for the pattern synonym, T [a] Bool to get the instantiation a := ty. This is very unlike DataCons, where univ tyvars match 1-1 the arguments of the TyCon. Side note: I (SG) get the impression that instantiated return types should generate a *required* constraint for pattern synonyms, rather than a *provided* constraint like it's the case for GADTs. For example, I'd expect these declarations to have identical semantics: pattern Just42 :: Maybe Int pattern Just42 = Just 42 pattern Just'42 :: (a ~ Int) => Maybe a pattern Just'42 = Just 42 The latter generates the proper required constraint, the former does not. Also rather different to GADTs is the fact that Just42 doesn't have any universally quantified type variables, whereas Just'42 or MkS above has. Note [Pattern synonym representation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following pattern synonym declaration pattern P x = MkT [x] (Just 42) where data T a where MkT :: (Show a, Ord b) => [b] -> a -> T a so pattern P has type b -> T (Maybe t) with the following typeclass constraints: requires: (Eq t, Num t) provides: (Show (Maybe t), Ord b) In this case, the fields of MkPatSyn will be set as follows: psArgs = [b] psArity = 1 psInfix = False psUnivTyVars = [t] psExTyVars = [b] psProvTheta = (Show (Maybe t), Ord b) psReqTheta = (Eq t, Num t) psResultTy = T (Maybe t) Note [Matchers and builders for pattern synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For each pattern synonym P, we generate * a "matcher" function, used to desugar uses of P in patterns, which implements pattern matching * A "builder" function (for bidirectional pattern synonyms only), used to desugar uses of P in expressions, which constructs P-values. For the above example, the matcher function has type: $mP :: forall (r :: ?) t. (Eq t, Num t) => T (Maybe t) -> (forall b. (Show (Maybe t), Ord b) => b -> r) -> (Void# -> r) -> r with the following implementation: $mP @r @t $dEq $dNum scrut cont fail = case scrut of MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x _ -> fail Void# Notice that the return type 'r' has an open kind, so that it can be instantiated by an unboxed type; for example where we see f (P x) = 3# The extra Void# argument for the failure continuation is needed so that it is lazy even when the result type is unboxed. For the same reason, if the pattern has no arguments, an extra Void# argument is added to the success continuation as well. For *bidirectional* pattern synonyms, we also generate a "builder" function which implements the pattern synonym in an expression context. For our running example, it will be: $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b) => b -> T (Maybe t) $bP x = MkT [x] (Just 42) NB: the existential/universal and required/provided split does not apply to the builder since you are only putting stuff in, not getting stuff out. Injectivity of bidirectional pattern synonyms is checked in tcPatToExpr which walks the pattern and returns its corresponding expression when available. Note [Builder for pattern synonyms with unboxed type] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For bidirectional pattern synonyms that have no arguments and have an unboxed type, we add an extra Void# argument to the builder, else it would be a top-level declaration with an unboxed type. pattern P = 0# $bP :: Void# -> Int# $bP _ = 0# This means that when typechecking an occurrence of P in an expression, we must remember that the builder has this void argument. This is done by TcPatSyn.patSynBuilderOcc. Note [Pattern synonyms and the data type Type] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The type of a pattern synonym is of the form (See Note [Pattern synonym signatures] in TcSigs): forall univ_tvs. req => forall ex_tvs. prov => ... We cannot in general represent this by a value of type Type: - if ex_tvs is empty, then req and prov cannot be distinguished from each other - if req is empty, then univ_tvs and ex_tvs cannot be distinguished from each other, and moreover, prov is seen as the "required" context (as it is the only context) ************************************************************************ * * \subsection{Instances} * * ************************************************************************ -} instance Eq PatSyn where (==) = (==) `on` getUnique (/=) = (/=) `on` getUnique instance Uniquable PatSyn where getUnique = psUnique instance NamedThing PatSyn where getName = patSynName instance Outputable PatSyn where ppr = ppr . getName instance OutputableBndr PatSyn where pprInfixOcc = pprInfixName . getName pprPrefixOcc = pprPrefixName . getName instance Data.Data PatSyn where -- don't traverse? toConstr _ = abstractConstr "PatSyn" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "PatSyn" {- ************************************************************************ * * \subsection{Construction} * * ************************************************************************ -} -- | Build a new pattern synonym mkPatSyn :: Name -> Bool -- ^ Is the pattern synonym declared infix? -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type -- variables and required dicts -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type -- variables and provided dicts -> [Type] -- ^ Original arguments -> Type -- ^ Original result type -> (Id, Bool) -- ^ Name of matcher -> Maybe (Id, Bool) -- ^ Name of builder -> [FieldLabel] -- ^ Names of fields for -- a record pattern synonym -> PatSyn -- NB: The univ and ex vars are both in TyBinder form and TyVar form for -- convenience. All the TyBinders should be Named! mkPatSyn name declared_infix (univ_tvs, req_theta) (ex_tvs, prov_theta) orig_args orig_res_ty matcher builder field_labels = MkPatSyn {psName = name, psUnique = getUnique name, psUnivTyVars = univ_tvs, psExTyVars = ex_tvs, psProvTheta = prov_theta, psReqTheta = req_theta, psInfix = declared_infix, psArgs = orig_args, psArity = length orig_args, psResultTy = orig_res_ty, psMatcher = matcher, psBuilder = builder, psFieldLabels = field_labels } -- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification patSynName :: PatSyn -> Name patSynName = psName -- | Should the 'PatSyn' be presented infix? patSynIsInfix :: PatSyn -> Bool patSynIsInfix = psInfix -- | Arity of the pattern synonym patSynArity :: PatSyn -> Arity patSynArity = psArity patSynArgs :: PatSyn -> [Type] patSynArgs = psArgs patSynFieldLabels :: PatSyn -> [FieldLabel] patSynFieldLabels = psFieldLabels -- | Extract the type for any given labelled field of the 'DataCon' patSynFieldType :: PatSyn -> FieldLabelString -> Type patSynFieldType ps label = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of Just (_, ty) -> ty Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label) patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder] patSynUnivTyVarBinders = psUnivTyVars patSynExTyVars :: PatSyn -> [TyVar] patSynExTyVars ps = binderVars (psExTyVars ps) patSynExTyVarBinders :: PatSyn -> [TyVarBinder] patSynExTyVarBinders = psExTyVars patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs , psProvTheta = prov, psReqTheta = req , psArgs = arg_tys, psResultTy = res_ty }) = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty) patSynMatcher :: PatSyn -> (Id,Bool) patSynMatcher = psMatcher patSynBuilder :: PatSyn -> Maybe (Id, Bool) patSynBuilder = psBuilder updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder }) = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder } where tidy_pr (id, dummy) = (tidy_fn id, dummy) patSynInstArgTys :: PatSyn -> [Type] -> [Type] -- Return the types of the argument patterns -- e.g. data D a = forall b. MkD a b (b->a) -- pattern P f x y = MkD (x,True) y f -- D :: forall a. forall b. a -> b -> (b->a) -> D a -- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c -- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb] -- NB: the inst_tys should be both universal and existential patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs , psExTyVars = ex_tvs, psArgs = arg_tys }) inst_tys = ASSERT2( tyvars `equalLength` inst_tys , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys ) map (substTyWith tyvars inst_tys) arg_tys where tyvars = binderVars (univ_tvs ++ ex_tvs) patSynInstResTy :: PatSyn -> [Type] -> Type -- Return the type of whole pattern -- E.g. pattern P x y = Just (x,x,y) -- P :: a -> b -> Just (a,a,b) -- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool) -- NB: unlike patSynInstArgTys, the inst_tys should be just the *universal* tyvars patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs , psResultTy = res_ty }) inst_tys = ASSERT2( univ_tvs `equalLength` inst_tys , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys ) substTyWith (binderVars univ_tvs) inst_tys res_ty -- | Print the type of a pattern synonym. The foralls are printed explicitly pprPatSynType :: PatSyn -> SDoc pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta , psExTyVars = ex_tvs, psProvTheta = prov_theta , psArgs = orig_args, psResultTy = orig_res_ty }) = sep [ pprForAll univ_tvs , pprThetaArrowTy req_theta , ppWhen insert_empty_ctxt $ parens empty <+> darrow , pprType sigma_ty ] where sigma_ty = mkForAllTys ex_tvs $ mkInvisFunTys prov_theta $ mkVisFunTys orig_args orig_res_ty insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs) ghc-lib-parser-8.10.2.20200808/compiler/main/PipelineMonad.hs0000644000000000000000000001053113713635745021325 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE NamedFieldPuns #-} -- | The CompPipeline monad and associated ops -- -- Defined in separate module so that it can safely be imported from Hooks module PipelineMonad ( CompPipeline(..), evalP , PhasePlus(..) , PipeEnv(..), PipeState(..), PipelineOutput(..) , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs, setIface , pipeStateDynFlags, pipeStateModIface ) where import GhcPrelude import MonadUtils import Outputable import DynFlags import DriverPhases import HscTypes import Module import FileCleanup (TempFileLifetime) import Control.Monad newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } deriving (Functor) evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a) evalP (P f) env st = f env st instance Applicative CompPipeline where pure a = P $ \_env state -> return (state, a) (<*>) = ap instance Monad CompPipeline where P m >>= k = P $ \env state -> do (state',a) <- m env state unP (k a) env state' instance MonadIO CompPipeline where liftIO m = P $ \_env state -> do a <- m; return (state, a) data PhasePlus = RealPhase Phase | HscOut HscSource ModuleName HscStatus instance Outputable PhasePlus where ppr (RealPhase p) = ppr p ppr (HscOut {}) = text "HscOut" -- ----------------------------------------------------------------------------- -- The pipeline uses a monad to carry around various bits of information -- PipeEnv: invariant information passed down data PipeEnv = PipeEnv { stop_phase :: Phase, -- ^ Stop just before this phase src_filename :: String, -- ^ basename of original input source src_basename :: String, -- ^ basename of original input source src_suffix :: String, -- ^ its extension output_spec :: PipelineOutput -- ^ says where to put the pipeline output } -- PipeState: information that might change during a pipeline run data PipeState = PipeState { hsc_env :: HscEnv, -- ^ only the DynFlags change in the HscEnv. The DynFlags change -- at various points, for example when we read the OPTIONS_GHC -- pragmas in the Cpp phase. maybe_loc :: Maybe ModLocation, -- ^ the ModLocation. This is discovered during compilation, -- in the Hsc phase where we read the module header. foreign_os :: [FilePath], -- ^ additional object files resulting from compiling foreign -- code. They come from two sources: foreign stubs, and -- add{C,Cxx,Objc,Objcxx}File from template haskell iface :: Maybe ModIface -- ^ Interface generated by HscOut phase. Only available after the -- phase runs. } pipeStateDynFlags :: PipeState -> DynFlags pipeStateDynFlags = hsc_dflags . hsc_env pipeStateModIface :: PipeState -> Maybe ModIface pipeStateModIface = iface data PipelineOutput = Temporary TempFileLifetime -- ^ Output should be to a temporary file: we're going to -- run more compilation steps on this output later. | Persistent -- ^ We want a persistent file, i.e. a file in the current directory -- derived from the input filename, but with the appropriate extension. -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o. | SpecificFile -- ^ The output must go into the specific outputFile in DynFlags. -- We don't store the filename in the constructor as it changes -- when doing -dynamic-too. deriving Show getPipeEnv :: CompPipeline PipeEnv getPipeEnv = P $ \env state -> return (state, env) getPipeState :: CompPipeline PipeState getPipeState = P $ \_env state -> return (state, state) instance HasDynFlags CompPipeline where getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) setDynFlags :: DynFlags -> CompPipeline () setDynFlags dflags = P $ \_env state -> return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) setModLocation :: ModLocation -> CompPipeline () setModLocation loc = P $ \_env state -> return (state{ maybe_loc = Just loc }, ()) setForeignOs :: [FilePath] -> CompPipeline () setForeignOs os = P $ \_env state -> return (state{ foreign_os = os }, ()) setIface :: ModIface -> CompPipeline () setIface iface = P $ \_env state -> return (state{ iface = Just iface }, ()) ghc-lib-parser-8.10.2.20200808/compiler/utils/PlainPanic.hs0000644000000000000000000001130313713635745021031 0ustar0000000000000000{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-} -- | Defines a simple exception type and utilities to throw it. The -- 'PlainGhcException' type is a subset of the 'Panic.GhcException' -- type. It omits the exception constructors that involve -- pretty-printing via 'Outputable.SDoc'. -- -- There are two reasons for this: -- -- 1. To avoid import cycles / use of boot files. "Outputable" has -- many transitive dependencies. To throw exceptions from these -- modules, the functions here can be used without introducing import -- cycles. -- -- 2. To reduce the number of modules that need to be compiled to -- object code when loading GHC into GHCi. See #13101 module PlainPanic ( PlainGhcException(..) , showPlainGhcException , panic, sorry, pgmError , cmdLineError, cmdLineErrorIO , assertPanic , progName ) where #include "GhclibHsVersions.h" import Config import Exception import GHC.Stack import GhcPrelude import System.Environment import System.IO.Unsafe -- | This type is very similar to 'Panic.GhcException', but it omits -- the constructors that involve pretty-printing via -- 'Outputable.SDoc'. Due to the implementation of 'fromException' -- for 'Panic.GhcException', this type can be caught as a -- 'Panic.GhcException'. -- -- Note that this should only be used for throwing exceptions, not for -- catching, as 'Panic.GhcException' will not be converted to this -- type when catching. data PlainGhcException -- | Some other fatal signal (SIGHUP,SIGTERM) = PlainSignal Int -- | Prints the short usage msg after the error | PlainUsageError String -- | A problem with the command line arguments, but don't print usage. | PlainCmdLineError String -- | The 'impossible' happened. | PlainPanic String -- | The user tickled something that's known not to work yet, -- but we're not counting it as a bug. | PlainSorry String -- | An installation problem. | PlainInstallationError String -- | An error in the user's code, probably. | PlainProgramError String instance Exception PlainGhcException instance Show PlainGhcException where showsPrec _ e@(PlainProgramError _) = showPlainGhcException e showsPrec _ e@(PlainCmdLineError _) = showString ": " . showPlainGhcException e showsPrec _ e = showString progName . showString ": " . showPlainGhcException e -- | The name of this GHC. progName :: String progName = unsafePerformIO (getProgName) {-# NOINLINE progName #-} -- | Short usage information to display when we are given the wrong cmd line arguments. short_usage :: String short_usage = "Usage: For basic information, try the `--help' option." -- | Append a description of the given exception to this string. showPlainGhcException :: PlainGhcException -> ShowS showPlainGhcException = \case PlainSignal n -> showString "signal: " . shows n PlainUsageError str -> showString str . showChar '\n' . showString short_usage PlainCmdLineError str -> showString str PlainPanic s -> panicMsg (showString s) PlainSorry s -> sorryMsg (showString s) PlainInstallationError str -> showString str PlainProgramError str -> showString str where sorryMsg :: ShowS -> ShowS sorryMsg s = showString "sorry! (unimplemented feature or known bug)\n" . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t") . s . showString "\n" panicMsg :: ShowS -> ShowS panicMsg s = showString "panic! (the 'impossible' happened)\n" . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t") . s . showString "\n\n" . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n" throwPlainGhcException :: PlainGhcException -> a throwPlainGhcException = Exception.throw -- | Panics and asserts. panic, sorry, pgmError :: String -> a panic x = unsafeDupablePerformIO $ do stack <- ccsToStrings =<< getCurrentCCS x if null stack then throwPlainGhcException (PlainPanic x) else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack)) sorry x = throwPlainGhcException (PlainSorry x) pgmError x = throwPlainGhcException (PlainProgramError x) cmdLineError :: String -> a cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO cmdLineErrorIO :: String -> IO a cmdLineErrorIO x = do stack <- ccsToStrings =<< getCurrentCCS x if null stack then throwPlainGhcException (PlainCmdLineError x) else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack)) -- | Throw a failed assertion exception for a given filename and line number. assertPanic :: String -> Int -> a assertPanic file line = Exception.throw (Exception.AssertionFailed ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) ghc-lib-parser-8.10.2.20200808/compiler/main/PlatformConstants.hs0000644000000000000000000000061713713635745022266 0ustar0000000000000000{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------- -- -- | Platform constants -- -- (c) The University of Glasgow 2013 -- ------------------------------------------------------------------------------- module PlatformConstants (PlatformConstants(..)) where import GhcPrelude -- Produced by deriveConstants #include "GHCConstantsHaskellType.hs" ghc-lib-parser-8.10.2.20200808/compiler/main/Plugins.hs0000644000000000000000000002475513713635745020237 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} -- | Definitions for writing /plugins/ for GHC. Plugins can hook into -- several areas of the compiler. See the 'Plugin' type. These plugins -- include type-checker plugins, source plugins, and core-to-core plugins. module Plugins ( -- * Plugins Plugin(..) , defaultPlugin , CommandLineOption -- ** Recompilation checking , purePlugin, impurePlugin, flagRecompile , PluginRecompile(..) -- * Plugin types -- ** Frontend plugins , FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction -- ** Core plugins -- | Core plugins allow plugins to register as a Core-to-Core pass. , CorePlugin -- ** Typechecker plugins -- | Typechecker plugins allow plugins to provide evidence to the -- typechecker. , TcPlugin -- ** Source plugins -- | GHC offers a number of points where plugins can access and modify its -- front-end (\"source\") representation. These include: -- -- - access to the parser result with 'parsedResultAction' -- - access to the renamed AST with 'renamedResultAction' -- - access to the typechecked AST with 'typeCheckResultAction' -- - access to the Template Haskell splices with 'spliceRunAction' -- - access to loaded interface files with 'interfaceLoadAction' -- , keepRenamedSource -- ** Hole fit plugins -- | hole fit plugins allow plugins to change the behavior of valid hole -- fit suggestions , HoleFitPluginR -- * Internal , PluginWithArgs(..), plugins, pluginRecompile' , LoadedPlugin(..), lpModuleName , StaticPlugin(..) , mapPlugins, withPlugins, withPlugins_ ) where import GhcPrelude import {-# SOURCE #-} CoreMonad ( CoreToDo, CoreM ) import qualified TcRnTypes import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports ) import TcHoleFitTypes ( HoleFitPluginR ) import GHC.Hs import DynFlags import HscTypes import GhcMonad import DriverPhases import Module ( ModuleName, Module(moduleName)) import Fingerprint import Data.List (sort) import Outputable (Outputable(..), text, (<+>)) --Qualified import so we can define a Semigroup instance -- but it doesn't clash with Outputable.<> import qualified Data.Semigroup import Control.Monad -- | Command line options gathered from the -PModule.Name:stuff syntax -- are given to you as this type type CommandLineOption = String -- | 'Plugin' is the compiler plugin data type. Try to avoid -- constructing one of these directly, and just modify some fields of -- 'defaultPlugin' instead: this is to try and preserve source-code -- compatibility when we add fields to this. -- -- Nonetheless, this API is preliminary and highly likely to change in -- the future. data Plugin = Plugin { installCoreToDos :: CorePlugin -- ^ Modify the Core pipeline that will be used for compilation. -- This is called as the Core pipeline is built for every module -- being compiled, and plugins get the opportunity to modify the -- pipeline in a nondeterministic order. , tcPlugin :: TcPlugin -- ^ An optional typechecker plugin, which may modify the -- behaviour of the constraint solver. , holeFitPlugin :: HoleFitPlugin -- ^ An optional plugin to handle hole fits, which may re-order -- or change the list of valid hole fits and refinement hole fits. , dynflagsPlugin :: [CommandLineOption] -> DynFlags -> IO DynFlags -- ^ An optional plugin to update 'DynFlags', right after -- plugin loading. This can be used to register hooks -- or tweak any field of 'DynFlags' before doing -- actual work on a module. -- -- @since 8.10.1 , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile -- ^ Specify how the plugin should affect recompilation. , parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule -- ^ Modify the module when it is parsed. This is called by -- HscMain when the parsing is successful. , renamedResultAction :: [CommandLineOption] -> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) -- ^ Modify each group after it is renamed. This is called after each -- `HsGroup` has been renamed. , typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv -- ^ Modify the module when it is type checked. This is called at the -- very end of typechecking. , spliceRunAction :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc) -- ^ Modify the TH splice or quasiqoute before it is run. , interfaceLoadAction :: forall lcl . [CommandLineOption] -> ModIface -> IfM lcl ModIface -- ^ Modify an interface that have been loaded. This is called by -- LoadIface when an interface is successfully loaded. Not applied to -- the loading of the plugin interface. Tools that rely on information from -- modules other than the currently compiled one should implement this -- function. } -- Note [Source plugins] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- The `Plugin` datatype have been extended by fields that allow access to the -- different inner representations that are generated during the compilation -- process. These fields are `parsedResultAction`, `renamedResultAction`, -- `typeCheckResultAction`, `spliceRunAction` and `interfaceLoadAction`. -- -- The main purpose of these plugins is to help tool developers. They allow -- development tools to extract the information about the source code of a big -- Haskell project during the normal build procedure. In this case the plugin -- acts as the tools access point to the compiler that can be controlled by -- compiler flags. This is important because the manipulation of compiler flags -- is supported by most build environment. -- -- For the full discussion, check the full proposal at: -- https://gitlab.haskell.org/ghc/ghc/wikis/extended-plugins-proposal data PluginWithArgs = PluginWithArgs { paPlugin :: Plugin -- ^ the actual callable plugin , paArguments :: [CommandLineOption] -- ^ command line arguments for the plugin } -- | A plugin with its arguments. The result of loading the plugin. data LoadedPlugin = LoadedPlugin { lpPlugin :: PluginWithArgs -- ^ the actual plugin together with its commandline arguments , lpModule :: ModIface -- ^ the module containing the plugin } -- | A static plugin with its arguments. For registering compiled-in plugins -- through the GHC API. data StaticPlugin = StaticPlugin { spPlugin :: PluginWithArgs -- ^ the actual plugin together with its commandline arguments } lpModuleName :: LoadedPlugin -> ModuleName lpModuleName = moduleName . mi_module . lpModule pluginRecompile' :: PluginWithArgs -> IO PluginRecompile pluginRecompile' (PluginWithArgs plugin args) = pluginRecompile plugin args data PluginRecompile = ForceRecompile | NoForceRecompile | MaybeRecompile Fingerprint instance Outputable PluginRecompile where ppr ForceRecompile = text "ForceRecompile" ppr NoForceRecompile = text "NoForceRecompile" ppr (MaybeRecompile fp) = text "MaybeRecompile" <+> ppr fp instance Semigroup PluginRecompile where ForceRecompile <> _ = ForceRecompile NoForceRecompile <> r = r MaybeRecompile fp <> NoForceRecompile = MaybeRecompile fp MaybeRecompile fp <> MaybeRecompile fp' = MaybeRecompile (fingerprintFingerprints [fp, fp']) MaybeRecompile _fp <> ForceRecompile = ForceRecompile instance Monoid PluginRecompile where mempty = NoForceRecompile type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] type TcPlugin = [CommandLineOption] -> Maybe TcRnTypes.TcPlugin type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile purePlugin _args = return NoForceRecompile impurePlugin _args = return ForceRecompile flagRecompile = return . MaybeRecompile . fingerprintFingerprints . map fingerprintString . sort -- | Default plugin: does nothing at all, except for marking that safe -- inference has failed unless @-fplugin-trustworthy@ is passed. For -- compatibility reaso you should base all your plugin definitions on this -- default value. defaultPlugin :: Plugin defaultPlugin = Plugin { installCoreToDos = const return , tcPlugin = const Nothing , holeFitPlugin = const Nothing , dynflagsPlugin = const return , pluginRecompile = impurePlugin , renamedResultAction = \_ env grp -> return (env, grp) , parsedResultAction = \_ _ -> return , typeCheckResultAction = \_ _ -> return , spliceRunAction = \_ -> return , interfaceLoadAction = \_ -> return } -- | A renamer plugin which mades the renamed source available in -- a typechecker plugin. keepRenamedSource :: [CommandLineOption] -> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) keepRenamedSource _ gbl_env group = return (gbl_env { tcg_rn_decls = update (tcg_rn_decls gbl_env) , tcg_rn_exports = update_exports (tcg_rn_exports gbl_env) }, group) where update_exports Nothing = Just [] update_exports m = m update Nothing = Just emptyRnGroup update m = m type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m () plugins :: DynFlags -> [PluginWithArgs] plugins df = map lpPlugin (cachedPlugins df) ++ map spPlugin (staticPlugins df) -- | Perform an operation by using all of the plugins in turn. withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a withPlugins df transformation input = foldM go input (plugins df) where go arg (PluginWithArgs p opts) = transformation p opts arg mapPlugins :: DynFlags -> (Plugin -> [CommandLineOption] -> a) -> [a] mapPlugins df f = map (\(PluginWithArgs p opts) -> f p opts) (plugins df) -- | Perform a constant operation by using all of the plugins in turn. withPlugins_ :: Monad m => DynFlags -> ConstPluginOperation m a -> a -> m () withPlugins_ df transformation input = mapM_ (\(PluginWithArgs p opts) -> transformation p opts input) (plugins df) type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc () data FrontendPlugin = FrontendPlugin { frontend :: FrontendPluginAction } defaultFrontendPlugin :: FrontendPlugin defaultFrontendPlugin = FrontendPlugin { frontend = \_ _ -> return () } ghc-lib-parser-8.10.2.20200808/compiler/utils/PprColour.hs0000644000000000000000000000511213713635745020741 0ustar0000000000000000module PprColour where import GhcPrelude import Data.Maybe (fromMaybe) import Util (OverridingBool(..), split) import Data.Semigroup as Semi -- | A colour\/style for use with 'coloured'. newtype PprColour = PprColour { renderColour :: String } instance Semi.Semigroup PprColour where PprColour s1 <> PprColour s2 = PprColour (s1 <> s2) -- | Allow colours to be combined (e.g. bold + red); -- In case of conflict, right side takes precedence. instance Monoid PprColour where mempty = PprColour mempty mappend = (<>) renderColourAfresh :: PprColour -> String renderColourAfresh c = renderColour (colReset `mappend` c) colCustom :: String -> PprColour colCustom "" = mempty colCustom s = PprColour ("\27[" ++ s ++ "m") colReset :: PprColour colReset = colCustom "0" colBold :: PprColour colBold = colCustom ";1" colBlackFg :: PprColour colBlackFg = colCustom "30" colRedFg :: PprColour colRedFg = colCustom "31" colGreenFg :: PprColour colGreenFg = colCustom "32" colYellowFg :: PprColour colYellowFg = colCustom "33" colBlueFg :: PprColour colBlueFg = colCustom "34" colMagentaFg :: PprColour colMagentaFg = colCustom "35" colCyanFg :: PprColour colCyanFg = colCustom "36" colWhiteFg :: PprColour colWhiteFg = colCustom "37" data Scheme = Scheme { sHeader :: PprColour , sMessage :: PprColour , sWarning :: PprColour , sError :: PprColour , sFatal :: PprColour , sMargin :: PprColour } defaultScheme :: Scheme defaultScheme = Scheme { sHeader = mempty , sMessage = colBold , sWarning = colBold `mappend` colMagentaFg , sError = colBold `mappend` colRedFg , sFatal = colBold `mappend` colRedFg , sMargin = colBold `mappend` colBlueFg } -- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@ -- environment variable). parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme) parseScheme "always" (_, cs) = (Always, cs) parseScheme "auto" (_, cs) = (Auto, cs) parseScheme "never" (_, cs) = (Never, cs) parseScheme input (b, cs) = ( b , Scheme { sHeader = fromMaybe (sHeader cs) (lookup "header" table) , sMessage = fromMaybe (sMessage cs) (lookup "message" table) , sWarning = fromMaybe (sWarning cs) (lookup "warning" table) , sError = fromMaybe (sError cs) (lookup "error" table) , sFatal = fromMaybe (sFatal cs) (lookup "fatal" table) , sMargin = fromMaybe (sMargin cs) (lookup "margin" table) } ) where table = do w <- split ':' input let (k, v') = break (== '=') w case v' of '=' : v -> return (k, colCustom v) _ -> [] ghc-lib-parser-8.10.2.20200808/compiler/coreSyn/PprCore.hs0000644000000000000000000005135013713635744020654 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1996-1998 Printing of Core syntax -} {-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module PprCore ( pprCoreExpr, pprParendExpr, pprCoreBinding, pprCoreBindings, pprCoreAlt, pprCoreBindingWithSize, pprCoreBindingsWithSize, pprRules, pprOptCo ) where import GhcPrelude import CoreSyn import CoreStats (exprStats) import Literal( pprLiteral ) import Name( pprInfixName, pprPrefixName ) import Var import Id import IdInfo import Demand import DataCon import TyCon import TyCoPpr import Coercion import DynFlags import BasicTypes import Maybes import Util import Outputable import FastString import SrcLoc ( pprUserRealSpan ) {- ************************************************************************ * * \subsection{Public interfaces for Core printing (excluding instances)} * * ************************************************************************ @pprParendCoreExpr@ puts parens around non-atomic Core expressions. -} pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc pprCoreBinding :: OutputableBndr b => Bind b -> SDoc pprCoreExpr :: OutputableBndr b => Expr b -> SDoc pprParendExpr :: OutputableBndr b => Expr b -> SDoc pprCoreBindings = pprTopBinds noAnn pprCoreBinding = pprTopBind noAnn pprCoreBindingsWithSize :: [CoreBind] -> SDoc pprCoreBindingWithSize :: CoreBind -> SDoc pprCoreBindingsWithSize = pprTopBinds sizeAnn pprCoreBindingWithSize = pprTopBind sizeAnn instance OutputableBndr b => Outputable (Bind b) where ppr bind = ppr_bind noAnn bind instance OutputableBndr b => Outputable (Expr b) where ppr expr = pprCoreExpr expr {- ************************************************************************ * * \subsection{The guts} * * ************************************************************************ -} -- | A function to produce an annotation for a given right-hand-side type Annotation b = Expr b -> SDoc -- | Annotate with the size of the right-hand-side sizeAnn :: CoreExpr -> SDoc sizeAnn e = text "-- RHS size:" <+> ppr (exprStats e) -- | No annotation noAnn :: Expr b -> SDoc noAnn _ = empty pprTopBinds :: OutputableBndr a => Annotation a -- ^ generate an annotation to place before the -- binding -> [Bind a] -- ^ bindings to show -> SDoc -- ^ the pretty result pprTopBinds ann binds = vcat (map (pprTopBind ann) binds) pprTopBind :: OutputableBndr a => Annotation a -> Bind a -> SDoc pprTopBind ann (NonRec binder expr) = ppr_binding ann (binder,expr) $$ blankLine pprTopBind _ (Rec []) = text "Rec { }" pprTopBind ann (Rec (b:bs)) = vcat [text "Rec {", ppr_binding ann b, vcat [blankLine $$ ppr_binding ann b | b <- bs], text "end Rec }", blankLine] ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc ppr_bind ann (NonRec val_bdr expr) = ppr_binding ann (val_bdr, expr) ppr_bind ann (Rec binds) = vcat (map pp binds) where pp bind = ppr_binding ann bind <> semi ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc ppr_binding ann (val_bdr, expr) = sdocWithDynFlags $ \dflags -> vcat [ ann expr , if gopt Opt_SuppressTypeSignatures dflags then empty else pprBndr LetBind val_bdr , pp_bind ] where pp_bind = case bndrIsJoin_maybe val_bdr of Nothing -> pp_normal_bind Just ar -> pp_join_bind ar pp_normal_bind = hang (ppr val_bdr) 2 (equals <+> pprCoreExpr expr) -- For a join point of join arity n, we want to print j = \x1 ... xn -> e -- as "j x1 ... xn = e" to differentiate when a join point returns a -- lambda (the first rendering looks like a nullary join point returning -- an n-argument function). pp_join_bind join_arity | bndrs `lengthAtLeast` join_arity = hang (ppr val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs)) 2 (equals <+> pprCoreExpr rhs) | otherwise -- Yikes! A join-binding with too few lambda -- Lint will complain, but we don't want to crash -- the pretty-printer else we can't see what's wrong -- So refer to printing j = e = pp_normal_bind where (bndrs, body) = collectBinders expr lhs_bndrs = take join_arity bndrs rhs = mkLams (drop join_arity bndrs) body pprParendExpr expr = ppr_expr parens expr pprCoreExpr expr = ppr_expr noParens expr noParens :: SDoc -> SDoc noParens pp = pp pprOptCo :: Coercion -> SDoc -- Print a coercion optionally; i.e. honouring -dsuppress-coercions pprOptCo co = sdocWithDynFlags $ \dflags -> if gopt Opt_SuppressCoercions dflags then angleBrackets (text "Co:" <> int (coercionSize co)) else parens (sep [ppr co, dcolon <+> ppr (coercionType co)]) ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc -- The function adds parens in context that need -- an atomic value (e.g. function args) ppr_expr add_par (Var name) | isJoinId name = add_par ((text "jump") <+> ppr name) | otherwise = ppr name ppr_expr add_par (Type ty) = add_par (text "TYPE:" <+> ppr ty) -- Weird ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co) ppr_expr add_par (Lit lit) = pprLiteral add_par lit ppr_expr add_par (Cast expr co) = add_par $ sep [pprParendExpr expr, text "`cast`" <+> pprOptCo co] ppr_expr add_par expr@(Lam _ _) = let (bndrs, body) = collectBinders expr in add_par $ hang (text "\\" <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) 2 (pprCoreExpr body) ppr_expr add_par expr@(App {}) = sdocWithDynFlags $ \dflags -> case collectArgs expr of { (fun, args) -> let pp_args = sep (map pprArg args) val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples pp_tup_args = pprWithCommas pprCoreExpr val_args args' | gopt Opt_SuppressTypeApplications dflags = val_args | otherwise = args parens | null args' = id | otherwise = add_par in case fun of Var f -> case isDataConWorkId_maybe f of -- Notice that we print the *worker* -- for tuples in paren'd format. Just dc | saturated , Just sort <- tyConTuple_maybe tc -> tupleParens sort pp_tup_args where tc = dataConTyCon dc saturated = val_args `lengthIs` idArity f _ -> parens (hang fun_doc 2 pp_args) where fun_doc | isJoinId f = text "jump" <+> ppr f | otherwise = ppr f _ -> parens (hang (pprParendExpr fun) 2 pp_args) } ppr_expr add_par (Case expr var ty [(con,args,rhs)]) = sdocWithDynFlags $ \dflags -> if gopt Opt_PprCaseAsLet dflags then add_par $ -- See Note [Print case as let] sep [ sep [ text "let! {" <+> ppr_case_pat con args <+> text "~" <+> ppr_bndr var , text "<-" <+> ppr_expr id expr <+> text "} in" ] , pprCoreExpr rhs ] else add_par $ sep [sep [sep [ text "case" <+> pprCoreExpr expr , whenPprDebug (text "return" <+> ppr ty) , text "of" <+> ppr_bndr var ] , char '{' <+> ppr_case_pat con args <+> arrow ] , pprCoreExpr rhs , char '}' ] where ppr_bndr = pprBndr CaseBind ppr_expr add_par (Case expr var ty alts) = add_par $ sep [sep [text "case" <+> pprCoreExpr expr <+> whenPprDebug (text "return" <+> ppr ty), text "of" <+> ppr_bndr var <+> char '{'], nest 2 (vcat (punctuate semi (map pprCoreAlt alts))), char '}' ] where ppr_bndr = pprBndr CaseBind -- special cases: let ... in let ... -- ("disgusting" SLPJ) {- ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) = add_par $ vcat [ hsep [text "let {", (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], nest 2 (pprCoreExpr rhs), text "} in", pprCoreExpr body ] ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) = add_par (hang (text "let {") 2 (hsep [ppr_binding (val_bdr,rhs), text "} in"]) $$ pprCoreExpr expr) -} -- General case (recursive case, too) ppr_expr add_par (Let bind expr) = add_par $ sep [hang (keyword bind <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"), pprCoreExpr expr] where keyword (NonRec b _) | isJust (bndrIsJoin_maybe b) = text "join" | otherwise = text "let" keyword (Rec pairs) | ((b,_):_) <- pairs , isJust (bndrIsJoin_maybe b) = text "joinrec" | otherwise = text "letrec" ppr_expr add_par (Tick tickish expr) = sdocWithDynFlags $ \dflags -> if gopt Opt_SuppressTicks dflags then ppr_expr add_par expr else add_par (sep [ppr tickish, pprCoreExpr expr]) pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc pprCoreAlt (con, args, rhs) = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs) ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc ppr_case_pat (DataAlt dc) args | Just sort <- tyConTuple_maybe tc = tupleParens sort (pprWithCommas ppr_bndr args) where ppr_bndr = pprBndr CasePatBind tc = dataConTyCon dc ppr_case_pat con args = ppr con <+> (fsep (map ppr_bndr args)) where ppr_bndr = pprBndr CasePatBind -- | Pretty print the argument in a function application. pprArg :: OutputableBndr a => Expr a -> SDoc pprArg (Type ty) = sdocWithDynFlags $ \dflags -> if gopt Opt_SuppressTypeApplications dflags then empty else text "@" <+> pprParendType ty pprArg (Coercion co) = text "@~" <+> pprOptCo co pprArg expr = pprParendExpr expr {- Note [Print case as let] ~~~~~~~~~~~~~~~~~~~~~~~~ Single-branch case expressions are very common: case x of y { I# x' -> case p of q { I# p' -> ... } } These are, in effect, just strict let's, with pattern matching. With -dppr-case-as-let we print them as such: let! { I# x' ~ y <- x } in let! { I# p' ~ q <- p } in ... Other printing bits-and-bobs used with the general @pprCoreBinding@ and @pprCoreExpr@ functions. Note [Binding-site specific printing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ pprCoreBinder and pprTypedLamBinder receive a BindingSite argument to adjust the information printed. Let-bound binders are printed with their full type and idInfo. Case-bound variables (both the case binder and pattern variables) are printed without a type and without their unfolding. Furthermore, a dead case-binder is completely ignored, while otherwise, dead binders are printed as "_". -} -- These instances are sadly orphans instance OutputableBndr Var where pprBndr = pprCoreBinder pprInfixOcc = pprInfixName . varName pprPrefixOcc = pprPrefixName . varName bndrIsJoin_maybe = isJoinId_maybe instance Outputable b => OutputableBndr (TaggedBndr b) where pprBndr _ b = ppr b -- Simple pprInfixOcc b = ppr b pprPrefixOcc b = ppr b bndrIsJoin_maybe (TB b _) = isJoinId_maybe b pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder | isTyVar binder = pprKindedTyVarBndr binder | otherwise = pprTypedLetBinder binder $$ ppIdInfo binder (idInfo binder) -- Lambda bound type variables are preceded by "@" pprCoreBinder bind_site bndr = getPprStyle $ \ sty -> pprTypedLamBinder bind_site (debugStyle sty) bndr pprUntypedBinder :: Var -> SDoc pprUntypedBinder binder | isTyVar binder = text "@" <+> ppr binder -- NB: don't print kind | otherwise = pprIdBndr binder pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc -- For lambda and case binders, show the unfolding info (usually none) pprTypedLamBinder bind_site debug_on var = sdocWithDynFlags $ \dflags -> case () of _ | not debug_on -- Show case-bound wild binders only if debug is on , CaseBind <- bind_site , isDeadBinder var -> empty | not debug_on -- Even dead binders can be one-shot , isDeadBinder var -> char '_' <+> ppWhen (isId var) (pprIdBndrInfo (idInfo var)) | not debug_on -- No parens, no kind info , CaseBind <- bind_site -> pprUntypedBinder var | not debug_on , CasePatBind <- bind_site -> pprUntypedBinder var | suppress_sigs dflags -> pprUntypedBinder var | isTyVar var -> parens (pprKindedTyVarBndr var) | otherwise -> parens (hang (pprIdBndr var) 2 (vcat [ dcolon <+> pprType (idType var) , pp_unf])) where suppress_sigs = gopt Opt_SuppressTypeSignatures unf_info = unfoldingInfo (idInfo var) pp_unf | hasSomeUnfolding unf_info = text "Unf=" <> ppr unf_info | otherwise = empty pprTypedLetBinder :: Var -> SDoc -- Print binder with a type or kind signature (not paren'd) pprTypedLetBinder binder = sdocWithDynFlags $ \dflags -> case () of _ | isTyVar binder -> pprKindedTyVarBndr binder | gopt Opt_SuppressTypeSignatures dflags -> pprIdBndr binder | otherwise -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) pprKindedTyVarBndr tyvar = text "@" <+> pprTyVar tyvar -- pprIdBndr does *not* print the type -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness pprIdBndr :: Id -> SDoc pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id) pprIdBndrInfo :: IdInfo -> SDoc pprIdBndrInfo info = sdocWithDynFlags $ \dflags -> ppUnless (gopt Opt_SuppressIdInfo dflags) $ info `seq` doc -- The seq is useful for poking on black holes where prag_info = inlinePragInfo info occ_info = occInfo info dmd_info = demandInfo info lbv_info = oneShotInfo info has_prag = not (isDefaultInlinePragma prag_info) has_occ = not (isManyOccs occ_info) has_dmd = not $ isTopDmd dmd_info has_lbv = not (hasNoOneShotInfo lbv_info) doc = showAttributes [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info) , (has_occ, text "Occ=" <> ppr occ_info) , (has_dmd, text "Dmd=" <> ppr dmd_info) , (has_lbv , text "OS=" <> ppr lbv_info) ] {- ----------------------------------------------------- -- IdDetails and IdInfo ----------------------------------------------------- -} ppIdInfo :: Id -> IdInfo -> SDoc ppIdInfo id info = sdocWithDynFlags $ \dflags -> ppUnless (gopt Opt_SuppressIdInfo dflags) $ showAttributes [ (True, pp_scope <> ppr (idDetails id)) , (has_arity, text "Arity=" <> int arity) , (has_called_arity, text "CallArity=" <> int called_arity) , (has_caf_info, text "Caf=" <> ppr caf_info) , (has_str_info, text "Str=" <> pprStrictness str_info) , (has_unf, text "Unf=" <> ppr unf_info) , (not (null rules), text "RULES:" <+> vcat (map pprRule rules)) ] -- Inline pragma, occ, demand, one-shot info -- printed out with all binders (when debug is on); -- see PprCore.pprIdBndr where pp_scope | isGlobalId id = text "GblId" | isExportedId id = text "LclIdX" | otherwise = text "LclId" arity = arityInfo info has_arity = arity /= 0 called_arity = callArityInfo info has_called_arity = called_arity /= 0 caf_info = cafInfo info has_caf_info = not (mayHaveCafRefs caf_info) str_info = strictnessInfo info has_str_info = not (isTopSig str_info) unf_info = unfoldingInfo info has_unf = hasSomeUnfolding unf_info rules = ruleInfoRules (ruleInfo info) showAttributes :: [(Bool,SDoc)] -> SDoc showAttributes stuff | null docs = empty | otherwise = brackets (sep (punctuate comma docs)) where docs = [d | (True,d) <- stuff] {- ----------------------------------------------------- -- Unfolding and UnfoldingGuidance ----------------------------------------------------- -} instance Outputable UnfoldingGuidance where ppr UnfNever = text "NEVER" ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }) = text "ALWAYS_IF" <> parens (text "arity=" <> int arity <> comma <> text "unsat_ok=" <> ppr unsat_ok <> comma <> text "boring_ok=" <> ppr boring_ok) ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) = hsep [ text "IF_ARGS", brackets (hsep (map int cs)), int size, int discount ] instance Outputable UnfoldingSource where ppr InlineCompulsory = text "Compulsory" ppr InlineStable = text "InlineStable" ppr InlineRhs = text "" instance Outputable Unfolding where ppr NoUnfolding = text "No unfolding" ppr BootUnfolding = text "No unfolding (from boot)" ppr (OtherCon cs) = text "OtherCon" <+> ppr cs ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) = hang (text "DFun:" <+> ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) 2 (ppr con <+> sep (map ppr args)) ppr (CoreUnfolding { uf_src = src , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf , uf_is_conlike=conlike, uf_is_work_free=wf , uf_expandable=exp, uf_guidance=g }) = text "Unf" <> braces (pp_info $$ pp_rhs) where pp_info = fsep $ punctuate comma [ text "Src=" <> ppr src , text "TopLvl=" <> ppr top , text "Value=" <> ppr hnf , text "ConLike=" <> ppr conlike , text "WorkFree=" <> ppr wf , text "Expandable=" <> ppr exp , text "Guidance=" <> ppr g ] pp_tmpl = sdocWithDynFlags $ \dflags -> ppUnless (gopt Opt_SuppressUnfoldings dflags) $ text "Tmpl=" <+> ppr rhs pp_rhs | isStableSource src = pp_tmpl | otherwise = empty -- Don't print the RHS or we get a quadratic -- blowup in the size of the printout! {- ----------------------------------------------------- -- Rules ----------------------------------------------------- -} instance Outputable CoreRule where ppr = pprRule pprRules :: [CoreRule] -> SDoc pprRules rules = vcat (map pprRule rules) pprRule :: CoreRule -> SDoc pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name) pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) = hang (doubleQuotes (ftext name) <+> ppr act) 4 (sep [text "forall" <+> sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, nest 2 (ppr fn <+> sep (map pprArg tpl_args)), nest 2 (text "=" <+> pprCoreExpr rhs) ]) {- ----------------------------------------------------- -- Tickish ----------------------------------------------------- -} instance Outputable id => Outputable (Tickish id) where ppr (HpcTick modl ix) = hcat [text "hpc<", ppr modl, comma, ppr ix, text ">"] ppr (Breakpoint ix vars) = hcat [text "break<", ppr ix, text ">", parens (hcat (punctuate comma (map ppr vars)))] ppr (ProfNote { profNoteCC = cc, profNoteCount = tick, profNoteScope = scope }) = case (tick,scope) of (True,True) -> hcat [text "scctick<", ppr cc, char '>'] (True,False) -> hcat [text "tick<", ppr cc, char '>'] _ -> hcat [text "scc<", ppr cc, char '>'] ppr (SourceNote span _) = hcat [ text "src<", pprUserRealSpan True span, char '>'] ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/Predicate.hs0000644000000000000000000001516113713635744021666 0ustar0000000000000000{- Describes predicates as they are considered by the solver. -} module Predicate ( Pred(..), classifyPredType, isPredTy, isEvVarType, -- Equality predicates EqRel(..), eqRelRole, isEqPrimPred, isEqPred, getEqPredTys, getEqPredTys_maybe, getEqPredRole, predTypeEqRel, mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, -- Class predicates mkClassPred, isDictTy, isClassPred, isEqPredClass, isCTupleClass, getClassPredTys, getClassPredTys_maybe, -- Implicit parameters isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, hasIPPred, -- Evidence variables DictId, isEvVar, isDictId ) where import GhcPrelude import Type import Class import TyCon import Var import Coercion import PrelNames import FastString import Outputable import Util import Control.Monad ( guard ) -- | A predicate in the solver. The solver tries to prove Wanted predicates -- from Given ones. data Pred = ClassPred Class [Type] | EqPred EqRel Type Type | IrredPred PredType | ForAllPred [TyCoVarBinder] [PredType] PredType -- ForAllPred: see Note [Quantified constraints] in TcCanonical -- NB: There is no TuplePred case -- Tuple predicates like (Eq a, Ord b) are just treated -- as ClassPred, as if we had a tuple class with two superclasses -- class (c1, c2) => (%,%) c1 c2 classifyPredType :: PredType -> Pred classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of Just (tc, [_, _, ty1, ty2]) | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2 | tc `hasKey` eqPrimTyConKey -> EqPred NomEq ty1 ty2 Just (tc, tys) | Just clas <- tyConClass_maybe tc -> ClassPred clas tys _ | (tvs, rho) <- splitForAllVarBndrs ev_ty , (theta, pred) <- splitFunTys rho , not (null tvs && null theta) -> ForAllPred tvs theta pred | otherwise -> IrredPred ev_ty -- --------------------- Dictionary types --------------------------------- mkClassPred :: Class -> [Type] -> PredType mkClassPred clas tys = mkTyConApp (classTyCon clas) tys isDictTy :: Type -> Bool isDictTy = isClassPred getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type]) getClassPredTys ty = case getClassPredTys_maybe ty of Just (clas, tys) -> (clas, tys) Nothing -> pprPanic "getClassPredTys" (ppr ty) getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) getClassPredTys_maybe ty = case splitTyConApp_maybe ty of Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys) _ -> Nothing -- --------------------- Equality predicates --------------------------------- -- | A choice of equality relation. This is separate from the type 'Role' -- because 'Phantom' does not define a (non-trivial) equality relation. data EqRel = NomEq | ReprEq deriving (Eq, Ord) instance Outputable EqRel where ppr NomEq = text "nominal equality" ppr ReprEq = text "representational equality" eqRelRole :: EqRel -> Role eqRelRole NomEq = Nominal eqRelRole ReprEq = Representational getEqPredTys :: PredType -> (Type, Type) getEqPredTys ty = case splitTyConApp_maybe ty of Just (tc, [_, _, ty1, ty2]) | tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey -> (ty1, ty2) _ -> pprPanic "getEqPredTys" (ppr ty) getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type) getEqPredTys_maybe ty = case splitTyConApp_maybe ty of Just (tc, [_, _, ty1, ty2]) | tc `hasKey` eqPrimTyConKey -> Just (Nominal, ty1, ty2) | tc `hasKey` eqReprPrimTyConKey -> Just (Representational, ty1, ty2) _ -> Nothing getEqPredRole :: PredType -> Role getEqPredRole ty = eqRelRole (predTypeEqRel ty) -- | Get the equality relation relevant for a pred type. predTypeEqRel :: PredType -> EqRel predTypeEqRel ty | Just (tc, _) <- splitTyConApp_maybe ty , tc `hasKey` eqReprPrimTyConKey = ReprEq | otherwise = NomEq {------------------------------------------- Predicates on PredType --------------------------------------------} {- Note [Evidence for quantified constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The superclass mechanism in TcCanonical.makeSuperClasses risks taking a quantified constraint like (forall a. C a => a ~ b) and generate superclass evidence (forall a. C a => a ~# b) This is a funny thing: neither isPredTy nor isCoVarType are true of it. So we are careful not to generate it in the first place: see Note [Equality superclasses in quantified constraints] in TcCanonical. -} isEvVarType :: Type -> Bool -- True of (a) predicates, of kind Constraint, such as (Eq a), and (a ~ b) -- (b) coercion types, such as (t1 ~# t2) or (t1 ~R# t2) -- See Note [Types for coercions, predicates, and evidence] in TyCoRep -- See Note [Evidence for quantified constraints] isEvVarType ty = isCoVarType ty || isPredTy ty isEqPredClass :: Class -> Bool -- True of (~) and (~~) isEqPredClass cls = cls `hasKey` eqTyConKey || cls `hasKey` heqTyConKey isClassPred, isEqPred, isEqPrimPred, isIPPred :: PredType -> Bool isClassPred ty = case tyConAppTyCon_maybe ty of Just tyCon | isClassTyCon tyCon -> True _ -> False isEqPred ty -- True of (a ~ b) and (a ~~ b) -- ToDo: should we check saturation? | Just tc <- tyConAppTyCon_maybe ty , Just cls <- tyConClass_maybe tc = isEqPredClass cls | otherwise = False isEqPrimPred ty = isCoVarType ty -- True of (a ~# b) (a ~R# b) isIPPred ty = case tyConAppTyCon_maybe ty of Just tc -> isIPTyCon tc _ -> False isIPTyCon :: TyCon -> Bool isIPTyCon tc = tc `hasKey` ipClassKey -- Class and its corresponding TyCon have the same Unique isIPClass :: Class -> Bool isIPClass cls = cls `hasKey` ipClassKey isCTupleClass :: Class -> Bool isCTupleClass cls = isTupleTyCon (classTyCon cls) isIPPred_maybe :: Type -> Maybe (FastString, Type) isIPPred_maybe ty = do (tc,[t1,t2]) <- splitTyConApp_maybe ty guard (isIPTyCon tc) x <- isStrLitTy t1 return (x,t2) hasIPPred :: PredType -> Bool hasIPPred pred = case classifyPredType pred of ClassPred cls tys | isIPClass cls -> True | isCTupleClass cls -> any hasIPPred tys _other -> False {- ************************************************************************ * * Evidence variables * * ************************************************************************ -} isEvVar :: Var -> Bool isEvVar var = isEvVarType (varType var) isDictId :: Id -> Bool isDictId id = isDictTy (varType id) ghc-lib-parser-8.10.2.20200808/compiler/prelude/PrelNames.hs0000644000000000000000000032772713713635745021225 0ustar0000000000000000{- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[PrelNames]{Definitions of prelude modules and names} Nota Bene: all Names defined in here should come from the base package - ModuleNames for prelude modules, e.g. pREL_BASE_Name :: ModuleName - Modules for prelude modules e.g. pREL_Base :: Module - Uniques for Ids, DataCons, TyCons and Classes that the compiler "knows about" in some way e.g. intTyConKey :: Unique minusClassOpKey :: Unique - Names for Ids, DataCons, TyCons and Classes that the compiler "knows about" in some way e.g. intTyConName :: Name minusName :: Name One of these Names contains (a) the module and occurrence name of the thing (b) its Unique The way the compiler "knows about" one of these things is where the type checker or desugarer needs to look it up. For example, when desugaring list comprehensions the desugarer needs to conjure up 'foldr'. It does this by looking up foldrName in the environment. - RdrNames for Ids, DataCons etc that the compiler may emit into generated code (e.g. for deriving). It's not necessary to know the uniques for these guys, only their names Note [Known-key names] ~~~~~~~~~~~~~~~~~~~~~~ It is *very* important that the compiler gives wired-in things and things with "known-key" names the correct Uniques wherever they occur. We have to be careful about this in exactly two places: 1. When we parse some source code, renaming the AST better yield an AST whose Names have the correct uniques 2. When we read an interface file, the read-in gubbins better have the right uniques This is accomplished through a combination of mechanisms: 1. When parsing source code, the RdrName-decorated AST has some RdrNames which are Exact. These are wired-in RdrNames where the we could directly tell from the parsed syntax what Name to use. For example, when we parse a [] in a type we can just insert an Exact RdrName Name with the listTyConKey. Currently, I believe this is just an optimisation: it would be equally valid to just output Orig RdrNames that correctly record the module etc we expect the final Name to come from. However, were we to eliminate isBuiltInOcc_maybe it would become essential (see point 3). 2. The knownKeyNames (which consist of the basicKnownKeyNames from the module, and those names reachable via the wired-in stuff from TysWiredIn) are used to initialise the "OrigNameCache" in IfaceEnv. This initialization ensures that when the type checker or renamer (both of which use IfaceEnv) look up an original name (i.e. a pair of a Module and an OccName) for a known-key name they get the correct Unique. This is the most important mechanism for ensuring that known-key stuff gets the right Unique, and is why it is so important to place your known-key names in the appropriate lists. 3. For "infinite families" of known-key names (i.e. tuples and sums), we have to be extra careful. Because there are an infinite number of these things, we cannot add them to the list of known-key names used to initialise the OrigNameCache. Instead, we have to rely on never having to look them up in that cache. See Note [Infinite families of known-key names] for details. Note [Infinite families of known-key names] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Infinite families of known-key things (e.g. tuples and sums) pose a tricky problem: we can't add them to the knownKeyNames finite map which we use to ensure that, e.g., a reference to (,) gets assigned the right unique (if this doesn't sound familiar see Note [Known-key names] above). We instead handle tuples and sums separately from the "vanilla" known-key things, a) The parser recognises them specially and generates an Exact Name (hence not looked up in the orig-name cache) b) The known infinite families of names are specially serialised by BinIface.putName, with that special treatment detected when we read back to ensure that we get back to the correct uniques. See Note [Symbol table representation of names] in BinIface and Note [How tuples work] in TysWiredIn. Most of the infinite families cannot occur in source code, so mechanisms (a) and (b) suffice to ensure that they always have the right Unique. In particular, implicit param TyCon names, constraint tuples and Any TyCons cannot be mentioned by the user. For those things that *can* appear in source programs, c) IfaceEnv.lookupOrigNameCache uses isBuiltInOcc_maybe to map built-in syntax directly onto the corresponding name, rather than trying to find it in the original-name cache. See also Note [Built-in syntax and the OrigNameCache] Note that one-tuples are an exception to the rule, as they do get assigned known keys. See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys) in GHC.Builtin.Types. Note [The integer library] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Clearly, we need to know the names of various definitions of the integer library, e.g. the type itself, `mkInteger` etc. But there are two possible implementations of the integer library: * integer-gmp (fast, but uses libgmp, which may not be available on all targets and is GPL licensed) * integer-simple (slow, but pure Haskell and BSD-licensed) We want the compiler to work with either one. The way we achieve this is: * When compiling the integer-{gmp,simple} library, we pass -this-unit-id integer-wired-in to GHC (see the cabal file libraries/integer-{gmp,simple}. * This way, GHC can use just this UnitID (see Module.integerUnitId) when generating code, and the linker will succeed. Unfortuately, the abstraction is not complete: When using integer-gmp, we really want to use the S# constructor directly. This is controlled by the `integerLibrary` field of `DynFlags`: If it is IntegerGMP, we use this constructor directly (see CorePrep.lookupIntegerSDataConName) When GHC reads the package data base, it (internally only) pretends it has UnitId `integer-wired-in` instead of the actual UnitId (which includes the version number); just like for `base` and other packages, as described in Note [Wired-in packages] in Module. This is done in Packages.findWiredInPackages. -} {-# LANGUAGE CPP #-} module PrelNames ( Unique, Uniquable(..), hasKey, -- Re-exported for convenience ----------------------------------------------------------- module PrelNames, -- A huge bunch of (a) Names, e.g. intTyConName -- (b) Uniques e.g. intTyConKey -- (c) Groups of classes and types -- (d) miscellaneous things -- So many that we export them all ) where #include "GhclibHsVersions.h" import GhcPrelude import Module import OccName import RdrName import Unique import Name import SrcLoc import FastString {- ************************************************************************ * * allNameStrings * * ************************************************************************ -} allNameStrings :: [String] -- Infinite list of a,b,c...z, aa, ab, ac, ... etc allNameStrings = [ c:cs | cs <- "" : allNameStrings, c <- ['a'..'z'] ] {- ************************************************************************ * * \subsection{Local Names} * * ************************************************************************ This *local* name is used by the interactive stuff -} itName :: Unique -> SrcSpan -> Name itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc -- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly -- during compiler debugging. mkUnboundName :: OccName -> Name mkUnboundName occ = mkInternalName unboundKey occ noSrcSpan isUnboundName :: Name -> Bool isUnboundName name = name `hasKey` unboundKey {- ************************************************************************ * * \subsection{Known key Names} * * ************************************************************************ This section tells what the compiler knows about the association of names with uniques. These ones are the *non* wired-in ones. The wired in ones are defined in TysWiredIn etc. -} basicKnownKeyNames :: [Name] -- See Note [Known-key names] basicKnownKeyNames = genericTyConNames ++ [ -- Classes. *Must* include: -- classes that are grabbed by key (e.g., eqClassKey) -- classes in "Class.standardClassKeys" (quite a few) eqClassName, -- mentioned, derivable ordClassName, -- derivable boundedClassName, -- derivable numClassName, -- mentioned, numeric enumClassName, -- derivable monadClassName, functorClassName, realClassName, -- numeric integralClassName, -- numeric fractionalClassName, -- numeric floatingClassName, -- numeric realFracClassName, -- numeric realFloatClassName, -- numeric dataClassName, isStringClassName, applicativeClassName, alternativeClassName, foldableClassName, traversableClassName, semigroupClassName, sappendName, monoidClassName, memptyName, mappendName, mconcatName, -- The IO type -- See Note [TyConRepNames for non-wired-in TyCons] ioTyConName, ioDataConName, runMainIOName, runRWName, -- Type representation types trModuleTyConName, trModuleDataConName, trNameTyConName, trNameSDataConName, trNameDDataConName, trTyConTyConName, trTyConDataConName, -- Typeable typeableClassName, typeRepTyConName, someTypeRepTyConName, someTypeRepDataConName, kindRepTyConName, kindRepTyConAppDataConName, kindRepVarDataConName, kindRepAppDataConName, kindRepFunDataConName, kindRepTYPEDataConName, kindRepTypeLitSDataConName, kindRepTypeLitDDataConName, typeLitSortTyConName, typeLitSymbolDataConName, typeLitNatDataConName, typeRepIdName, mkTrTypeName, mkTrConName, mkTrAppName, mkTrFunName, typeSymbolTypeRepName, typeNatTypeRepName, trGhcPrimModuleName, -- KindReps for common cases starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName, -- Dynamic toDynName, -- Numeric stuff negateName, minusName, geName, eqName, -- Conversion functions rationalTyConName, ratioTyConName, ratioDataConName, fromRationalName, fromIntegerName, toIntegerName, toRationalName, fromIntegralName, realToFracName, -- Int# stuff divIntName, modIntName, -- String stuff fromStringName, -- Enum stuff enumFromName, enumFromThenName, enumFromThenToName, enumFromToName, -- Applicative stuff pureAName, apAName, thenAName, -- Functor stuff fmapName, -- Monad stuff thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName, returnMName, joinMName, -- MonadFail monadFailClassName, failMName, -- MonadFix monadFixClassName, mfixName, -- Arrow stuff arrAName, composeAName, firstAName, appAName, choiceAName, loopAName, -- Ix stuff ixClassName, -- Show stuff showClassName, -- Read stuff readClassName, -- Stable pointers newStablePtrName, -- GHC Extensions groupWithName, -- Strings and lists unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, -- Overloaded lists isListClassName, fromListName, fromListNName, toListName, -- List operations concatName, filterName, mapName, zipName, foldrName, buildName, augmentName, appendName, -- FFI primitive types that are not wired-in. stablePtrTyConName, ptrTyConName, funPtrTyConName, int8TyConName, int16TyConName, int32TyConName, int64TyConName, word16TyConName, word32TyConName, word64TyConName, -- Others otherwiseIdName, inlineIdName, eqStringName, assertName, breakpointName, breakpointCondName, opaqueTyConName, assertErrorName, traceName, printName, fstName, sndName, dollarName, -- Integer integerTyConName, mkIntegerName, integerToWord64Name, integerToInt64Name, word64ToIntegerName, int64ToIntegerName, plusIntegerName, timesIntegerName, smallIntegerName, wordToIntegerName, integerToWordName, integerToIntName, minusIntegerName, negateIntegerName, eqIntegerPrimName, neqIntegerPrimName, absIntegerName, signumIntegerName, leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName, compareIntegerName, quotRemIntegerName, divModIntegerName, quotIntegerName, remIntegerName, divIntegerName, modIntegerName, floatFromIntegerName, doubleFromIntegerName, encodeFloatIntegerName, encodeDoubleIntegerName, decodeDoubleIntegerName, gcdIntegerName, lcmIntegerName, andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, shiftLIntegerName, shiftRIntegerName, bitIntegerName, integerSDataConName,naturalSDataConName, -- Natural naturalTyConName, naturalFromIntegerName, naturalToIntegerName, plusNaturalName, minusNaturalName, timesNaturalName, mkNaturalName, wordToNaturalName, -- Float/Double rationalToFloatName, rationalToDoubleName, -- Other classes randomClassName, randomGenClassName, monadPlusClassName, -- Type-level naturals knownNatClassName, knownSymbolClassName, -- Overloaded labels isLabelClassName, -- Implicit Parameters ipClassName, -- Overloaded record fields hasFieldClassName, -- Call Stacks callStackTyConName, emptyCallStackName, pushCallStackName, -- Source Locations srcLocDataConName, -- Annotation type checking toAnnotationWrapperName -- The SPEC type for SpecConstr , specTyConName -- The Either type , eitherTyConName, leftDataConName, rightDataConName -- Plugins , pluginTyConName , frontendPluginTyConName -- Generics , genClassName, gen1ClassName , datatypeClassName, constructorClassName, selectorClassName -- Monad comprehensions , guardMName , liftMName , mzipName -- GHCi Sandbox , ghciIoClassName, ghciStepIoMName -- StaticPtr , makeStaticName , staticPtrTyConName , staticPtrDataConName, staticPtrInfoDataConName , fromStaticPtrName -- Fingerprint , fingerprintDataConName -- Custom type errors , errorMessageTypeErrorFamName , typeErrorTextDataConName , typeErrorAppendDataConName , typeErrorVAppendDataConName , typeErrorShowTypeDataConName ] genericTyConNames :: [Name] genericTyConNames = [ v1TyConName, u1TyConName, par1TyConName, rec1TyConName, k1TyConName, m1TyConName, sumTyConName, prodTyConName, compTyConName, rTyConName, dTyConName, cTyConName, sTyConName, rec0TyConName, d1TyConName, c1TyConName, s1TyConName, noSelTyConName, repTyConName, rep1TyConName, uRecTyConName, uAddrTyConName, uCharTyConName, uDoubleTyConName, uFloatTyConName, uIntTyConName, uWordTyConName, prefixIDataConName, infixIDataConName, leftAssociativeDataConName, rightAssociativeDataConName, notAssociativeDataConName, sourceUnpackDataConName, sourceNoUnpackDataConName, noSourceUnpackednessDataConName, sourceLazyDataConName, sourceStrictDataConName, noSourceStrictnessDataConName, decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, metaDataDataConName, metaConsDataConName, metaSelDataConName ] {- ************************************************************************ * * \subsection{Module names} * * ************************************************************************ --MetaHaskell Extension Add a new module here -} pRELUDE :: Module pRELUDE = mkBaseModule_ pRELUDE_NAME gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING, gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL, gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_LIST, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, gHC_CONC, gHC_IO, gHC_IO_Exception, gHC_ST, gHC_IX, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL, gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, tYPEABLE_INTERNAL, gENERICS, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL, aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_TYPENATS, dATA_TYPE_EQUALITY, dATA_COERCE, dEBUG_TRACE :: Module gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values gHC_TYPES = mkPrimModule (fsLit "GHC.Types") gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") gHC_CSTRING = mkPrimModule (fsLit "GHC.CString") gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes") gHC_PRIMOPWRAPPERS = mkPrimModule (fsLit "GHC.PrimopWrappers") gHC_BASE = mkBaseModule (fsLit "GHC.Base") gHC_ENUM = mkBaseModule (fsLit "GHC.Enum") gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi") gHC_GHCI_HELPERS= mkBaseModule (fsLit "GHC.GHCi.Helpers") gHC_SHOW = mkBaseModule (fsLit "GHC.Show") gHC_READ = mkBaseModule (fsLit "GHC.Read") gHC_NUM = mkBaseModule (fsLit "GHC.Num") gHC_MAYBE = mkBaseModule (fsLit "GHC.Maybe") gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type") gHC_NATURAL = mkBaseModule (fsLit "GHC.Natural") gHC_LIST = mkBaseModule (fsLit "GHC.List") gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") dATA_EITHER = mkBaseModule (fsLit "Data.Either") dATA_LIST = mkBaseModule (fsLit "Data.List") dATA_STRING = mkBaseModule (fsLit "Data.String") dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable") gHC_CONC = mkBaseModule (fsLit "GHC.Conc") gHC_IO = mkBaseModule (fsLit "GHC.IO") gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception") gHC_ST = mkBaseModule (fsLit "GHC.ST") gHC_IX = mkBaseModule (fsLit "GHC.Ix") gHC_STABLE = mkBaseModule (fsLit "GHC.Stable") gHC_PTR = mkBaseModule (fsLit "GHC.Ptr") gHC_ERR = mkBaseModule (fsLit "GHC.Err") gHC_REAL = mkBaseModule (fsLit "GHC.Real") gHC_FLOAT = mkBaseModule (fsLit "GHC.Float") gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler") sYSTEM_IO = mkBaseModule (fsLit "System.IO") dYNAMIC = mkBaseModule (fsLit "Data.Dynamic") tYPEABLE = mkBaseModule (fsLit "Data.Typeable") tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal") gENERICS = mkBaseModule (fsLit "Data.Data") rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec") lEX = mkBaseModule (fsLit "Text.Read.Lex") gHC_INT = mkBaseModule (fsLit "GHC.Int") gHC_WORD = mkBaseModule (fsLit "GHC.Word") mONAD = mkBaseModule (fsLit "Control.Monad") mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix") mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip") mONAD_FAIL = mkBaseModule (fsLit "Control.Monad.Fail") aRROW = mkBaseModule (fsLit "Control.Arrow") cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative") gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") rANDOM = mkBaseModule (fsLit "System.Random") gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") gHC_GENERICS = mkBaseModule (fsLit "GHC.Generics") gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits") gHC_TYPENATS = mkBaseModule (fsLit "GHC.TypeNats") dATA_TYPE_EQUALITY = mkBaseModule (fsLit "Data.Type.Equality") dATA_COERCE = mkBaseModule (fsLit "Data.Coerce") dEBUG_TRACE = mkBaseModule (fsLit "Debug.Trace") gHC_SRCLOC :: Module gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc") gHC_STACK, gHC_STACK_TYPES :: Module gHC_STACK = mkBaseModule (fsLit "GHC.Stack") gHC_STACK_TYPES = mkBaseModule (fsLit "GHC.Stack.Types") gHC_STATICPTR :: Module gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr") gHC_STATICPTR_INTERNAL :: Module gHC_STATICPTR_INTERNAL = mkBaseModule (fsLit "GHC.StaticPtr.Internal") gHC_FINGERPRINT_TYPE :: Module gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type") gHC_OVER_LABELS :: Module gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels") gHC_RECORDS :: Module gHC_RECORDS = mkBaseModule (fsLit "GHC.Records") mAIN, rOOT_MAIN :: Module mAIN = mkMainModule_ mAIN_NAME rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation mkInteractiveModule :: Int -> Module -- (mkInteractiveMoudule 9) makes module 'interactive:M9' mkInteractiveModule n = mkModule interactiveUnitId (mkModuleName ("Ghci" ++ show n)) pRELUDE_NAME, mAIN_NAME :: ModuleName pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude") mAIN_NAME = mkModuleNameFS (fsLit "Main") dATA_ARRAY_PARALLEL_NAME, dATA_ARRAY_PARALLEL_PRIM_NAME :: ModuleName dATA_ARRAY_PARALLEL_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel") dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim") mkPrimModule :: FastString -> Module mkPrimModule m = mkModule primUnitId (mkModuleNameFS m) mkIntegerModule :: FastString -> Module mkIntegerModule m = mkModule integerUnitId (mkModuleNameFS m) mkBaseModule :: FastString -> Module mkBaseModule m = mkModule baseUnitId (mkModuleNameFS m) mkBaseModule_ :: ModuleName -> Module mkBaseModule_ m = mkModule baseUnitId m mkThisGhcModule :: FastString -> Module mkThisGhcModule m = mkModule thisGhcUnitId (mkModuleNameFS m) mkThisGhcModule_ :: ModuleName -> Module mkThisGhcModule_ m = mkModule thisGhcUnitId m mkMainModule :: FastString -> Module mkMainModule m = mkModule mainUnitId (mkModuleNameFS m) mkMainModule_ :: ModuleName -> Module mkMainModule_ m = mkModule mainUnitId m {- ************************************************************************ * * RdrNames * * ************************************************************************ -} main_RDR_Unqual :: RdrName main_RDR_Unqual = mkUnqual varName (fsLit "main") -- We definitely don't want an Orig RdrName, because -- main might, in principle, be imported into module Main eq_RDR, ge_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR, ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName eq_RDR = nameRdrName eqName ge_RDR = nameRdrName geName le_RDR = varQual_RDR gHC_CLASSES (fsLit "<=") lt_RDR = varQual_RDR gHC_CLASSES (fsLit "<") gt_RDR = varQual_RDR gHC_CLASSES (fsLit ">") compare_RDR = varQual_RDR gHC_CLASSES (fsLit "compare") ltTag_RDR = nameRdrName ordLTDataConName eqTag_RDR = nameRdrName ordEQDataConName gtTag_RDR = nameRdrName ordGTDataConName eqClass_RDR, numClass_RDR, ordClass_RDR, enumClass_RDR, monadClass_RDR :: RdrName eqClass_RDR = nameRdrName eqClassName numClass_RDR = nameRdrName numClassName ordClass_RDR = nameRdrName ordClassName enumClass_RDR = nameRdrName enumClassName monadClass_RDR = nameRdrName monadClassName map_RDR, append_RDR :: RdrName map_RDR = nameRdrName mapName append_RDR = nameRdrName appendName foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR :: RdrName foldr_RDR = nameRdrName foldrName build_RDR = nameRdrName buildName returnM_RDR = nameRdrName returnMName bindM_RDR = nameRdrName bindMName failM_RDR = nameRdrName failMName left_RDR, right_RDR :: RdrName left_RDR = nameRdrName leftDataConName right_RDR = nameRdrName rightDataConName fromEnum_RDR, toEnum_RDR :: RdrName fromEnum_RDR = varQual_RDR gHC_ENUM (fsLit "fromEnum") toEnum_RDR = varQual_RDR gHC_ENUM (fsLit "toEnum") enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName enumFrom_RDR = nameRdrName enumFromName enumFromTo_RDR = nameRdrName enumFromToName enumFromThen_RDR = nameRdrName enumFromThenName enumFromThenTo_RDR = nameRdrName enumFromThenToName ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR :: RdrName ratioDataCon_RDR = nameRdrName ratioDataConName plusInteger_RDR = nameRdrName plusIntegerName timesInteger_RDR = nameRdrName timesIntegerName ioDataCon_RDR :: RdrName ioDataCon_RDR = nameRdrName ioDataConName eqString_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR :: RdrName eqString_RDR = nameRdrName eqStringName unpackCString_RDR = nameRdrName unpackCStringName unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name newStablePtr_RDR :: RdrName newStablePtr_RDR = nameRdrName newStablePtrName bindIO_RDR, returnIO_RDR :: RdrName bindIO_RDR = nameRdrName bindIOName returnIO_RDR = nameRdrName returnIOName fromInteger_RDR, fromRational_RDR, minus_RDR, times_RDR, plus_RDR :: RdrName fromInteger_RDR = nameRdrName fromIntegerName fromRational_RDR = nameRdrName fromRationalName minus_RDR = nameRdrName minusName times_RDR = varQual_RDR gHC_NUM (fsLit "*") plus_RDR = varQual_RDR gHC_NUM (fsLit "+") toInteger_RDR, toRational_RDR, fromIntegral_RDR :: RdrName toInteger_RDR = nameRdrName toIntegerName toRational_RDR = nameRdrName toRationalName fromIntegral_RDR = nameRdrName fromIntegralName stringTy_RDR, fromString_RDR :: RdrName stringTy_RDR = tcQual_RDR gHC_BASE (fsLit "String") fromString_RDR = nameRdrName fromStringName fromList_RDR, fromListN_RDR, toList_RDR :: RdrName fromList_RDR = nameRdrName fromListName fromListN_RDR = nameRdrName fromListNName toList_RDR = nameRdrName toListName compose_RDR :: RdrName compose_RDR = varQual_RDR gHC_BASE (fsLit ".") not_RDR, getTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR, and_RDR, range_RDR, inRange_RDR, index_RDR, unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName and_RDR = varQual_RDR gHC_CLASSES (fsLit "&&") not_RDR = varQual_RDR gHC_CLASSES (fsLit "not") getTag_RDR = varQual_RDR gHC_BASE (fsLit "getTag") succ_RDR = varQual_RDR gHC_ENUM (fsLit "succ") pred_RDR = varQual_RDR gHC_ENUM (fsLit "pred") minBound_RDR = varQual_RDR gHC_ENUM (fsLit "minBound") maxBound_RDR = varQual_RDR gHC_ENUM (fsLit "maxBound") range_RDR = varQual_RDR gHC_IX (fsLit "range") inRange_RDR = varQual_RDR gHC_IX (fsLit "inRange") index_RDR = varQual_RDR gHC_IX (fsLit "index") unsafeIndex_RDR = varQual_RDR gHC_IX (fsLit "unsafeIndex") unsafeRangeSize_RDR = varQual_RDR gHC_IX (fsLit "unsafeRangeSize") readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR, readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName readList_RDR = varQual_RDR gHC_READ (fsLit "readList") readListDefault_RDR = varQual_RDR gHC_READ (fsLit "readListDefault") readListPrec_RDR = varQual_RDR gHC_READ (fsLit "readListPrec") readListPrecDefault_RDR = varQual_RDR gHC_READ (fsLit "readListPrecDefault") readPrec_RDR = varQual_RDR gHC_READ (fsLit "readPrec") parens_RDR = varQual_RDR gHC_READ (fsLit "parens") choose_RDR = varQual_RDR gHC_READ (fsLit "choose") lexP_RDR = varQual_RDR gHC_READ (fsLit "lexP") expectP_RDR = varQual_RDR gHC_READ (fsLit "expectP") readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName readField_RDR = varQual_RDR gHC_READ (fsLit "readField") readFieldHash_RDR = varQual_RDR gHC_READ (fsLit "readFieldHash") readSymField_RDR = varQual_RDR gHC_READ (fsLit "readSymField") punc_RDR, ident_RDR, symbol_RDR :: RdrName punc_RDR = dataQual_RDR lEX (fsLit "Punc") ident_RDR = dataQual_RDR lEX (fsLit "Ident") symbol_RDR = dataQual_RDR lEX (fsLit "Symbol") step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName step_RDR = varQual_RDR rEAD_PREC (fsLit "step") alt_RDR = varQual_RDR rEAD_PREC (fsLit "+++") reset_RDR = varQual_RDR rEAD_PREC (fsLit "reset") prec_RDR = varQual_RDR rEAD_PREC (fsLit "prec") pfail_RDR = varQual_RDR rEAD_PREC (fsLit "pfail") showsPrec_RDR, shows_RDR, showString_RDR, showSpace_RDR, showCommaSpace_RDR, showParen_RDR :: RdrName showsPrec_RDR = varQual_RDR gHC_SHOW (fsLit "showsPrec") shows_RDR = varQual_RDR gHC_SHOW (fsLit "shows") showString_RDR = varQual_RDR gHC_SHOW (fsLit "showString") showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace") showCommaSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showCommaSpace") showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen") undefined_RDR :: RdrName undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") error_RDR :: RdrName error_RDR = varQual_RDR gHC_ERR (fsLit "error") -- Generics (constructors and functions) u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, prodDataCon_RDR, comp1DataCon_RDR, unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR, from_RDR, from1_RDR, to_RDR, to1_RDR, datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR, conName_RDR, conFixity_RDR, conIsRecord_RDR, selName_RDR, prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR, rightAssocDataCon_RDR, notAssocDataCon_RDR, uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR, uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR, uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR, uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1") par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1") rec1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Rec1") k1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "K1") m1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "M1") l1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "L1") r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1") prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1") unPar1_RDR = varQual_RDR gHC_GENERICS (fsLit "unPar1") unRec1_RDR = varQual_RDR gHC_GENERICS (fsLit "unRec1") unK1_RDR = varQual_RDR gHC_GENERICS (fsLit "unK1") unComp1_RDR = varQual_RDR gHC_GENERICS (fsLit "unComp1") from_RDR = varQual_RDR gHC_GENERICS (fsLit "from") from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1") to_RDR = varQual_RDR gHC_GENERICS (fsLit "to") to1_RDR = varQual_RDR gHC_GENERICS (fsLit "to1") datatypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "datatypeName") moduleName_RDR = varQual_RDR gHC_GENERICS (fsLit "moduleName") packageName_RDR = varQual_RDR gHC_GENERICS (fsLit "packageName") isNewtypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "isNewtype") selName_RDR = varQual_RDR gHC_GENERICS (fsLit "selName") conName_RDR = varQual_RDR gHC_GENERICS (fsLit "conName") conFixity_RDR = varQual_RDR gHC_GENERICS (fsLit "conFixity") conIsRecord_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsRecord") prefixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Prefix") infixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Infix") leftAssocDataCon_RDR = nameRdrName leftAssociativeDataConName rightAssocDataCon_RDR = nameRdrName rightAssociativeDataConName notAssocDataCon_RDR = nameRdrName notAssociativeDataConName uAddrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UAddr") uCharDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UChar") uDoubleDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UDouble") uFloatDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UFloat") uIntDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UInt") uWordDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UWord") uAddrHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uAddr#") uCharHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uChar#") uDoubleHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uDouble#") uFloatHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uFloat#") uIntHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uInt#") uWordHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uWord#") fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR, foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR, mappend_RDR :: RdrName fmap_RDR = nameRdrName fmapName replace_RDR = varQual_RDR gHC_BASE (fsLit "<$") pure_RDR = nameRdrName pureAName ap_RDR = nameRdrName apAName liftA2_RDR = varQual_RDR gHC_BASE (fsLit "liftA2") foldable_foldr_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldr") foldMap_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldMap") null_RDR = varQual_RDR dATA_FOLDABLE (fsLit "null") all_RDR = varQual_RDR dATA_FOLDABLE (fsLit "all") traverse_RDR = varQual_RDR dATA_TRAVERSABLE (fsLit "traverse") mempty_RDR = nameRdrName memptyName mappend_RDR = nameRdrName mappendName ---------------------- varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR :: Module -> FastString -> RdrName varQual_RDR mod str = mkOrig mod (mkOccNameFS varName str) tcQual_RDR mod str = mkOrig mod (mkOccNameFS tcName str) clsQual_RDR mod str = mkOrig mod (mkOccNameFS clsName str) dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str) {- ************************************************************************ * * \subsection{Known-key names} * * ************************************************************************ Many of these Names are not really "built in", but some parts of the compiler (notably the deriving mechanism) need to mention their names, and it's convenient to write them all down in one place. -} wildCardName :: Name wildCardName = mkSystemVarName wildCardKey (fsLit "wild") runMainIOName, runRWName :: Name runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey runRWName = varQual gHC_MAGIC (fsLit "runRW#") runRWKey orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name orderingTyConName = tcQual gHC_TYPES (fsLit "Ordering") orderingTyConKey ordLTDataConName = dcQual gHC_TYPES (fsLit "LT") ordLTDataConKey ordEQDataConName = dcQual gHC_TYPES (fsLit "EQ") ordEQDataConKey ordGTDataConName = dcQual gHC_TYPES (fsLit "GT") ordGTDataConKey specTyConName :: Name specTyConName = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey eitherTyConName, leftDataConName, rightDataConName :: Name eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey leftDataConName = dcQual dATA_EITHER (fsLit "Left") leftDataConKey rightDataConName = dcQual dATA_EITHER (fsLit "Right") rightDataConKey -- Generics (types) v1TyConName, u1TyConName, par1TyConName, rec1TyConName, k1TyConName, m1TyConName, sumTyConName, prodTyConName, compTyConName, rTyConName, dTyConName, cTyConName, sTyConName, rec0TyConName, d1TyConName, c1TyConName, s1TyConName, noSelTyConName, repTyConName, rep1TyConName, uRecTyConName, uAddrTyConName, uCharTyConName, uDoubleTyConName, uFloatTyConName, uIntTyConName, uWordTyConName, prefixIDataConName, infixIDataConName, leftAssociativeDataConName, rightAssociativeDataConName, notAssociativeDataConName, sourceUnpackDataConName, sourceNoUnpackDataConName, noSourceUnpackednessDataConName, sourceLazyDataConName, sourceStrictDataConName, noSourceStrictnessDataConName, decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey rec1TyConName = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey k1TyConName = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey m1TyConName = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey sumTyConName = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey prodTyConName = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey compTyConName = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey rTyConName = tcQual gHC_GENERICS (fsLit "R") rTyConKey dTyConName = tcQual gHC_GENERICS (fsLit "D") dTyConKey cTyConName = tcQual gHC_GENERICS (fsLit "C") cTyConKey sTyConName = tcQual gHC_GENERICS (fsLit "S") sTyConKey rec0TyConName = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey uRecTyConName = tcQual gHC_GENERICS (fsLit "URec") uRecTyConKey uAddrTyConName = tcQual gHC_GENERICS (fsLit "UAddr") uAddrTyConKey uCharTyConName = tcQual gHC_GENERICS (fsLit "UChar") uCharTyConKey uDoubleTyConName = tcQual gHC_GENERICS (fsLit "UDouble") uDoubleTyConKey uFloatTyConName = tcQual gHC_GENERICS (fsLit "UFloat") uFloatTyConKey uIntTyConName = tcQual gHC_GENERICS (fsLit "UInt") uIntTyConKey uWordTyConName = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey prefixIDataConName = dcQual gHC_GENERICS (fsLit "PrefixI") prefixIDataConKey infixIDataConName = dcQual gHC_GENERICS (fsLit "InfixI") infixIDataConKey leftAssociativeDataConName = dcQual gHC_GENERICS (fsLit "LeftAssociative") leftAssociativeDataConKey rightAssociativeDataConName = dcQual gHC_GENERICS (fsLit "RightAssociative") rightAssociativeDataConKey notAssociativeDataConName = dcQual gHC_GENERICS (fsLit "NotAssociative") notAssociativeDataConKey sourceUnpackDataConName = dcQual gHC_GENERICS (fsLit "SourceUnpack") sourceUnpackDataConKey sourceNoUnpackDataConName = dcQual gHC_GENERICS (fsLit "SourceNoUnpack") sourceNoUnpackDataConKey noSourceUnpackednessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey sourceLazyDataConName = dcQual gHC_GENERICS (fsLit "SourceLazy") sourceLazyDataConKey sourceStrictDataConName = dcQual gHC_GENERICS (fsLit "SourceStrict") sourceStrictDataConKey noSourceStrictnessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceStrictness") noSourceStrictnessDataConKey decidedLazyDataConName = dcQual gHC_GENERICS (fsLit "DecidedLazy") decidedLazyDataConKey decidedStrictDataConName = dcQual gHC_GENERICS (fsLit "DecidedStrict") decidedStrictDataConKey decidedUnpackDataConName = dcQual gHC_GENERICS (fsLit "DecidedUnpack") decidedUnpackDataConKey metaDataDataConName = dcQual gHC_GENERICS (fsLit "MetaData") metaDataDataConKey metaConsDataConName = dcQual gHC_GENERICS (fsLit "MetaCons") metaConsDataConKey metaSelDataConName = dcQual gHC_GENERICS (fsLit "MetaSel") metaSelDataConKey -- Primitive Int divIntName, modIntName :: Name divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey -- Base strings Strings unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName :: Name unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey -- The 'inline' function inlineIdName :: Name inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey -- Base classes (Eq, Ord, Functor) fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey eqName = varQual gHC_CLASSES (fsLit "==") eqClassOpKey ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey geName = varQual gHC_CLASSES (fsLit ">=") geClassOpKey functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey fmapName = varQual gHC_BASE (fsLit "fmap") fmapClassOpKey -- Class Monad monadClassName, thenMName, bindMName, returnMName :: Name monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey thenMName = varQual gHC_BASE (fsLit ">>") thenMClassOpKey bindMName = varQual gHC_BASE (fsLit ">>=") bindMClassOpKey returnMName = varQual gHC_BASE (fsLit "return") returnMClassOpKey -- Class MonadFail monadFailClassName, failMName :: Name monadFailClassName = clsQual mONAD_FAIL (fsLit "MonadFail") monadFailClassKey failMName = varQual mONAD_FAIL (fsLit "fail") failMClassOpKey -- Class Applicative applicativeClassName, pureAName, apAName, thenAName :: Name applicativeClassName = clsQual gHC_BASE (fsLit "Applicative") applicativeClassKey apAName = varQual gHC_BASE (fsLit "<*>") apAClassOpKey pureAName = varQual gHC_BASE (fsLit "pure") pureAClassOpKey thenAName = varQual gHC_BASE (fsLit "*>") thenAClassOpKey -- Classes (Foldable, Traversable) foldableClassName, traversableClassName :: Name foldableClassName = clsQual dATA_FOLDABLE (fsLit "Foldable") foldableClassKey traversableClassName = clsQual dATA_TRAVERSABLE (fsLit "Traversable") traversableClassKey -- Classes (Semigroup, Monoid) semigroupClassName, sappendName :: Name semigroupClassName = clsQual gHC_BASE (fsLit "Semigroup") semigroupClassKey sappendName = varQual gHC_BASE (fsLit "<>") sappendClassOpKey monoidClassName, memptyName, mappendName, mconcatName :: Name monoidClassName = clsQual gHC_BASE (fsLit "Monoid") monoidClassKey memptyName = varQual gHC_BASE (fsLit "mempty") memptyClassOpKey mappendName = varQual gHC_BASE (fsLit "mappend") mappendClassOpKey mconcatName = varQual gHC_BASE (fsLit "mconcat") mconcatClassOpKey -- AMP additions joinMName, alternativeClassName :: Name joinMName = varQual gHC_BASE (fsLit "join") joinMIdKey alternativeClassName = clsQual mONAD (fsLit "Alternative") alternativeClassKey -- joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey, alternativeClassKey :: Unique joinMIdKey = mkPreludeMiscIdUnique 750 apAClassOpKey = mkPreludeMiscIdUnique 751 -- <*> pureAClassOpKey = mkPreludeMiscIdUnique 752 thenAClassOpKey = mkPreludeMiscIdUnique 753 alternativeClassKey = mkPreludeMiscIdUnique 754 -- Functions for GHC extensions groupWithName :: Name groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey -- Random PrelBase functions fromStringName, otherwiseIdName, foldrName, buildName, augmentName, mapName, appendName, assertName, breakpointName, breakpointCondName, opaqueTyConName, dollarName :: Name dollarName = varQual gHC_BASE (fsLit "$") dollarIdKey otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey foldrName = varQual gHC_BASE (fsLit "foldr") foldrIdKey buildName = varQual gHC_BASE (fsLit "build") buildIdKey augmentName = varQual gHC_BASE (fsLit "augment") augmentIdKey mapName = varQual gHC_BASE (fsLit "map") mapIdKey appendName = varQual gHC_BASE (fsLit "++") appendIdKey assertName = varQual gHC_BASE (fsLit "assert") assertIdKey breakpointName = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey opaqueTyConName = tcQual gHC_BASE (fsLit "Opaque") opaqueTyConKey fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey -- PrelTup fstName, sndName :: Name fstName = varQual dATA_TUPLE (fsLit "fst") fstIdKey sndName = varQual dATA_TUPLE (fsLit "snd") sndIdKey -- Module GHC.Num numClassName, fromIntegerName, minusName, negateName :: Name numClassName = clsQual gHC_NUM (fsLit "Num") numClassKey fromIntegerName = varQual gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey minusName = varQual gHC_NUM (fsLit "-") minusClassOpKey negateName = varQual gHC_NUM (fsLit "negate") negateClassOpKey integerTyConName, mkIntegerName, integerSDataConName, integerToWord64Name, integerToInt64Name, word64ToIntegerName, int64ToIntegerName, plusIntegerName, timesIntegerName, smallIntegerName, wordToIntegerName, integerToWordName, integerToIntName, minusIntegerName, negateIntegerName, eqIntegerPrimName, neqIntegerPrimName, absIntegerName, signumIntegerName, leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName, compareIntegerName, quotRemIntegerName, divModIntegerName, quotIntegerName, remIntegerName, divIntegerName, modIntegerName, floatFromIntegerName, doubleFromIntegerName, encodeFloatIntegerName, encodeDoubleIntegerName, decodeDoubleIntegerName, gcdIntegerName, lcmIntegerName, andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, shiftLIntegerName, shiftRIntegerName, bitIntegerName :: Name integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey integerSDataConName = dcQual gHC_INTEGER_TYPE (fsLit "S#") integerSDataConKey mkIntegerName = varQual gHC_INTEGER_TYPE (fsLit "mkInteger") mkIntegerIdKey integerToWord64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64") integerToWord64IdKey integerToInt64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64") integerToInt64IdKey word64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "word64ToInteger") word64ToIntegerIdKey int64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "int64ToInteger") int64ToIntegerIdKey plusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "plusInteger") plusIntegerIdKey timesIntegerName = varQual gHC_INTEGER_TYPE (fsLit "timesInteger") timesIntegerIdKey smallIntegerName = varQual gHC_INTEGER_TYPE (fsLit "smallInteger") smallIntegerIdKey wordToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "wordToInteger") wordToIntegerIdKey integerToWordName = varQual gHC_INTEGER_TYPE (fsLit "integerToWord") integerToWordIdKey integerToIntName = varQual gHC_INTEGER_TYPE (fsLit "integerToInt") integerToIntIdKey minusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "minusInteger") minusIntegerIdKey negateIntegerName = varQual gHC_INTEGER_TYPE (fsLit "negateInteger") negateIntegerIdKey eqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "eqInteger#") eqIntegerPrimIdKey neqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "neqInteger#") neqIntegerPrimIdKey absIntegerName = varQual gHC_INTEGER_TYPE (fsLit "absInteger") absIntegerIdKey signumIntegerName = varQual gHC_INTEGER_TYPE (fsLit "signumInteger") signumIntegerIdKey leIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "leInteger#") leIntegerPrimIdKey gtIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "gtInteger#") gtIntegerPrimIdKey ltIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "ltInteger#") ltIntegerPrimIdKey geIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "geInteger#") geIntegerPrimIdKey compareIntegerName = varQual gHC_INTEGER_TYPE (fsLit "compareInteger") compareIntegerIdKey quotRemIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger") quotRemIntegerIdKey divModIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divModInteger") divModIntegerIdKey quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quotIntegerIdKey remIntegerName = varQual gHC_INTEGER_TYPE (fsLit "remInteger") remIntegerIdKey divIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divInteger") divIntegerIdKey modIntegerName = varQual gHC_INTEGER_TYPE (fsLit "modInteger") modIntegerIdKey floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger") floatFromIntegerIdKey doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger") doubleFromIntegerIdKey encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger") encodeFloatIntegerIdKey encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleInteger") encodeDoubleIntegerIdKey decodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "decodeDoubleInteger") decodeDoubleIntegerIdKey gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey lcmIntegerName = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger") lcmIntegerIdKey andIntegerName = varQual gHC_INTEGER_TYPE (fsLit "andInteger") andIntegerIdKey orIntegerName = varQual gHC_INTEGER_TYPE (fsLit "orInteger") orIntegerIdKey xorIntegerName = varQual gHC_INTEGER_TYPE (fsLit "xorInteger") xorIntegerIdKey complementIntegerName = varQual gHC_INTEGER_TYPE (fsLit "complementInteger") complementIntegerIdKey shiftLIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftLInteger") shiftLIntegerIdKey shiftRIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftRInteger") shiftRIntegerIdKey bitIntegerName = varQual gHC_INTEGER_TYPE (fsLit "bitInteger") bitIntegerIdKey -- GHC.Natural types naturalTyConName, naturalSDataConName :: Name naturalTyConName = tcQual gHC_NATURAL (fsLit "Natural") naturalTyConKey naturalSDataConName = dcQual gHC_NATURAL (fsLit "NatS#") naturalSDataConKey naturalFromIntegerName :: Name naturalFromIntegerName = varQual gHC_NATURAL (fsLit "naturalFromInteger") naturalFromIntegerIdKey naturalToIntegerName, plusNaturalName, minusNaturalName, timesNaturalName, mkNaturalName, wordToNaturalName :: Name naturalToIntegerName = varQual gHC_NATURAL (fsLit "naturalToInteger") naturalToIntegerIdKey plusNaturalName = varQual gHC_NATURAL (fsLit "plusNatural") plusNaturalIdKey minusNaturalName = varQual gHC_NATURAL (fsLit "minusNatural") minusNaturalIdKey timesNaturalName = varQual gHC_NATURAL (fsLit "timesNatural") timesNaturalIdKey mkNaturalName = varQual gHC_NATURAL (fsLit "mkNatural") mkNaturalIdKey wordToNaturalName = varQual gHC_NATURAL (fsLit "wordToNatural#") wordToNaturalIdKey -- GHC.Real types and classes rationalTyConName, ratioTyConName, ratioDataConName, realClassName, integralClassName, realFracClassName, fractionalClassName, fromRationalName, toIntegerName, toRationalName, fromIntegralName, realToFracName :: Name rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey ratioDataConName = dcQual gHC_REAL (fsLit ":%") ratioDataConKey realClassName = clsQual gHC_REAL (fsLit "Real") realClassKey integralClassName = clsQual gHC_REAL (fsLit "Integral") integralClassKey realFracClassName = clsQual gHC_REAL (fsLit "RealFrac") realFracClassKey fractionalClassName = clsQual gHC_REAL (fsLit "Fractional") fractionalClassKey fromRationalName = varQual gHC_REAL (fsLit "fromRational") fromRationalClassOpKey toIntegerName = varQual gHC_REAL (fsLit "toInteger") toIntegerClassOpKey toRationalName = varQual gHC_REAL (fsLit "toRational") toRationalClassOpKey fromIntegralName = varQual gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey realToFracName = varQual gHC_REAL (fsLit "realToFrac") realToFracIdKey -- PrelFloat classes floatingClassName, realFloatClassName :: Name floatingClassName = clsQual gHC_FLOAT (fsLit "Floating") floatingClassKey realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey -- other GHC.Float functions rationalToFloatName, rationalToDoubleName :: Name rationalToFloatName = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey -- Class Ix ixClassName :: Name ixClassName = clsQual gHC_IX (fsLit "Ix") ixClassKey -- Typeable representation types trModuleTyConName , trModuleDataConName , trNameTyConName , trNameSDataConName , trNameDDataConName , trTyConTyConName , trTyConDataConName :: Name trModuleTyConName = tcQual gHC_TYPES (fsLit "Module") trModuleTyConKey trModuleDataConName = dcQual gHC_TYPES (fsLit "Module") trModuleDataConKey trNameTyConName = tcQual gHC_TYPES (fsLit "TrName") trNameTyConKey trNameSDataConName = dcQual gHC_TYPES (fsLit "TrNameS") trNameSDataConKey trNameDDataConName = dcQual gHC_TYPES (fsLit "TrNameD") trNameDDataConKey trTyConTyConName = tcQual gHC_TYPES (fsLit "TyCon") trTyConTyConKey trTyConDataConName = dcQual gHC_TYPES (fsLit "TyCon") trTyConDataConKey kindRepTyConName , kindRepTyConAppDataConName , kindRepVarDataConName , kindRepAppDataConName , kindRepFunDataConName , kindRepTYPEDataConName , kindRepTypeLitSDataConName , kindRepTypeLitDDataConName :: Name kindRepTyConName = tcQual gHC_TYPES (fsLit "KindRep") kindRepTyConKey kindRepTyConAppDataConName = dcQual gHC_TYPES (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey kindRepVarDataConName = dcQual gHC_TYPES (fsLit "KindRepVar") kindRepVarDataConKey kindRepAppDataConName = dcQual gHC_TYPES (fsLit "KindRepApp") kindRepAppDataConKey kindRepFunDataConName = dcQual gHC_TYPES (fsLit "KindRepFun") kindRepFunDataConKey kindRepTYPEDataConName = dcQual gHC_TYPES (fsLit "KindRepTYPE") kindRepTYPEDataConKey kindRepTypeLitSDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey kindRepTypeLitDDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitD") kindRepTypeLitDDataConKey typeLitSortTyConName , typeLitSymbolDataConName , typeLitNatDataConName :: Name typeLitSortTyConName = tcQual gHC_TYPES (fsLit "TypeLitSort") typeLitSortTyConKey typeLitSymbolDataConName = dcQual gHC_TYPES (fsLit "TypeLitSymbol") typeLitSymbolDataConKey typeLitNatDataConName = dcQual gHC_TYPES (fsLit "TypeLitNat") typeLitNatDataConKey -- Class Typeable, and functions for constructing `Typeable` dictionaries typeableClassName , typeRepTyConName , someTypeRepTyConName , someTypeRepDataConName , mkTrTypeName , mkTrConName , mkTrAppName , mkTrFunName , typeRepIdName , typeNatTypeRepName , typeSymbolTypeRepName , trGhcPrimModuleName :: Name typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey typeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "TypeRep") typeRepTyConKey someTypeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepTyConKey someTypeRepDataConName = dcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepDataConKey typeRepIdName = varQual tYPEABLE_INTERNAL (fsLit "typeRep#") typeRepIdKey mkTrTypeName = varQual tYPEABLE_INTERNAL (fsLit "mkTrType") mkTrTypeKey mkTrConName = varQual tYPEABLE_INTERNAL (fsLit "mkTrCon") mkTrConKey mkTrAppName = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp") mkTrAppKey mkTrFunName = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun") mkTrFunKey typeNatTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey -- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types) -- See Note [Grand plan for Typeable] in TcTypeable. trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey -- Typeable KindReps for some common cases starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName :: Name starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey -- Custom type errors errorMessageTypeErrorFamName , typeErrorTextDataConName , typeErrorAppendDataConName , typeErrorVAppendDataConName , typeErrorShowTypeDataConName :: Name errorMessageTypeErrorFamName = tcQual gHC_TYPELITS (fsLit "TypeError") errorMessageTypeErrorFamKey typeErrorTextDataConName = dcQual gHC_TYPELITS (fsLit "Text") typeErrorTextDataConKey typeErrorAppendDataConName = dcQual gHC_TYPELITS (fsLit ":<>:") typeErrorAppendDataConKey typeErrorVAppendDataConName = dcQual gHC_TYPELITS (fsLit ":$$:") typeErrorVAppendDataConKey typeErrorShowTypeDataConName = dcQual gHC_TYPELITS (fsLit "ShowType") typeErrorShowTypeDataConKey -- Dynamic toDynName :: Name toDynName = varQual dYNAMIC (fsLit "toDyn") toDynIdKey -- Class Data dataClassName :: Name dataClassName = clsQual gENERICS (fsLit "Data") dataClassKey -- Error module assertErrorName :: Name assertErrorName = varQual gHC_IO_Exception (fsLit "assertError") assertErrorIdKey -- Debug.Trace traceName :: Name traceName = varQual dEBUG_TRACE (fsLit "trace") traceKey -- Enum module (Enum, Bounded) enumClassName, enumFromName, enumFromToName, enumFromThenName, enumFromThenToName, boundedClassName :: Name enumClassName = clsQual gHC_ENUM (fsLit "Enum") enumClassKey enumFromName = varQual gHC_ENUM (fsLit "enumFrom") enumFromClassOpKey enumFromToName = varQual gHC_ENUM (fsLit "enumFromTo") enumFromToClassOpKey enumFromThenName = varQual gHC_ENUM (fsLit "enumFromThen") enumFromThenClassOpKey enumFromThenToName = varQual gHC_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey boundedClassName = clsQual gHC_ENUM (fsLit "Bounded") boundedClassKey -- List functions concatName, filterName, zipName :: Name concatName = varQual gHC_LIST (fsLit "concat") concatIdKey filterName = varQual gHC_LIST (fsLit "filter") filterIdKey zipName = varQual gHC_LIST (fsLit "zip") zipIdKey -- Overloaded lists isListClassName, fromListName, fromListNName, toListName :: Name isListClassName = clsQual gHC_EXTS (fsLit "IsList") isListClassKey fromListName = varQual gHC_EXTS (fsLit "fromList") fromListClassOpKey fromListNName = varQual gHC_EXTS (fsLit "fromListN") fromListNClassOpKey toListName = varQual gHC_EXTS (fsLit "toList") toListClassOpKey -- Class Show showClassName :: Name showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey -- Class Read readClassName :: Name readClassName = clsQual gHC_READ (fsLit "Read") readClassKey -- Classes Generic and Generic1, Datatype, Constructor and Selector genClassName, gen1ClassName, datatypeClassName, constructorClassName, selectorClassName :: Name genClassName = clsQual gHC_GENERICS (fsLit "Generic") genClassKey gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey genericClassNames :: [Name] genericClassNames = [genClassName, gen1ClassName] -- GHCi things ghciIoClassName, ghciStepIoMName :: Name ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey ghciStepIoMName = varQual gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey -- IO things ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName, failIOName :: Name ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey ioDataConName = dcQual gHC_TYPES (fsLit "IO") ioDataConKey thenIOName = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey bindIOName = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey returnIOName = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey failIOName = varQual gHC_IO (fsLit "failIO") failIOIdKey -- IO things printName :: Name printName = varQual sYSTEM_IO (fsLit "print") printIdKey -- Int, Word, and Addr things int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name int8TyConName = tcQual gHC_INT (fsLit "Int8") int8TyConKey int16TyConName = tcQual gHC_INT (fsLit "Int16") int16TyConKey int32TyConName = tcQual gHC_INT (fsLit "Int32") int32TyConKey int64TyConName = tcQual gHC_INT (fsLit "Int64") int64TyConKey -- Word module word16TyConName, word32TyConName, word64TyConName :: Name word16TyConName = tcQual gHC_WORD (fsLit "Word16") word16TyConKey word32TyConName = tcQual gHC_WORD (fsLit "Word32") word32TyConKey word64TyConName = tcQual gHC_WORD (fsLit "Word64") word64TyConKey -- PrelPtr module ptrTyConName, funPtrTyConName :: Name ptrTyConName = tcQual gHC_PTR (fsLit "Ptr") ptrTyConKey funPtrTyConName = tcQual gHC_PTR (fsLit "FunPtr") funPtrTyConKey -- Foreign objects and weak pointers stablePtrTyConName, newStablePtrName :: Name stablePtrTyConName = tcQual gHC_STABLE (fsLit "StablePtr") stablePtrTyConKey newStablePtrName = varQual gHC_STABLE (fsLit "newStablePtr") newStablePtrIdKey -- Recursive-do notation monadFixClassName, mfixName :: Name monadFixClassName = clsQual mONAD_FIX (fsLit "MonadFix") monadFixClassKey mfixName = varQual mONAD_FIX (fsLit "mfix") mfixIdKey -- Arrow notation arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name arrAName = varQual aRROW (fsLit "arr") arrAIdKey composeAName = varQual gHC_DESUGAR (fsLit ">>>") composeAIdKey firstAName = varQual aRROW (fsLit "first") firstAIdKey appAName = varQual aRROW (fsLit "app") appAIdKey choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey loopAName = varQual aRROW (fsLit "loop") loopAIdKey -- Monad comprehensions guardMName, liftMName, mzipName :: Name guardMName = varQual mONAD (fsLit "guard") guardMIdKey liftMName = varQual mONAD (fsLit "liftM") liftMIdKey mzipName = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey -- Annotation type checking toAnnotationWrapperName :: Name toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey -- Other classes, needed for type defaulting monadPlusClassName, randomClassName, randomGenClassName, isStringClassName :: Name monadPlusClassName = clsQual mONAD (fsLit "MonadPlus") monadPlusClassKey randomClassName = clsQual rANDOM (fsLit "Random") randomClassKey randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey -- Type-level naturals knownNatClassName :: Name knownNatClassName = clsQual gHC_TYPENATS (fsLit "KnownNat") knownNatClassNameKey knownSymbolClassName :: Name knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey -- Overloaded labels isLabelClassName :: Name isLabelClassName = clsQual gHC_OVER_LABELS (fsLit "IsLabel") isLabelClassNameKey -- Implicit Parameters ipClassName :: Name ipClassName = clsQual gHC_CLASSES (fsLit "IP") ipClassKey -- Overloaded record fields hasFieldClassName :: Name hasFieldClassName = clsQual gHC_RECORDS (fsLit "HasField") hasFieldClassNameKey -- Source Locations callStackTyConName, emptyCallStackName, pushCallStackName, srcLocDataConName :: Name callStackTyConName = tcQual gHC_STACK_TYPES (fsLit "CallStack") callStackTyConKey emptyCallStackName = varQual gHC_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey pushCallStackName = varQual gHC_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey srcLocDataConName = dcQual gHC_STACK_TYPES (fsLit "SrcLoc") srcLocDataConKey -- plugins pLUGINS :: Module pLUGINS = mkThisGhcModule (fsLit "Plugins") pluginTyConName :: Name pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey frontendPluginTyConName :: Name frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey -- Static pointers makeStaticName :: Name makeStaticName = varQual gHC_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey staticPtrInfoTyConName :: Name staticPtrInfoTyConName = tcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey staticPtrInfoDataConName :: Name staticPtrInfoDataConName = dcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey staticPtrTyConName :: Name staticPtrTyConName = tcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey staticPtrDataConName :: Name staticPtrDataConName = dcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey fromStaticPtrName :: Name fromStaticPtrName = varQual gHC_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey fingerprintDataConName :: Name fingerprintDataConName = dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey {- ************************************************************************ * * \subsection{Local helpers} * * ************************************************************************ All these are original names; hence mkOrig -} varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name varQual = mk_known_key_name varName tcQual = mk_known_key_name tcName clsQual = mk_known_key_name clsName dcQual = mk_known_key_name dataName mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name mk_known_key_name space modu str unique = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan {- ************************************************************************ * * \subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@} * * ************************************************************************ --MetaHaskell extension hand allocate keys here -} boundedClassKey, enumClassKey, eqClassKey, floatingClassKey, fractionalClassKey, integralClassKey, monadClassKey, dataClassKey, functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey, realFloatClassKey, realFracClassKey, showClassKey, ixClassKey :: Unique boundedClassKey = mkPreludeClassUnique 1 enumClassKey = mkPreludeClassUnique 2 eqClassKey = mkPreludeClassUnique 3 floatingClassKey = mkPreludeClassUnique 5 fractionalClassKey = mkPreludeClassUnique 6 integralClassKey = mkPreludeClassUnique 7 monadClassKey = mkPreludeClassUnique 8 dataClassKey = mkPreludeClassUnique 9 functorClassKey = mkPreludeClassUnique 10 numClassKey = mkPreludeClassUnique 11 ordClassKey = mkPreludeClassUnique 12 readClassKey = mkPreludeClassUnique 13 realClassKey = mkPreludeClassUnique 14 realFloatClassKey = mkPreludeClassUnique 15 realFracClassKey = mkPreludeClassUnique 16 showClassKey = mkPreludeClassUnique 17 ixClassKey = mkPreludeClassUnique 18 typeableClassKey, typeable1ClassKey, typeable2ClassKey, typeable3ClassKey, typeable4ClassKey, typeable5ClassKey, typeable6ClassKey, typeable7ClassKey :: Unique typeableClassKey = mkPreludeClassUnique 20 typeable1ClassKey = mkPreludeClassUnique 21 typeable2ClassKey = mkPreludeClassUnique 22 typeable3ClassKey = mkPreludeClassUnique 23 typeable4ClassKey = mkPreludeClassUnique 24 typeable5ClassKey = mkPreludeClassUnique 25 typeable6ClassKey = mkPreludeClassUnique 26 typeable7ClassKey = mkPreludeClassUnique 27 monadFixClassKey :: Unique monadFixClassKey = mkPreludeClassUnique 28 monadFailClassKey :: Unique monadFailClassKey = mkPreludeClassUnique 29 monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique monadPlusClassKey = mkPreludeClassUnique 30 randomClassKey = mkPreludeClassUnique 31 randomGenClassKey = mkPreludeClassUnique 32 isStringClassKey :: Unique isStringClassKey = mkPreludeClassUnique 33 applicativeClassKey, foldableClassKey, traversableClassKey :: Unique applicativeClassKey = mkPreludeClassUnique 34 foldableClassKey = mkPreludeClassUnique 35 traversableClassKey = mkPreludeClassUnique 36 genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey, selectorClassKey :: Unique genClassKey = mkPreludeClassUnique 37 gen1ClassKey = mkPreludeClassUnique 38 datatypeClassKey = mkPreludeClassUnique 39 constructorClassKey = mkPreludeClassUnique 40 selectorClassKey = mkPreludeClassUnique 41 -- KnownNat: see Note [KnowNat & KnownSymbol and EvLit] in TcEvidence knownNatClassNameKey :: Unique knownNatClassNameKey = mkPreludeClassUnique 42 -- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in TcEvidence knownSymbolClassNameKey :: Unique knownSymbolClassNameKey = mkPreludeClassUnique 43 ghciIoClassKey :: Unique ghciIoClassKey = mkPreludeClassUnique 44 isLabelClassNameKey :: Unique isLabelClassNameKey = mkPreludeClassUnique 45 semigroupClassKey, monoidClassKey :: Unique semigroupClassKey = mkPreludeClassUnique 46 monoidClassKey = mkPreludeClassUnique 47 -- Implicit Parameters ipClassKey :: Unique ipClassKey = mkPreludeClassUnique 48 -- Overloaded record fields hasFieldClassNameKey :: Unique hasFieldClassNameKey = mkPreludeClassUnique 49 ---------------- Template Haskell ------------------- -- THNames.hs: USES ClassUniques 200-299 ----------------------------------------------------- {- ************************************************************************ * * \subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@} * * ************************************************************************ -} addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey, doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey, intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey, integerTyConKey, naturalTyConKey, listTyConKey, foreignObjPrimTyConKey, maybeTyConKey, weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey, eqTyConKey, heqTyConKey, smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey :: Unique addrPrimTyConKey = mkPreludeTyConUnique 1 arrayPrimTyConKey = mkPreludeTyConUnique 3 boolTyConKey = mkPreludeTyConUnique 4 byteArrayPrimTyConKey = mkPreludeTyConUnique 5 charPrimTyConKey = mkPreludeTyConUnique 7 charTyConKey = mkPreludeTyConUnique 8 doublePrimTyConKey = mkPreludeTyConUnique 9 doubleTyConKey = mkPreludeTyConUnique 10 floatPrimTyConKey = mkPreludeTyConUnique 11 floatTyConKey = mkPreludeTyConUnique 12 funTyConKey = mkPreludeTyConUnique 13 intPrimTyConKey = mkPreludeTyConUnique 14 intTyConKey = mkPreludeTyConUnique 15 int8PrimTyConKey = mkPreludeTyConUnique 16 int8TyConKey = mkPreludeTyConUnique 17 int16PrimTyConKey = mkPreludeTyConUnique 18 int16TyConKey = mkPreludeTyConUnique 19 int32PrimTyConKey = mkPreludeTyConUnique 20 int32TyConKey = mkPreludeTyConUnique 21 int64PrimTyConKey = mkPreludeTyConUnique 22 int64TyConKey = mkPreludeTyConUnique 23 integerTyConKey = mkPreludeTyConUnique 24 naturalTyConKey = mkPreludeTyConUnique 25 listTyConKey = mkPreludeTyConUnique 26 foreignObjPrimTyConKey = mkPreludeTyConUnique 27 maybeTyConKey = mkPreludeTyConUnique 28 weakPrimTyConKey = mkPreludeTyConUnique 29 mutableArrayPrimTyConKey = mkPreludeTyConUnique 30 mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 31 orderingTyConKey = mkPreludeTyConUnique 32 mVarPrimTyConKey = mkPreludeTyConUnique 33 ratioTyConKey = mkPreludeTyConUnique 34 rationalTyConKey = mkPreludeTyConUnique 35 realWorldTyConKey = mkPreludeTyConUnique 36 stablePtrPrimTyConKey = mkPreludeTyConUnique 37 stablePtrTyConKey = mkPreludeTyConUnique 38 eqTyConKey = mkPreludeTyConUnique 40 heqTyConKey = mkPreludeTyConUnique 41 arrayArrayPrimTyConKey = mkPreludeTyConUnique 42 mutableArrayArrayPrimTyConKey = mkPreludeTyConUnique 43 statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, mutVarPrimTyConKey, ioTyConKey, wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey, word16PrimTyConKey, word16TyConKey, word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey, liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, eqReprPrimTyConKey, eqPhantPrimTyConKey, voidPrimTyConKey, compactPrimTyConKey :: Unique statePrimTyConKey = mkPreludeTyConUnique 50 stableNamePrimTyConKey = mkPreludeTyConUnique 51 stableNameTyConKey = mkPreludeTyConUnique 52 eqPrimTyConKey = mkPreludeTyConUnique 53 eqReprPrimTyConKey = mkPreludeTyConUnique 54 eqPhantPrimTyConKey = mkPreludeTyConUnique 55 mutVarPrimTyConKey = mkPreludeTyConUnique 56 ioTyConKey = mkPreludeTyConUnique 57 voidPrimTyConKey = mkPreludeTyConUnique 58 wordPrimTyConKey = mkPreludeTyConUnique 59 wordTyConKey = mkPreludeTyConUnique 60 word8PrimTyConKey = mkPreludeTyConUnique 61 word8TyConKey = mkPreludeTyConUnique 62 word16PrimTyConKey = mkPreludeTyConUnique 63 word16TyConKey = mkPreludeTyConUnique 64 word32PrimTyConKey = mkPreludeTyConUnique 65 word32TyConKey = mkPreludeTyConUnique 66 word64PrimTyConKey = mkPreludeTyConUnique 67 word64TyConKey = mkPreludeTyConUnique 68 liftedConKey = mkPreludeTyConUnique 69 unliftedConKey = mkPreludeTyConUnique 70 anyBoxConKey = mkPreludeTyConUnique 71 kindConKey = mkPreludeTyConUnique 72 boxityConKey = mkPreludeTyConUnique 73 typeConKey = mkPreludeTyConUnique 74 threadIdPrimTyConKey = mkPreludeTyConUnique 75 bcoPrimTyConKey = mkPreludeTyConUnique 76 ptrTyConKey = mkPreludeTyConUnique 77 funPtrTyConKey = mkPreludeTyConUnique 78 tVarPrimTyConKey = mkPreludeTyConUnique 79 compactPrimTyConKey = mkPreludeTyConUnique 80 -- dotnet interop objectTyConKey :: Unique objectTyConKey = mkPreludeTyConUnique 83 eitherTyConKey :: Unique eitherTyConKey = mkPreludeTyConUnique 84 -- Kind constructors liftedTypeKindTyConKey, tYPETyConKey, constraintKindTyConKey, runtimeRepTyConKey, vecCountTyConKey, vecElemTyConKey :: Unique liftedTypeKindTyConKey = mkPreludeTyConUnique 87 tYPETyConKey = mkPreludeTyConUnique 88 constraintKindTyConKey = mkPreludeTyConUnique 92 runtimeRepTyConKey = mkPreludeTyConUnique 95 vecCountTyConKey = mkPreludeTyConUnique 96 vecElemTyConKey = mkPreludeTyConUnique 97 pluginTyConKey, frontendPluginTyConKey :: Unique pluginTyConKey = mkPreludeTyConUnique 102 frontendPluginTyConKey = mkPreludeTyConUnique 103 unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey, opaqueTyConKey :: Unique unknownTyConKey = mkPreludeTyConUnique 129 unknown1TyConKey = mkPreludeTyConUnique 130 unknown2TyConKey = mkPreludeTyConUnique 131 unknown3TyConKey = mkPreludeTyConUnique 132 opaqueTyConKey = mkPreludeTyConUnique 133 -- Generics (Unique keys) v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, compTyConKey, rTyConKey, dTyConKey, cTyConKey, sTyConKey, rec0TyConKey, d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey, repTyConKey, rep1TyConKey, uRecTyConKey, uAddrTyConKey, uCharTyConKey, uDoubleTyConKey, uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique v1TyConKey = mkPreludeTyConUnique 135 u1TyConKey = mkPreludeTyConUnique 136 par1TyConKey = mkPreludeTyConUnique 137 rec1TyConKey = mkPreludeTyConUnique 138 k1TyConKey = mkPreludeTyConUnique 139 m1TyConKey = mkPreludeTyConUnique 140 sumTyConKey = mkPreludeTyConUnique 141 prodTyConKey = mkPreludeTyConUnique 142 compTyConKey = mkPreludeTyConUnique 143 rTyConKey = mkPreludeTyConUnique 144 dTyConKey = mkPreludeTyConUnique 146 cTyConKey = mkPreludeTyConUnique 147 sTyConKey = mkPreludeTyConUnique 148 rec0TyConKey = mkPreludeTyConUnique 149 d1TyConKey = mkPreludeTyConUnique 151 c1TyConKey = mkPreludeTyConUnique 152 s1TyConKey = mkPreludeTyConUnique 153 noSelTyConKey = mkPreludeTyConUnique 154 repTyConKey = mkPreludeTyConUnique 155 rep1TyConKey = mkPreludeTyConUnique 156 uRecTyConKey = mkPreludeTyConUnique 157 uAddrTyConKey = mkPreludeTyConUnique 158 uCharTyConKey = mkPreludeTyConUnique 159 uDoubleTyConKey = mkPreludeTyConUnique 160 uFloatTyConKey = mkPreludeTyConUnique 161 uIntTyConKey = mkPreludeTyConUnique 162 uWordTyConKey = mkPreludeTyConUnique 163 -- Type-level naturals typeNatKindConNameKey, typeSymbolKindConNameKey, typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey, typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey , typeNatDivTyFamNameKey , typeNatModTyFamNameKey , typeNatLogTyFamNameKey :: Unique typeNatKindConNameKey = mkPreludeTyConUnique 164 typeSymbolKindConNameKey = mkPreludeTyConUnique 165 typeNatAddTyFamNameKey = mkPreludeTyConUnique 166 typeNatMulTyFamNameKey = mkPreludeTyConUnique 167 typeNatExpTyFamNameKey = mkPreludeTyConUnique 168 typeNatLeqTyFamNameKey = mkPreludeTyConUnique 169 typeNatSubTyFamNameKey = mkPreludeTyConUnique 170 typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171 typeNatCmpTyFamNameKey = mkPreludeTyConUnique 172 typeNatDivTyFamNameKey = mkPreludeTyConUnique 173 typeNatModTyFamNameKey = mkPreludeTyConUnique 174 typeNatLogTyFamNameKey = mkPreludeTyConUnique 175 -- Custom user type-errors errorMessageTypeErrorFamKey :: Unique errorMessageTypeErrorFamKey = mkPreludeTyConUnique 176 ntTyConKey:: Unique ntTyConKey = mkPreludeTyConUnique 177 coercibleTyConKey :: Unique coercibleTyConKey = mkPreludeTyConUnique 178 proxyPrimTyConKey :: Unique proxyPrimTyConKey = mkPreludeTyConUnique 179 specTyConKey :: Unique specTyConKey = mkPreludeTyConUnique 180 anyTyConKey :: Unique anyTyConKey = mkPreludeTyConUnique 181 smallArrayPrimTyConKey = mkPreludeTyConUnique 182 smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 183 staticPtrTyConKey :: Unique staticPtrTyConKey = mkPreludeTyConUnique 184 staticPtrInfoTyConKey :: Unique staticPtrInfoTyConKey = mkPreludeTyConUnique 185 callStackTyConKey :: Unique callStackTyConKey = mkPreludeTyConUnique 186 -- Typeables typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique typeRepTyConKey = mkPreludeTyConUnique 187 someTypeRepTyConKey = mkPreludeTyConUnique 188 someTypeRepDataConKey = mkPreludeTyConUnique 189 typeSymbolAppendFamNameKey :: Unique typeSymbolAppendFamNameKey = mkPreludeTyConUnique 190 ---------------- Template Haskell ------------------- -- THNames.hs: USES TyConUniques 200-299 ----------------------------------------------------- ----------------------- SIMD ------------------------ -- USES TyConUniques 300-399 ----------------------------------------------------- #include "primop-vector-uniques.hs-incl" {- ************************************************************************ * * \subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@} * * ************************************************************************ -} charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey, ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, word8DataConKey, ioDataConKey, integerDataConKey, heqDataConKey, coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey :: Unique charDataConKey = mkPreludeDataConUnique 1 consDataConKey = mkPreludeDataConUnique 2 doubleDataConKey = mkPreludeDataConUnique 3 falseDataConKey = mkPreludeDataConUnique 4 floatDataConKey = mkPreludeDataConUnique 5 intDataConKey = mkPreludeDataConUnique 6 integerSDataConKey = mkPreludeDataConUnique 7 nothingDataConKey = mkPreludeDataConUnique 8 justDataConKey = mkPreludeDataConUnique 9 eqDataConKey = mkPreludeDataConUnique 10 nilDataConKey = mkPreludeDataConUnique 11 ratioDataConKey = mkPreludeDataConUnique 12 word8DataConKey = mkPreludeDataConUnique 13 stableNameDataConKey = mkPreludeDataConUnique 14 trueDataConKey = mkPreludeDataConUnique 15 wordDataConKey = mkPreludeDataConUnique 16 ioDataConKey = mkPreludeDataConUnique 17 integerDataConKey = mkPreludeDataConUnique 18 heqDataConKey = mkPreludeDataConUnique 19 -- Generic data constructors crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique crossDataConKey = mkPreludeDataConUnique 20 inlDataConKey = mkPreludeDataConUnique 21 inrDataConKey = mkPreludeDataConUnique 22 genUnitDataConKey = mkPreludeDataConUnique 23 leftDataConKey, rightDataConKey :: Unique leftDataConKey = mkPreludeDataConUnique 25 rightDataConKey = mkPreludeDataConUnique 26 ordLTDataConKey, ordEQDataConKey, ordGTDataConKey :: Unique ordLTDataConKey = mkPreludeDataConUnique 27 ordEQDataConKey = mkPreludeDataConUnique 28 ordGTDataConKey = mkPreludeDataConUnique 29 coercibleDataConKey = mkPreludeDataConUnique 32 staticPtrDataConKey :: Unique staticPtrDataConKey = mkPreludeDataConUnique 33 staticPtrInfoDataConKey :: Unique staticPtrInfoDataConKey = mkPreludeDataConUnique 34 fingerprintDataConKey :: Unique fingerprintDataConKey = mkPreludeDataConUnique 35 srcLocDataConKey :: Unique srcLocDataConKey = mkPreludeDataConUnique 37 trTyConTyConKey, trTyConDataConKey, trModuleTyConKey, trModuleDataConKey, trNameTyConKey, trNameSDataConKey, trNameDDataConKey, trGhcPrimModuleKey, kindRepTyConKey, typeLitSortTyConKey :: Unique trTyConTyConKey = mkPreludeDataConUnique 40 trTyConDataConKey = mkPreludeDataConUnique 41 trModuleTyConKey = mkPreludeDataConUnique 42 trModuleDataConKey = mkPreludeDataConUnique 43 trNameTyConKey = mkPreludeDataConUnique 44 trNameSDataConKey = mkPreludeDataConUnique 45 trNameDDataConKey = mkPreludeDataConUnique 46 trGhcPrimModuleKey = mkPreludeDataConUnique 47 kindRepTyConKey = mkPreludeDataConUnique 48 typeLitSortTyConKey = mkPreludeDataConUnique 49 typeErrorTextDataConKey, typeErrorAppendDataConKey, typeErrorVAppendDataConKey, typeErrorShowTypeDataConKey :: Unique typeErrorTextDataConKey = mkPreludeDataConUnique 50 typeErrorAppendDataConKey = mkPreludeDataConUnique 51 typeErrorVAppendDataConKey = mkPreludeDataConUnique 52 typeErrorShowTypeDataConKey = mkPreludeDataConUnique 53 prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey, rightAssociativeDataConKey, notAssociativeDataConKey, sourceUnpackDataConKey, sourceNoUnpackDataConKey, noSourceUnpackednessDataConKey, sourceLazyDataConKey, sourceStrictDataConKey, noSourceStrictnessDataConKey, decidedLazyDataConKey, decidedStrictDataConKey, decidedUnpackDataConKey, metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique prefixIDataConKey = mkPreludeDataConUnique 54 infixIDataConKey = mkPreludeDataConUnique 55 leftAssociativeDataConKey = mkPreludeDataConUnique 56 rightAssociativeDataConKey = mkPreludeDataConUnique 57 notAssociativeDataConKey = mkPreludeDataConUnique 58 sourceUnpackDataConKey = mkPreludeDataConUnique 59 sourceNoUnpackDataConKey = mkPreludeDataConUnique 60 noSourceUnpackednessDataConKey = mkPreludeDataConUnique 61 sourceLazyDataConKey = mkPreludeDataConUnique 62 sourceStrictDataConKey = mkPreludeDataConUnique 63 noSourceStrictnessDataConKey = mkPreludeDataConUnique 64 decidedLazyDataConKey = mkPreludeDataConUnique 65 decidedStrictDataConKey = mkPreludeDataConUnique 66 decidedUnpackDataConKey = mkPreludeDataConUnique 67 metaDataDataConKey = mkPreludeDataConUnique 68 metaConsDataConKey = mkPreludeDataConUnique 69 metaSelDataConKey = mkPreludeDataConUnique 70 vecRepDataConKey, tupleRepDataConKey, sumRepDataConKey :: Unique vecRepDataConKey = mkPreludeDataConUnique 71 tupleRepDataConKey = mkPreludeDataConUnique 72 sumRepDataConKey = mkPreludeDataConUnique 73 -- See Note [Wiring in RuntimeRep] in TysWiredIn runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique] liftedRepDataConKey :: Unique runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys) = map mkPreludeDataConUnique [74..88] unliftedRepDataConKeys = vecRepDataConKey : tupleRepDataConKey : sumRepDataConKey : unliftedSimpleRepDataConKeys -- See Note [Wiring in RuntimeRep] in TysWiredIn -- VecCount vecCountDataConKeys :: [Unique] vecCountDataConKeys = map mkPreludeDataConUnique [89..94] -- See Note [Wiring in RuntimeRep] in TysWiredIn -- VecElem vecElemDataConKeys :: [Unique] vecElemDataConKeys = map mkPreludeDataConUnique [95..104] -- Typeable things kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey, kindRepFunDataConKey, kindRepTYPEDataConKey, kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey :: Unique kindRepTyConAppDataConKey = mkPreludeDataConUnique 105 kindRepVarDataConKey = mkPreludeDataConUnique 106 kindRepAppDataConKey = mkPreludeDataConUnique 107 kindRepFunDataConKey = mkPreludeDataConUnique 108 kindRepTYPEDataConKey = mkPreludeDataConUnique 109 kindRepTypeLitSDataConKey = mkPreludeDataConUnique 110 kindRepTypeLitDDataConKey = mkPreludeDataConUnique 111 typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique typeLitSymbolDataConKey = mkPreludeDataConUnique 112 typeLitNatDataConKey = mkPreludeDataConUnique 113 ---------------- Template Haskell ------------------- -- THNames.hs: USES DataUniques 200-250 ----------------------------------------------------- {- ************************************************************************ * * \subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)} * * ************************************************************************ -} wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey, buildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey, seqIdKey, eqStringIdKey, noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey, realWorldPrimIdKey, recConErrorIdKey, unpackCStringUtf8IdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey, unpackCStringIdKey, typeErrorIdKey, divIntIdKey, modIntIdKey, absentSumFieldErrorIdKey :: Unique wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders] absentErrorIdKey = mkPreludeMiscIdUnique 1 augmentIdKey = mkPreludeMiscIdUnique 2 appendIdKey = mkPreludeMiscIdUnique 3 buildIdKey = mkPreludeMiscIdUnique 4 errorIdKey = mkPreludeMiscIdUnique 5 foldrIdKey = mkPreludeMiscIdUnique 6 recSelErrorIdKey = mkPreludeMiscIdUnique 7 seqIdKey = mkPreludeMiscIdUnique 8 eqStringIdKey = mkPreludeMiscIdUnique 10 noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11 nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12 runtimeErrorIdKey = mkPreludeMiscIdUnique 13 patErrorIdKey = mkPreludeMiscIdUnique 14 realWorldPrimIdKey = mkPreludeMiscIdUnique 15 recConErrorIdKey = mkPreludeMiscIdUnique 16 unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 17 unpackCStringAppendIdKey = mkPreludeMiscIdUnique 18 unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 19 unpackCStringIdKey = mkPreludeMiscIdUnique 20 voidPrimIdKey = mkPreludeMiscIdUnique 21 typeErrorIdKey = mkPreludeMiscIdUnique 22 divIntIdKey = mkPreludeMiscIdUnique 23 modIntIdKey = mkPreludeMiscIdUnique 24 absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9 unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey, returnIOIdKey, newStablePtrIdKey, printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey, fstIdKey, sndIdKey, otherwiseIdKey, assertIdKey :: Unique unsafeCoerceIdKey = mkPreludeMiscIdUnique 30 concatIdKey = mkPreludeMiscIdUnique 31 filterIdKey = mkPreludeMiscIdUnique 32 zipIdKey = mkPreludeMiscIdUnique 33 bindIOIdKey = mkPreludeMiscIdUnique 34 returnIOIdKey = mkPreludeMiscIdUnique 35 newStablePtrIdKey = mkPreludeMiscIdUnique 36 printIdKey = mkPreludeMiscIdUnique 37 failIOIdKey = mkPreludeMiscIdUnique 38 nullAddrIdKey = mkPreludeMiscIdUnique 39 voidArgIdKey = mkPreludeMiscIdUnique 40 fstIdKey = mkPreludeMiscIdUnique 41 sndIdKey = mkPreludeMiscIdUnique 42 otherwiseIdKey = mkPreludeMiscIdUnique 43 assertIdKey = mkPreludeMiscIdUnique 44 mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey, integerToWordIdKey, integerToIntIdKey, integerToWord64IdKey, integerToInt64IdKey, word64ToIntegerIdKey, int64ToIntegerIdKey, plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey, negateIntegerIdKey, eqIntegerPrimIdKey, neqIntegerPrimIdKey, absIntegerIdKey, signumIntegerIdKey, leIntegerPrimIdKey, gtIntegerPrimIdKey, ltIntegerPrimIdKey, geIntegerPrimIdKey, compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey, quotIntegerIdKey, remIntegerIdKey, divIntegerIdKey, modIntegerIdKey, floatFromIntegerIdKey, doubleFromIntegerIdKey, encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey, decodeDoubleIntegerIdKey, gcdIntegerIdKey, lcmIntegerIdKey, andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey, shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique mkIntegerIdKey = mkPreludeMiscIdUnique 60 smallIntegerIdKey = mkPreludeMiscIdUnique 61 integerToWordIdKey = mkPreludeMiscIdUnique 62 integerToIntIdKey = mkPreludeMiscIdUnique 63 integerToWord64IdKey = mkPreludeMiscIdUnique 64 integerToInt64IdKey = mkPreludeMiscIdUnique 65 plusIntegerIdKey = mkPreludeMiscIdUnique 66 timesIntegerIdKey = mkPreludeMiscIdUnique 67 minusIntegerIdKey = mkPreludeMiscIdUnique 68 negateIntegerIdKey = mkPreludeMiscIdUnique 69 eqIntegerPrimIdKey = mkPreludeMiscIdUnique 70 neqIntegerPrimIdKey = mkPreludeMiscIdUnique 71 absIntegerIdKey = mkPreludeMiscIdUnique 72 signumIntegerIdKey = mkPreludeMiscIdUnique 73 leIntegerPrimIdKey = mkPreludeMiscIdUnique 74 gtIntegerPrimIdKey = mkPreludeMiscIdUnique 75 ltIntegerPrimIdKey = mkPreludeMiscIdUnique 76 geIntegerPrimIdKey = mkPreludeMiscIdUnique 77 compareIntegerIdKey = mkPreludeMiscIdUnique 78 quotIntegerIdKey = mkPreludeMiscIdUnique 79 remIntegerIdKey = mkPreludeMiscIdUnique 80 divIntegerIdKey = mkPreludeMiscIdUnique 81 modIntegerIdKey = mkPreludeMiscIdUnique 82 divModIntegerIdKey = mkPreludeMiscIdUnique 83 quotRemIntegerIdKey = mkPreludeMiscIdUnique 84 floatFromIntegerIdKey = mkPreludeMiscIdUnique 85 doubleFromIntegerIdKey = mkPreludeMiscIdUnique 86 encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 87 encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 88 gcdIntegerIdKey = mkPreludeMiscIdUnique 89 lcmIntegerIdKey = mkPreludeMiscIdUnique 90 andIntegerIdKey = mkPreludeMiscIdUnique 91 orIntegerIdKey = mkPreludeMiscIdUnique 92 xorIntegerIdKey = mkPreludeMiscIdUnique 93 complementIntegerIdKey = mkPreludeMiscIdUnique 94 shiftLIntegerIdKey = mkPreludeMiscIdUnique 95 shiftRIntegerIdKey = mkPreludeMiscIdUnique 96 wordToIntegerIdKey = mkPreludeMiscIdUnique 97 word64ToIntegerIdKey = mkPreludeMiscIdUnique 98 int64ToIntegerIdKey = mkPreludeMiscIdUnique 99 decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 100 rootMainKey, runMainKey :: Unique rootMainKey = mkPreludeMiscIdUnique 101 runMainKey = mkPreludeMiscIdUnique 102 thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique thenIOIdKey = mkPreludeMiscIdUnique 103 lazyIdKey = mkPreludeMiscIdUnique 104 assertErrorIdKey = mkPreludeMiscIdUnique 105 oneShotKey = mkPreludeMiscIdUnique 106 runRWKey = mkPreludeMiscIdUnique 107 traceKey :: Unique traceKey = mkPreludeMiscIdUnique 108 breakpointIdKey, breakpointCondIdKey :: Unique breakpointIdKey = mkPreludeMiscIdUnique 110 breakpointCondIdKey = mkPreludeMiscIdUnique 111 inlineIdKey, noinlineIdKey :: Unique inlineIdKey = mkPreludeMiscIdUnique 120 -- see below mapIdKey, groupWithIdKey, dollarIdKey :: Unique mapIdKey = mkPreludeMiscIdUnique 121 groupWithIdKey = mkPreludeMiscIdUnique 122 dollarIdKey = mkPreludeMiscIdUnique 123 coercionTokenIdKey :: Unique coercionTokenIdKey = mkPreludeMiscIdUnique 124 noinlineIdKey = mkPreludeMiscIdUnique 125 rationalToFloatIdKey, rationalToDoubleIdKey :: Unique rationalToFloatIdKey = mkPreludeMiscIdUnique 130 rationalToDoubleIdKey = mkPreludeMiscIdUnique 131 -- dotnet interop unmarshalObjectIdKey, marshalObjectIdKey, marshalStringIdKey, unmarshalStringIdKey, checkDotnetResNameIdKey :: Unique unmarshalObjectIdKey = mkPreludeMiscIdUnique 150 marshalObjectIdKey = mkPreludeMiscIdUnique 151 marshalStringIdKey = mkPreludeMiscIdUnique 152 unmarshalStringIdKey = mkPreludeMiscIdUnique 153 checkDotnetResNameIdKey = mkPreludeMiscIdUnique 154 undefinedKey :: Unique undefinedKey = mkPreludeMiscIdUnique 155 magicDictKey :: Unique magicDictKey = mkPreludeMiscIdUnique 156 coerceKey :: Unique coerceKey = mkPreludeMiscIdUnique 157 {- Certain class operations from Prelude classes. They get their own uniques so we can look them up easily when we want to conjure them up during type checking. -} -- Just a placeholder for unbound variables produced by the renamer: unboundKey :: Unique unboundKey = mkPreludeMiscIdUnique 158 fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, fmapClassOpKey :: Unique fromIntegerClassOpKey = mkPreludeMiscIdUnique 160 minusClassOpKey = mkPreludeMiscIdUnique 161 fromRationalClassOpKey = mkPreludeMiscIdUnique 162 enumFromClassOpKey = mkPreludeMiscIdUnique 163 enumFromThenClassOpKey = mkPreludeMiscIdUnique 164 enumFromToClassOpKey = mkPreludeMiscIdUnique 165 enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166 eqClassOpKey = mkPreludeMiscIdUnique 167 geClassOpKey = mkPreludeMiscIdUnique 168 negateClassOpKey = mkPreludeMiscIdUnique 169 bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=) thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>) fmapClassOpKey = mkPreludeMiscIdUnique 173 returnMClassOpKey = mkPreludeMiscIdUnique 174 -- Recursive do notation mfixIdKey :: Unique mfixIdKey = mkPreludeMiscIdUnique 175 -- MonadFail operations failMClassOpKey :: Unique failMClassOpKey = mkPreludeMiscIdUnique 176 -- Arrow notation arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey, loopAIdKey :: Unique arrAIdKey = mkPreludeMiscIdUnique 180 composeAIdKey = mkPreludeMiscIdUnique 181 -- >>> firstAIdKey = mkPreludeMiscIdUnique 182 appAIdKey = mkPreludeMiscIdUnique 183 choiceAIdKey = mkPreludeMiscIdUnique 184 -- ||| loopAIdKey = mkPreludeMiscIdUnique 185 fromStringClassOpKey :: Unique fromStringClassOpKey = mkPreludeMiscIdUnique 186 -- Annotation type checking toAnnotationWrapperIdKey :: Unique toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 187 -- Conversion functions fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique fromIntegralIdKey = mkPreludeMiscIdUnique 190 realToFracIdKey = mkPreludeMiscIdUnique 191 toIntegerClassOpKey = mkPreludeMiscIdUnique 192 toRationalClassOpKey = mkPreludeMiscIdUnique 193 -- Monad comprehensions guardMIdKey, liftMIdKey, mzipIdKey :: Unique guardMIdKey = mkPreludeMiscIdUnique 194 liftMIdKey = mkPreludeMiscIdUnique 195 mzipIdKey = mkPreludeMiscIdUnique 196 -- GHCi ghciStepIoMClassOpKey :: Unique ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 -- Overloaded lists isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique isListClassKey = mkPreludeMiscIdUnique 198 fromListClassOpKey = mkPreludeMiscIdUnique 199 fromListNClassOpKey = mkPreludeMiscIdUnique 500 toListClassOpKey = mkPreludeMiscIdUnique 501 proxyHashKey :: Unique proxyHashKey = mkPreludeMiscIdUnique 502 ---------------- Template Haskell ------------------- -- THNames.hs: USES IdUniques 200-499 ----------------------------------------------------- -- Used to make `Typeable` dictionaries mkTyConKey , mkTrTypeKey , mkTrConKey , mkTrAppKey , mkTrFunKey , typeNatTypeRepKey , typeSymbolTypeRepKey , typeRepIdKey :: Unique mkTyConKey = mkPreludeMiscIdUnique 503 mkTrTypeKey = mkPreludeMiscIdUnique 504 mkTrConKey = mkPreludeMiscIdUnique 505 mkTrAppKey = mkPreludeMiscIdUnique 506 typeNatTypeRepKey = mkPreludeMiscIdUnique 507 typeSymbolTypeRepKey = mkPreludeMiscIdUnique 508 typeRepIdKey = mkPreludeMiscIdUnique 509 mkTrFunKey = mkPreludeMiscIdUnique 510 -- Representations for primitive types trTYPEKey ,trTYPE'PtrRepLiftedKey , trRuntimeRepKey , tr'PtrRepLiftedKey :: Unique trTYPEKey = mkPreludeMiscIdUnique 511 trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 512 trRuntimeRepKey = mkPreludeMiscIdUnique 513 tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 514 -- KindReps for common cases starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique starKindRepKey = mkPreludeMiscIdUnique 520 starArrStarKindRepKey = mkPreludeMiscIdUnique 521 starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522 -- Dynamic toDynIdKey :: Unique toDynIdKey = mkPreludeMiscIdUnique 523 bitIntegerIdKey :: Unique bitIntegerIdKey = mkPreludeMiscIdUnique 550 heqSCSelIdKey, eqSCSelIdKey, coercibleSCSelIdKey :: Unique eqSCSelIdKey = mkPreludeMiscIdUnique 551 heqSCSelIdKey = mkPreludeMiscIdUnique 552 coercibleSCSelIdKey = mkPreludeMiscIdUnique 553 sappendClassOpKey :: Unique sappendClassOpKey = mkPreludeMiscIdUnique 554 memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique memptyClassOpKey = mkPreludeMiscIdUnique 555 mappendClassOpKey = mkPreludeMiscIdUnique 556 mconcatClassOpKey = mkPreludeMiscIdUnique 557 emptyCallStackKey, pushCallStackKey :: Unique emptyCallStackKey = mkPreludeMiscIdUnique 558 pushCallStackKey = mkPreludeMiscIdUnique 559 fromStaticPtrClassOpKey :: Unique fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560 makeStaticKey :: Unique makeStaticKey = mkPreludeMiscIdUnique 561 -- Natural naturalFromIntegerIdKey, naturalToIntegerIdKey, plusNaturalIdKey, minusNaturalIdKey, timesNaturalIdKey, mkNaturalIdKey, naturalSDataConKey, wordToNaturalIdKey :: Unique naturalFromIntegerIdKey = mkPreludeMiscIdUnique 562 naturalToIntegerIdKey = mkPreludeMiscIdUnique 563 plusNaturalIdKey = mkPreludeMiscIdUnique 564 minusNaturalIdKey = mkPreludeMiscIdUnique 565 timesNaturalIdKey = mkPreludeMiscIdUnique 566 mkNaturalIdKey = mkPreludeMiscIdUnique 567 naturalSDataConKey = mkPreludeMiscIdUnique 568 wordToNaturalIdKey = mkPreludeMiscIdUnique 569 {- ************************************************************************ * * \subsection[Class-std-groups]{Standard groups of Prelude classes} * * ************************************************************************ NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ even though every numeric class has these two as a superclass, because the list of ambiguous dictionaries hasn't been simplified. -} numericClassKeys :: [Unique] numericClassKeys = [ numClassKey , realClassKey , integralClassKey ] ++ fractionalClassKeys fractionalClassKeys :: [Unique] fractionalClassKeys = [ fractionalClassKey , floatingClassKey , realFracClassKey , realFloatClassKey ] -- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4), -- and are: "classes defined in the Prelude or a standard library" standardClassKeys :: [Unique] standardClassKeys = derivableClassKeys ++ numericClassKeys ++ [randomClassKey, randomGenClassKey, functorClassKey, monadClassKey, monadPlusClassKey, monadFailClassKey, semigroupClassKey, monoidClassKey, isStringClassKey, applicativeClassKey, foldableClassKey, traversableClassKey, alternativeClassKey ] {- @derivableClassKeys@ is also used in checking \tr{deriving} constructs (@TcDeriv@). -} derivableClassKeys :: [Unique] derivableClassKeys = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey, boundedClassKey, showClassKey, readClassKey ] -- These are the "interactive classes" that are consulted when doing -- defaulting. Does not include Num or IsString, which have special -- handling. interactiveClassNames :: [Name] interactiveClassNames = [ showClassName, eqClassName, ordClassName, foldableClassName , traversableClassName ] interactiveClassKeys :: [Unique] interactiveClassKeys = map getUnique interactiveClassNames {- ************************************************************************ * * Semi-builtin names * * ************************************************************************ The following names should be considered by GHCi to be in scope always. -} pretendNameIsInScope :: Name -> Bool pretendNameIsInScope n = any (n `hasKey`) [ liftedTypeKindTyConKey, tYPETyConKey , runtimeRepTyConKey, liftedRepDataConKey ] ghc-lib-parser-8.10.2.20200808/compiler/prelude/PrelRules.hs0000644000000000000000000026276513713635745021254 0ustar0000000000000000{- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[ConFold]{Constant Folder} Conceptually, constant folding should be parameterized with the kind of target machine to get identical behaviour during compilation time and runtime. We cheat a little bit here... ToDo: check boundaries before folding, e.g. we can fold the Float addition (i1 + i2) only if it results in a valid Float. -} {-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards, DeriveFunctor #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} module PrelRules ( primOpRules , builtinRules , caseRules ) where #include "GhclibHsVersions.h" import GhcPrelude import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId ) import CoreSyn import MkCore import Id import Literal import CoreOpt ( exprIsLiteral_maybe ) import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn import TysPrim import TyCon ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons , tyConFamilySize ) import DataCon ( dataConTagZ, dataConTyCon, dataConWorkId ) import CoreUtils ( cheapEqExpr, cheapEqExpr', exprIsHNF, exprType, stripTicksTop, stripTicksTopT, mkTicks ) import CoreUnfold ( exprIsConApp_maybe ) import Type import OccName ( occNameFS ) import PrelNames import Maybes ( orElse ) import Name ( Name, nameOccName ) import Outputable import FastString import BasicTypes import DynFlags import GHC.Platform import Util import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..)) import Control.Applicative ( Alternative(..) ) import Control.Monad import qualified Control.Monad.Fail as MonadFail import Data.Bits as Bits import qualified Data.ByteString as BS import Data.Int import Data.Ratio import Data.Word {- Note [Constant folding] ~~~~~~~~~~~~~~~~~~~~~~~ primOpRules generates a rewrite rule for each primop These rules do what is often called "constant folding" E.g. the rules for +# might say 4 +# 5 = 9 Well, of course you'd need a lot of rules if you did it like that, so we use a BuiltinRule instead, so that we can match in any two literal values. So the rule is really more like (Lit x) +# (Lit y) = Lit (x+#y) where the (+#) on the rhs is done at compile time That is why these rules are built in here. -} primOpRules :: Name -> PrimOp -> Maybe CoreRule -- ToDo: something for integer-shift ops? -- NotOp primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ] primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ] -- Int operations primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) , identityDynFlags zeroi , numFoldingRules IntAddOp intPrimOps ] primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-)) , rightIdentityDynFlags zeroi , equalArgs >> retLit zeroi , numFoldingRules IntSubOp intPrimOps ] primOpRules nm IntAddCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+)) , identityCDynFlags zeroi ] primOpRules nm IntSubCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-)) , rightIdentityCDynFlags zeroi , equalArgs >> retLitNoC zeroi ] primOpRules nm IntMulOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*)) , zeroElem zeroi , identityDynFlags onei , numFoldingRules IntMulOp intPrimOps ] primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) , leftZero zeroi , rightIdentityDynFlags onei , equalArgs >> retLit onei ] primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem) , leftZero zeroi , do l <- getLiteral 1 dflags <- getDynFlags guard (l == onei dflags) retLit zeroi , equalArgs >> retLit zeroi , equalArgs >> retLit zeroi ] primOpRules nm AndIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.)) , idempotent , zeroElem zeroi ] primOpRules nm OrIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.)) , idempotent , identityDynFlags zeroi ] primOpRules nm XorIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor) , identityDynFlags zeroi , equalArgs >> retLit zeroi ] primOpRules nm NotIOp = mkPrimOpRule nm 1 [ unaryLit complementOp , inversePrimOp NotIOp ] primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp , inversePrimOp IntNegOp ] primOpRules nm ISllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) , rightIdentityDynFlags zeroi ] primOpRules nm ISraOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR) , rightIdentityDynFlags zeroi ] primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical , rightIdentityDynFlags zeroi ] -- Word operations primOpRules nm WordAddOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+)) , identityDynFlags zerow , numFoldingRules WordAddOp wordPrimOps ] primOpRules nm WordSubOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-)) , rightIdentityDynFlags zerow , equalArgs >> retLit zerow , numFoldingRules WordSubOp wordPrimOps ] primOpRules nm WordAddCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+)) , identityCDynFlags zerow ] primOpRules nm WordSubCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-)) , rightIdentityCDynFlags zerow , equalArgs >> retLitNoC zerow ] primOpRules nm WordMulOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*)) , identityDynFlags onew , numFoldingRules WordMulOp wordPrimOps ] primOpRules nm WordQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) , rightIdentityDynFlags onew ] primOpRules nm WordRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem) , leftZero zerow , do l <- getLiteral 1 dflags <- getDynFlags guard (l == onew dflags) retLit zerow , equalArgs >> retLit zerow ] primOpRules nm AndOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.)) , idempotent , zeroElem zerow ] primOpRules nm OrOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.)) , idempotent , identityDynFlags zerow ] primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) , identityDynFlags zerow , equalArgs >> retLit zerow ] primOpRules nm NotOp = mkPrimOpRule nm 1 [ unaryLit complementOp , inversePrimOp NotOp ] primOpRules nm SllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ] primOpRules nm SrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ] -- coercions primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit , inversePrimOp Int2WordOp ] primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit , inversePrimOp Word2IntOp ] primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit , subsumedByPrimOp Narrow8IntOp , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ] primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit , subsumedByPrimOp Narrow8IntOp , subsumedByPrimOp Narrow16IntOp , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ] primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit , subsumedByPrimOp Narrow8IntOp , subsumedByPrimOp Narrow16IntOp , subsumedByPrimOp Narrow32IntOp , removeOp32 ] primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit , subsumedByPrimOp Narrow8WordOp , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ] primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit , subsumedByPrimOp Narrow8WordOp , subsumedByPrimOp Narrow16WordOp , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ] primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit , subsumedByPrimOp Narrow8WordOp , subsumedByPrimOp Narrow16WordOp , subsumedByPrimOp Narrow32WordOp , removeOp32 ] primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit , inversePrimOp ChrOp ] primOpRules nm ChrOp = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs guard (litFitsInChar lit) liftLit int2CharLit , inversePrimOp OrdOp ] primOpRules nm Float2IntOp = mkPrimOpRule nm 1 [ liftLit float2IntLit ] primOpRules nm Int2FloatOp = mkPrimOpRule nm 1 [ liftLit int2FloatLit ] primOpRules nm Double2IntOp = mkPrimOpRule nm 1 [ liftLit double2IntLit ] primOpRules nm Int2DoubleOp = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ] -- SUP: Not sure what the standard says about precision in the following 2 cases primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ] primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ] -- Float primOpRules nm FloatAddOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+)) , identity zerof ] primOpRules nm FloatSubOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-)) , rightIdentity zerof ] primOpRules nm FloatMulOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*)) , identity onef , strengthReduction twof FloatAddOp ] -- zeroElem zerof doesn't hold because of NaN primOpRules nm FloatDivOp = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) , rightIdentity onef ] primOpRules nm FloatNegOp = mkPrimOpRule nm 1 [ unaryLit negOp , inversePrimOp FloatNegOp ] -- Double primOpRules nm DoubleAddOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+)) , identity zerod ] primOpRules nm DoubleSubOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-)) , rightIdentity zerod ] primOpRules nm DoubleMulOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*)) , identity oned , strengthReduction twod DoubleAddOp ] -- zeroElem zerod doesn't hold because of NaN primOpRules nm DoubleDivOp = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) , rightIdentity oned ] primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp , inversePrimOp DoubleNegOp ] -- Relational operators primOpRules nm IntEqOp = mkRelOpRule nm (==) [ litEq True ] primOpRules nm IntNeOp = mkRelOpRule nm (/=) [ litEq False ] primOpRules nm CharEqOp = mkRelOpRule nm (==) [ litEq True ] primOpRules nm CharNeOp = mkRelOpRule nm (/=) [ litEq False ] primOpRules nm IntGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] primOpRules nm IntGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] primOpRules nm IntLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] primOpRules nm IntLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] primOpRules nm CharGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] primOpRules nm CharGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] primOpRules nm CharLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] primOpRules nm CharLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>) primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=) primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=) primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<) primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==) primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=) primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>) primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=) primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=) primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<) primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==) primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) primOpRules nm WordGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] primOpRules nm WordGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] primOpRules nm WordLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] primOpRules nm WordLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] primOpRules nm WordEqOp = mkRelOpRule nm (==) [ litEq True ] primOpRules nm WordNeOp = mkRelOpRule nm (/=) [ litEq False ] primOpRules nm AddrAddOp = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ] primOpRules nm SeqOp = mkPrimOpRule nm 4 [ seqRule ] primOpRules nm SparkOp = mkPrimOpRule nm 4 [ sparkRule ] primOpRules _ _ = Nothing {- ************************************************************************ * * \subsection{Doing the business} * * ************************************************************************ -} -- useful shorthands mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules) mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) -> [RuleM CoreExpr] -> Maybe CoreRule mkRelOpRule nm cmp extra = mkPrimOpRule nm 2 $ binaryCmpLit cmp : equal_rule : extra where -- x `cmp` x does not depend on x, so -- compute it for the arbitrary value 'True' -- and use that result equal_rule = do { equalArgs ; dflags <- getDynFlags ; return (if cmp True True then trueValInt dflags else falseValInt dflags) } {- Note [Rules for floating-point comparisons] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need different rules for floating-point values because for floats it is not true that x = x (for NaNs); so we do not want the equal_rule rule that mkRelOpRule uses. Note also that, in the case of equality/inequality, we do /not/ want to switch to a case-expression. For example, we do not want to convert case (eqFloat# x 3.8#) of True -> this False -> that to case x of 3.8#::Float# -> this _ -> that See #9238. Reason: comparing floating-point values for equality delicate, and we don't want to implement that delicacy in the code for case expressions. So we make it an invariant of Core that a case expression never scrutinises a Float# or Double#. This transformation is what the litEq rule does; see Note [The litEq rule: converting equality to case]. So we /refrain/ from using litEq for mkFloatingRelOpRule. -} mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) -> Maybe CoreRule -- See Note [Rules for floating-point comparisons] mkFloatingRelOpRule nm cmp = mkPrimOpRule nm 2 [binaryCmpLit cmp] -- common constants zeroi, onei, zerow, onew :: DynFlags -> Literal zeroi dflags = mkLitInt dflags 0 onei dflags = mkLitInt dflags 1 zerow dflags = mkLitWord dflags 0 onew dflags = mkLitWord dflags 1 zerof, onef, twof, zerod, oned, twod :: Literal zerof = mkLitFloat 0.0 onef = mkLitFloat 1.0 twof = mkLitFloat 2.0 zerod = mkLitDouble 0.0 oned = mkLitDouble 1.0 twod = mkLitDouble 2.0 cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool) -> Literal -> Literal -> Maybe CoreExpr cmpOp dflags cmp = go where done True = Just $ trueValInt dflags done False = Just $ falseValInt dflags -- These compares are at different types go (LitChar i1) (LitChar i2) = done (i1 `cmp` i2) go (LitFloat i1) (LitFloat i2) = done (i1 `cmp` i2) go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2) go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _) | nt1 /= nt2 = Nothing | otherwise = done (i1 `cmp` i2) go _ _ = Nothing -------------------------- negOp :: DynFlags -> Literal -> Maybe CoreExpr -- Negate negOp _ (LitFloat 0.0) = Nothing -- can't represent -0.0 as a Rational negOp dflags (LitFloat f) = Just (mkFloatVal dflags (-f)) negOp _ (LitDouble 0.0) = Nothing negOp dflags (LitDouble d) = Just (mkDoubleVal dflags (-d)) negOp dflags (LitNumber nt i t) | litNumIsSigned nt = Just (Lit (mkLitNumberWrap dflags nt (-i) t)) negOp _ _ = Nothing complementOp :: DynFlags -> Literal -> Maybe CoreExpr -- Binary complement complementOp dflags (LitNumber nt i t) = Just (Lit (mkLitNumberWrap dflags nt (complement i) t)) complementOp _ _ = Nothing -------------------------- intOp2 :: (Integral a, Integral b) => (a -> b -> Integer) -> DynFlags -> Literal -> Literal -> Maybe CoreExpr intOp2 = intOp2' . const intOp2' :: (Integral a, Integral b) => (DynFlags -> a -> b -> Integer) -> DynFlags -> Literal -> Literal -> Maybe CoreExpr intOp2' op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = let o = op dflags in intResult dflags (fromInteger i1 `o` fromInteger i2) intOp2' _ _ _ _ = Nothing -- Could find LitLit intOpC2 :: (Integral a, Integral b) => (a -> b -> Integer) -> DynFlags -> Literal -> Literal -> Maybe CoreExpr intOpC2 op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do intCResult dflags (fromInteger i1 `op` fromInteger i2) intOpC2 _ _ _ _ = Nothing -- Could find LitLit shiftRightLogical :: DynFlags -> Integer -> Int -> Integer -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do -- Do this by converting to Word and back. Obviously this won't work for big -- values, but its ok as we use it here shiftRightLogical dflags x n = case platformWordSize (targetPlatform dflags) of PW4 -> fromIntegral (fromInteger x `shiftR` n :: Word32) PW8 -> fromIntegral (fromInteger x `shiftR` n :: Word64) -------------------------- retLit :: (DynFlags -> Literal) -> RuleM CoreExpr retLit l = do dflags <- getDynFlags return $ Lit $ l dflags retLitNoC :: (DynFlags -> Literal) -> RuleM CoreExpr retLitNoC l = do dflags <- getDynFlags let lit = l dflags let ty = literalType lit return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi dflags)] wordOp2 :: (Integral a, Integral b) => (a -> b -> Integer) -> DynFlags -> Literal -> Literal -> Maybe CoreExpr wordOp2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) = wordResult dflags (fromInteger w1 `op` fromInteger w2) wordOp2 _ _ _ _ = Nothing -- Could find LitLit wordOpC2 :: (Integral a, Integral b) => (a -> b -> Integer) -> DynFlags -> Literal -> Literal -> Maybe CoreExpr wordOpC2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) = wordCResult dflags (fromInteger w1 `op` fromInteger w2) wordOpC2 _ _ _ _ = Nothing -- Could find LitLit shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr -- Shifts take an Int; hence third arg of op is Int -- Used for shift primops -- ISllOp, ISraOp, ISrlOp :: Word# -> Int# -> Word# -- SllOp, SrlOp :: Word# -> Int# -> Word# shiftRule shift_op = do { dflags <- getDynFlags ; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs ; case e1 of _ | shift_len == 0 -> return e1 -- See Note [Guarding against silly shifts] | shift_len < 0 || shift_len > wordSizeInBits dflags -> return $ Lit $ mkLitNumberWrap dflags LitNumInt 0 (exprType e1) -- Do the shift at type Integer, but shift length is Int Lit (LitNumber nt x t) | 0 < shift_len , shift_len <= wordSizeInBits dflags -> let op = shift_op dflags y = x `op` fromInteger shift_len in liftMaybe $ Just (Lit (mkLitNumberWrap dflags nt y t)) _ -> mzero } wordSizeInBits :: DynFlags -> Integer wordSizeInBits dflags = toInteger (platformWordSizeInBits (targetPlatform dflags)) -------------------------- floatOp2 :: (Rational -> Rational -> Rational) -> DynFlags -> Literal -> Literal -> Maybe (Expr CoreBndr) floatOp2 op dflags (LitFloat f1) (LitFloat f2) = Just (mkFloatVal dflags (f1 `op` f2)) floatOp2 _ _ _ _ = Nothing -------------------------- doubleOp2 :: (Rational -> Rational -> Rational) -> DynFlags -> Literal -> Literal -> Maybe (Expr CoreBndr) doubleOp2 op dflags (LitDouble f1) (LitDouble f2) = Just (mkDoubleVal dflags (f1 `op` f2)) doubleOp2 _ _ _ _ = Nothing -------------------------- {- Note [The litEq rule: converting equality to case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This stuff turns n ==# 3# into case n of 3# -> True m -> False This is a Good Thing, because it allows case-of case things to happen, and case-default absorption to happen. For example: if (n ==# 3#) || (n ==# 4#) then e1 else e2 will transform to case n of 3# -> e1 4# -> e1 m -> e2 (modulo the usual precautions to avoid duplicating e1) -} litEq :: Bool -- True <=> equality, False <=> inequality -> RuleM CoreExpr litEq is_eq = msum [ do [Lit lit, expr] <- getArgs dflags <- getDynFlags do_lit_eq dflags lit expr , do [expr, Lit lit] <- getArgs dflags <- getDynFlags do_lit_eq dflags lit expr ] where do_lit_eq dflags lit expr = do guard (not (litIsLifted lit)) return (mkWildCase expr (literalType lit) intPrimTy [(DEFAULT, [], val_if_neq), (LitAlt lit, [], val_if_eq)]) where val_if_eq | is_eq = trueValInt dflags | otherwise = falseValInt dflags val_if_neq | is_eq = falseValInt dflags | otherwise = trueValInt dflags -- | Check if there is comparison with minBound or maxBound, that is -- always true or false. For instance, an Int cannot be smaller than its -- minBound, so we can replace such comparison with False. boundsCmp :: Comparison -> RuleM CoreExpr boundsCmp op = do dflags <- getDynFlags [a, b] <- getArgs liftMaybe $ mkRuleFn dflags op a b data Comparison = Gt | Ge | Lt | Le mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags mkRuleFn _ _ _ _ = Nothing isMinBound :: DynFlags -> Literal -> Bool isMinBound _ (LitChar c) = c == minBound isMinBound dflags (LitNumber nt i _) = case nt of LitNumInt -> i == tARGET_MIN_INT dflags LitNumInt64 -> i == toInteger (minBound :: Int64) LitNumWord -> i == 0 LitNumWord64 -> i == 0 LitNumNatural -> i == 0 LitNumInteger -> False isMinBound _ _ = False isMaxBound :: DynFlags -> Literal -> Bool isMaxBound _ (LitChar c) = c == maxBound isMaxBound dflags (LitNumber nt i _) = case nt of LitNumInt -> i == tARGET_MAX_INT dflags LitNumInt64 -> i == toInteger (maxBound :: Int64) LitNumWord -> i == tARGET_MAX_WORD dflags LitNumWord64 -> i == toInteger (maxBound :: Word64) LitNumNatural -> False LitNumInteger -> False isMaxBound _ _ = False -- | Create an Int literal expression while ensuring the given Integer is in the -- target Int range intResult :: DynFlags -> Integer -> Maybe CoreExpr intResult dflags result = Just (intResult' dflags result) intResult' :: DynFlags -> Integer -> CoreExpr intResult' dflags result = Lit (mkLitIntWrap dflags result) -- | Create an unboxed pair of an Int literal expression, ensuring the given -- Integer is in the target Int range and the corresponding overflow flag -- (@0#@/@1#@) if it wasn't. intCResult :: DynFlags -> Integer -> Maybe CoreExpr intCResult dflags result = Just (mkPair [Lit lit, Lit c]) where mkPair = mkCoreUbxTup [intPrimTy, intPrimTy] (lit, b) = mkLitIntWrapC dflags result c = if b then onei dflags else zeroi dflags -- | Create a Word literal expression while ensuring the given Integer is in the -- target Word range wordResult :: DynFlags -> Integer -> Maybe CoreExpr wordResult dflags result = Just (wordResult' dflags result) wordResult' :: DynFlags -> Integer -> CoreExpr wordResult' dflags result = Lit (mkLitWordWrap dflags result) -- | Create an unboxed pair of a Word literal expression, ensuring the given -- Integer is in the target Word range and the corresponding carry flag -- (@0#@/@1#@) if it wasn't. wordCResult :: DynFlags -> Integer -> Maybe CoreExpr wordCResult dflags result = Just (mkPair [Lit lit, Lit c]) where mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy] (lit, b) = mkLitWordWrapC dflags result c = if b then onei dflags else zeroi dflags inversePrimOp :: PrimOp -> RuleM CoreExpr inversePrimOp primop = do [Var primop_id `App` e] <- getArgs matchPrimOpId primop primop_id return e subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr this `subsumesPrimOp` that = do [Var primop_id `App` e] <- getArgs matchPrimOpId that primop_id return (Var (mkPrimOpId this) `App` e) subsumedByPrimOp :: PrimOp -> RuleM CoreExpr subsumedByPrimOp primop = do [e@(Var primop_id `App` _)] <- getArgs matchPrimOpId primop primop_id return e idempotent :: RuleM CoreExpr idempotent = do [e1, e2] <- getArgs guard $ cheapEqExpr e1 e2 return e1 {- Note [Guarding against silly shifts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this code: import Data.Bits( (.|.), shiftL ) chunkToBitmap :: [Bool] -> Word32 chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ] This optimises to: Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) -> case w1_sCT of _ { [] -> 0##; : x_aAW xs_aAX -> case x_aAW of _ { GHC.Types.False -> case w_sCS of wild2_Xh { __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX; 9223372036854775807 -> 0## }; GHC.Types.True -> case GHC.Prim.>=# w_sCS 64 of _ { GHC.Types.False -> case w_sCS of wild3_Xh { __DEFAULT -> case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT -> GHC.Prim.or# (GHC.Prim.narrow32Word# (GHC.Prim.uncheckedShiftL# 1## wild3_Xh)) ww_sCW }; 9223372036854775807 -> GHC.Prim.narrow32Word# !!!!--> (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807) }; GHC.Types.True -> case w_sCS of wild3_Xh { __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX; 9223372036854775807 -> 0## } } } } Note the massive shift on line "!!!!". It can't happen, because we've checked that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this! Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we can't constant fold it, but if it gets to the assember we get Error: operand type mismatch for `shl' So the best thing to do is to rewrite the shift with a call to error, when the second arg is large. However, in general we cannot do this; consider this case let x = I# (uncheckedIShiftL# n 80) in ... Here x contains an invalid shift and consequently we would like to rewrite it as follows: let x = I# (error "invalid shift) in ... This was originally done in the fix to #16449 but this breaks the let/app invariant (see Note [CoreSyn let/app invariant] in CoreSyn) as noted in #16742. For the reasons discussed in Note [Checking versus non-checking primops] (in the PrimOp module) there is no safe way rewrite the argument of I# such that it bottoms. Consequently we instead take advantage of the fact that large shifts are undefined behavior (see associated documentation in primops.txt.pp) and transform the invalid shift into an "obviously incorrect" value. There are two cases: - Shifting fixed-width things: the primops ISll, Sll, etc These are handled by shiftRule. We are happy to shift by any amount up to wordSize but no more. - Shifting Integers: the function shiftLInteger, shiftRInteger from the 'integer' library. These are handled by rule_shift_op, and match_Integer_shift_op. Here we could in principle shift by any amount, but we arbitary limit the shift to 4 bits; in particualr we do not want shift by a huge amount, which can happen in code like that above. The two cases are more different in their code paths that is comfortable, but that is only a historical accident. ************************************************************************ * * \subsection{Vaguely generic functions} * * ************************************************************************ -} mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule -- Gives the Rule the same name as the primop itself mkBasicRule op_name n_args rm = BuiltinRule { ru_name = occNameFS (nameOccName op_name), ru_fn = op_name, ru_nargs = n_args, ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope } newtype RuleM r = RuleM { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r } deriving (Functor) instance Applicative RuleM where pure x = RuleM $ \_ _ _ -> Just x (<*>) = ap instance Monad RuleM where RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of Nothing -> Nothing Just r -> runRuleM (g r) dflags iu e #if !MIN_VERSION_base(4,13,0) fail = MonadFail.fail #endif instance MonadFail.MonadFail RuleM where fail _ = mzero instance Alternative RuleM where empty = RuleM $ \_ _ _ -> Nothing RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu args -> f1 dflags iu args <|> f2 dflags iu args instance MonadPlus RuleM instance HasDynFlags RuleM where getDynFlags = RuleM $ \dflags _ _ -> Just dflags liftMaybe :: Maybe a -> RuleM a liftMaybe Nothing = mzero liftMaybe (Just x) = return x liftLit :: (Literal -> Literal) -> RuleM CoreExpr liftLit f = liftLitDynFlags (const f) liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr liftLitDynFlags f = do dflags <- getDynFlags [Lit lit] <- getArgs return $ Lit (f dflags lit) removeOp32 :: RuleM CoreExpr removeOp32 = do dflags <- getDynFlags case platformWordSize (targetPlatform dflags) of PW4 -> do [e] <- getArgs return e PW8 -> mzero getArgs :: RuleM [CoreExpr] getArgs = RuleM $ \_ _ args -> Just args getInScopeEnv :: RuleM InScopeEnv getInScopeEnv = RuleM $ \_ iu _ -> Just iu -- return the n-th argument of this rule, if it is a literal -- argument indices start from 0 getLiteral :: Int -> RuleM Literal getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of (Lit l:_) -> Just l _ -> Nothing unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr unaryLit op = do dflags <- getDynFlags [Lit l] <- getArgs liftMaybe $ op dflags (convFloating dflags l) binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr binaryLit op = do dflags <- getDynFlags [Lit l1, Lit l2] <- getArgs liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2) binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr binaryCmpLit op = do dflags <- getDynFlags binaryLit (\_ -> cmpOp dflags op) leftIdentity :: Literal -> RuleM CoreExpr leftIdentity id_lit = leftIdentityDynFlags (const id_lit) rightIdentity :: Literal -> RuleM CoreExpr rightIdentity id_lit = rightIdentityDynFlags (const id_lit) identity :: Literal -> RuleM CoreExpr identity lit = leftIdentity lit `mplus` rightIdentity lit leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr leftIdentityDynFlags id_lit = do dflags <- getDynFlags [Lit l1, e2] <- getArgs guard $ l1 == id_lit dflags return e2 -- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in -- addition to the result, we have to indicate that no carry/overflow occured. leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr leftIdentityCDynFlags id_lit = do dflags <- getDynFlags [Lit l1, e2] <- getArgs guard $ l1 == id_lit dflags let no_c = Lit (zeroi dflags) return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c]) rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr rightIdentityDynFlags id_lit = do dflags <- getDynFlags [e1, Lit l2] <- getArgs guard $ l2 == id_lit dflags return e1 -- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in -- addition to the result, we have to indicate that no carry/overflow occured. rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr rightIdentityCDynFlags id_lit = do dflags <- getDynFlags [e1, Lit l2] <- getArgs guard $ l2 == id_lit dflags let no_c = Lit (zeroi dflags) return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c]) identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr identityDynFlags lit = leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit -- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition -- to the result, we have to indicate that no carry/overflow occured. identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr identityCDynFlags lit = leftIdentityCDynFlags lit `mplus` rightIdentityCDynFlags lit leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr leftZero zero = do dflags <- getDynFlags [Lit l1, _] <- getArgs guard $ l1 == zero dflags return $ Lit l1 rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr rightZero zero = do dflags <- getDynFlags [_, Lit l2] <- getArgs guard $ l2 == zero dflags return $ Lit l2 zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr zeroElem lit = leftZero lit `mplus` rightZero lit equalArgs :: RuleM () equalArgs = do [e1, e2] <- getArgs guard $ e1 `cheapEqExpr` e2 nonZeroLit :: Int -> RuleM () nonZeroLit n = getLiteral n >>= guard . not . isZeroLit -- When excess precision is not requested, cut down the precision of the -- Rational value to that of Float/Double. We confuse host architecture -- and target architecture here, but it's convenient (and wrong :-). convFloating :: DynFlags -> Literal -> Literal convFloating dflags (LitFloat f) | not (gopt Opt_ExcessPrecision dflags) = LitFloat (toRational (fromRational f :: Float )) convFloating dflags (LitDouble d) | not (gopt Opt_ExcessPrecision dflags) = LitDouble (toRational (fromRational d :: Double)) convFloating _ l = l guardFloatDiv :: RuleM () guardFloatDiv = do [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero] && f2 /= 0 -- avoid NaN and Infinity/-Infinity guardDoubleDiv :: RuleM () guardDoubleDiv = do [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero] && d2 /= 0 -- avoid NaN and Infinity/-Infinity -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to -- zero, but we might want to preserve the negative zero here which -- is representable in Float/Double but not in (normalised) -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead? strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr strengthReduction two_lit add_op = do -- Note [Strength reduction] arg <- msum [ do [arg, Lit mult_lit] <- getArgs guard (mult_lit == two_lit) return arg , do [Lit mult_lit, arg] <- getArgs guard (mult_lit == two_lit) return arg ] return $ Var (mkPrimOpId add_op) `App` arg `App` arg -- Note [Strength reduction] -- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- This rule turns floating point multiplications of the form 2.0 * x and -- x * 2.0 into x + x addition, because addition costs less than multiplication. -- See #7116 -- Note [What's true and false] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- trueValInt and falseValInt represent true and false values returned by -- comparison primops for Char, Int, Word, Integer, Double, Float and Addr. -- True is represented as an unboxed 1# literal, while false is represented -- as 0# literal. -- We still need Bool data constructors (True and False) to use in a rule -- for constant folding of equal Strings trueValInt, falseValInt :: DynFlags -> Expr CoreBndr trueValInt dflags = Lit $ onei dflags -- see Note [What's true and false] falseValInt dflags = Lit $ zeroi dflags trueValBool, falseValBool :: Expr CoreBndr trueValBool = Var trueDataConId -- see Note [What's true and false] falseValBool = Var falseDataConId ltVal, eqVal, gtVal :: Expr CoreBndr ltVal = Var ordLTDataConId eqVal = Var ordEQDataConId gtVal = Var ordGTDataConId mkIntVal :: DynFlags -> Integer -> Expr CoreBndr mkIntVal dflags i = Lit (mkLitInt dflags i) mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr mkFloatVal dflags f = Lit (convFloating dflags (LitFloat f)) mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr mkDoubleVal dflags d = Lit (convFloating dflags (LitDouble d)) matchPrimOpId :: PrimOp -> Id -> RuleM () matchPrimOpId op id = do op' <- liftMaybe $ isPrimOpId_maybe id guard $ op == op' {- ************************************************************************ * * \subsection{Special rules for seq, tagToEnum, dataToTag} * * ************************************************************************ Note [tagToEnum#] ~~~~~~~~~~~~~~~~~ Nasty check to ensure that tagToEnum# is applied to a type that is an enumeration TyCon. Unification may refine the type later, but this check won't see that, alas. It's crude but it works. Here's are two cases that should fail f :: forall a. a f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable g :: Int g = tagToEnum# 0 -- Int is not an enumeration We used to make this check in the type inference engine, but it's quite ugly to do so, because the delayed constraint solving means that we don't really know what's going on until the end. It's very much a corner case because we don't expect the user to call tagToEnum# at all; we merely generate calls in derived instances of Enum. So we compromise: a rewrite rule rewrites a bad instance of tagToEnum# to an error call, and emits a warning. -} tagToEnumRule :: RuleM CoreExpr -- If data T a = A | B | C -- then tag2Enum# (T ty) 2# --> B ty tagToEnumRule = do [Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs case splitTyConApp_maybe ty of Just (tycon, tc_args) | isEnumerationTyCon tycon -> do let tag = fromInteger i correct_tag dc = (dataConTagZ dc) == tag (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` []) ASSERT(null rest) return () return $ mkTyApps (Var (dataConWorkId dc)) tc_args -- See Note [tagToEnum#] _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty ) return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type" ------------------------------ dataToTagRule :: RuleM CoreExpr -- See Note [dataToTag#] in primops.txt.pp dataToTagRule = a `mplus` b where -- dataToTag (tagToEnum x) ==> x a = do [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs guard $ tag_to_enum `hasKey` tagToEnumKey guard $ ty1 `eqType` ty2 return tag -- dataToTag (K e1 e2) ==> tag-of K -- This also works (via exprIsConApp_maybe) for -- dataToTag x -- where x's unfolding is a constructor application b = do dflags <- getDynFlags [_, val_arg] <- getArgs in_scope <- getInScopeEnv (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return () return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc))) {- Note [dataToTag# magic] ~~~~~~~~~~~~~~~~~~~~~~~~~~ The primop dataToTag# is unusual because it evaluates its argument. Only `SeqOp` shares that property. (Other primops do not do anything as fancy as argument evaluation.) The special handling for dataToTag# is: * CoreUtils.exprOkForSpeculation has a special case for DataToTagOp, (actually in app_ok). Most primops with lifted arguments do not evaluate those arguments, but DataToTagOp and SeqOp are two exceptions. We say that they are /never/ ok-for-speculation, regardless of the evaluated-ness of their argument. See CoreUtils Note [exprOkForSpeculation and SeqOp/DataToTagOp] * There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr, that evaluates its argument and then extracts the tag from the returned value. * An application like (dataToTag# (Just x)) is optimised by dataToTagRule in PrelRules. * A case expression like case (dataToTag# e) of gets transformed t case e of by PrelRules.caseRules; see Note [caseRules for dataToTag] See #15696 for a long saga. ************************************************************************ * * \subsection{Rules for seq# and spark#} * * ************************************************************************ -} {- Note [seq# magic] ~~~~~~~~~~~~~~~~~~~~ The primop seq# :: forall a s . a -> State# s -> (# State# s, a #) is /not/ the same as the Prelude function seq :: a -> b -> b as you can see from its type. In fact, seq# is the implementation mechanism for 'evaluate' evaluate :: a -> IO a evaluate a = IO $ \s -> seq# a s The semantics of seq# is * evaluate its first argument * and return it Things to note * Why do we need a primop at all? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah) Reason (see #5129): if we saw catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler then we'd drop the 'case x' because the body of the case is bottom anyway. But we don't want to do that; the whole /point/ of seq#/evaluate is to evaluate 'x' first in the IO monad. In short, we /always/ evaluate the first argument and never just discard it. * Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as let x = e in case seq# x RW of (# _, x' #) -> ... x' ... also it matches the type of rseq in the Eval monad. Implementing seq#. The compiler has magic for SeqOp in - PrelRules.seqRule: eliminate (seq# s) - GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# - CoreUtils.exprOkForSpeculation; see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in CoreUtils - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in Simplify -} seqRule :: RuleM CoreExpr seqRule = do [Type ty_a, Type _ty_s, a, s] <- getArgs guard $ exprIsHNF a return $ mkCoreUbxTup [exprType s, ty_a] [s, a] -- spark# :: forall a s . a -> State# s -> (# State# s, a #) sparkRule :: RuleM CoreExpr sparkRule = seqRule -- reduce on HNF, just the same -- XXX perhaps we shouldn't do this, because a spark eliminated by -- this rule won't be counted as a dud at runtime? {- ************************************************************************ * * \subsection{Built in rules} * * ************************************************************************ Note [Scoping for Builtin rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When compiling a (base-package) module that defines one of the functions mentioned in the RHS of a built-in rule, there's a danger that we'll see f = ...(eq String x).... ....and lower down... eqString = ... Then a rewrite would give f = ...(eqString x)... ....and lower down... eqString = ... and lo, eqString is not in scope. This only really matters when we get to code generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole set of bindings, which sorts out the dependency. Without -O we don't do any rule rewriting so again we are fine. (This whole thing doesn't show up for non-built-in rules because their dependencies are explicit.) -} builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules = [BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName, ru_nargs = 4, ru_try = match_append_lit }, BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, ru_nargs = 2, ru_try = match_eq_string }, BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId, ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict }, mkBasicRule divIntName 2 $ msum [ nonZeroLit 1 >> binaryLit (intOp2 div) , leftZero zeroi , do [arg, Lit (LitNumber LitNumInt d _)] <- getArgs Just n <- return $ exactLog2 d dflags <- getDynFlags return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n ], mkBasicRule modIntName 2 $ msum [ nonZeroLit 1 >> binaryLit (intOp2 mod) , leftZero zeroi , do [arg, Lit (LitNumber LitNumInt d _)] <- getArgs Just _ <- return $ exactLog2 d dflags <- getDynFlags return $ Var (mkPrimOpId AndIOp) `App` arg `App` mkIntVal dflags (d - 1) ] ] ++ builtinIntegerRules ++ builtinNaturalRules {-# NOINLINE builtinRules #-} -- there is no benefit to inlining these yet, despite this, GHC produces -- unfoldings for this regardless since the floated list entries look small. builtinIntegerRules :: [CoreRule] builtinIntegerRules = [rule_IntToInteger "smallInteger" smallIntegerName, rule_WordToInteger "wordToInteger" wordToIntegerName, rule_Int64ToInteger "int64ToInteger" int64ToIntegerName, rule_Word64ToInteger "word64ToInteger" word64ToIntegerName, rule_convert "integerToWord" integerToWordName mkWordLitWord, rule_convert "integerToInt" integerToIntName mkIntLitInt, rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64), rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64), rule_binop "plusInteger" plusIntegerName (+), rule_binop "minusInteger" minusIntegerName (-), rule_binop "timesInteger" timesIntegerName (*), rule_unop "negateInteger" negateIntegerName negate, rule_binop_Prim "eqInteger#" eqIntegerPrimName (==), rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=), rule_unop "absInteger" absIntegerName abs, rule_unop "signumInteger" signumIntegerName signum, rule_binop_Prim "leInteger#" leIntegerPrimName (<=), rule_binop_Prim "gtInteger#" gtIntegerPrimName (>), rule_binop_Prim "ltInteger#" ltIntegerPrimName (<), rule_binop_Prim "geInteger#" geIntegerPrimName (>=), rule_binop_Ordering "compareInteger" compareIntegerName compare, rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat, rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat), rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName, rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble), rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr, rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr, rule_binop "gcdInteger" gcdIntegerName gcd, rule_binop "lcmInteger" lcmIntegerName lcm, rule_binop "andInteger" andIntegerName (.&.), rule_binop "orInteger" orIntegerName (.|.), rule_binop "xorInteger" xorIntegerName xor, rule_unop "complementInteger" complementIntegerName complement, rule_shift_op "shiftLInteger" shiftLIntegerName shiftL, rule_shift_op "shiftRInteger" shiftRIntegerName shiftR, rule_bitInteger "bitInteger" bitIntegerName, -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs rule_divop_one "quotInteger" quotIntegerName quot, rule_divop_one "remInteger" remIntegerName rem, rule_divop_one "divInteger" divIntegerName div, rule_divop_one "modInteger" modIntegerName mod, rule_divop_both "divModInteger" divModIntegerName divMod, rule_divop_both "quotRemInteger" quotRemIntegerName quotRem, -- These rules below don't actually have to be built in, but if we -- put them in the Haskell source then we'd have to duplicate them -- between all Integer implementations rule_XToIntegerToX "smallIntegerToInt" integerToIntName smallIntegerName, rule_XToIntegerToX "wordToIntegerToWord" integerToWordName wordToIntegerName, rule_XToIntegerToX "int64ToIntegerToInt64" integerToInt64Name int64ToIntegerName, rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName, rule_smallIntegerTo "smallIntegerToWord" integerToWordName Int2WordOp, rule_smallIntegerTo "smallIntegerToFloat" floatFromIntegerName Int2FloatOp, rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp ] where rule_convert str name convert = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_Integer_convert convert } rule_IntToInteger str name = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_IntToInteger } rule_WordToInteger str name = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_WordToInteger } rule_Int64ToInteger str name = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_Int64ToInteger } rule_Word64ToInteger str name = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_Word64ToInteger } rule_unop str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_Integer_unop op } rule_bitInteger str name = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_bitInteger } rule_binop str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_binop op } rule_divop_both str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_divop_both op } rule_divop_one str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_divop_one op } rule_shift_op str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_shift_op op } rule_binop_Prim str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_binop_Prim op } rule_binop_Ordering str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_binop_Ordering op } rule_encodeFloat str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_Int_encodeFloat op } rule_decodeDouble str name = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_decodeDouble } rule_XToIntegerToX str name toIntegerName = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_XToIntegerToX toIntegerName } rule_smallIntegerTo str name primOp = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_smallIntegerTo primOp } rule_rationalTo str name mkLit = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_rationalTo mkLit } builtinNaturalRules :: [CoreRule] builtinNaturalRules = [rule_binop "plusNatural" plusNaturalName (+) ,rule_partial_binop "minusNatural" minusNaturalName (\a b -> if a >= b then Just (a - b) else Nothing) ,rule_binop "timesNatural" timesNaturalName (*) ,rule_NaturalFromInteger "naturalFromInteger" naturalFromIntegerName ,rule_NaturalToInteger "naturalToInteger" naturalToIntegerName ,rule_WordToNatural "wordToNatural" wordToNaturalName ] where rule_binop str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Natural_binop op } rule_partial_binop str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Natural_partial_binop op } rule_NaturalToInteger str name = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_NaturalToInteger } rule_NaturalFromInteger str name = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_NaturalFromInteger } rule_WordToNatural str name = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_WordToNatural } --------------------------------------------------- -- The rule is this: -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) -- = unpackFoldrCString# "foobaz" c n match_append_lit :: RuleFun match_append_lit _ id_unf _ [ Type ty1 , lit1 , c1 , e2 ] -- N.B. Ensure that we strip off any ticks (e.g. source notes) from the -- `lit` and `c` arguments, lest this may fail to fire when building with -- -g3. See #16740. | (strTicks, Var unpk `App` Type ty2 `App` lit2 `App` c2 `App` n) <- stripTicksTop tickishFloatable e2 , unpk `hasKey` unpackCStringFoldrIdKey , cheapEqExpr' tickishFloatable c1 c2 , (c1Ticks, c1') <- stripTicksTop tickishFloatable c1 , c2Ticks <- stripTicksTopT tickishFloatable c2 , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 = ASSERT( ty1 `eqType` ty2 ) Just $ mkTicks strTicks $ Var unpk `App` Type ty1 `App` Lit (LitString (s1 `BS.append` s2)) `App` mkTicks (c1Ticks ++ c2Ticks) c1' `App` n match_append_lit _ _ _ _ = Nothing --------------------------------------------------- -- The rule is this: -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2 match_eq_string :: RuleFun match_eq_string _ id_unf _ [Var unpk1 `App` lit1, Var unpk2 `App` lit2] | unpk1 `hasKey` unpackCStringIdKey , unpk2 `hasKey` unpackCStringIdKey , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 = Just (if s1 == s2 then trueValBool else falseValBool) match_eq_string _ _ _ _ = Nothing --------------------------------------------------- -- The rule is this: -- inline f_ty (f a b c) = a b c -- (if f has an unfolding, EVEN if it's a loop breaker) -- -- It's important to allow the argument to 'inline' to have args itself -- (a) because its more forgiving to allow the programmer to write -- inline f a b c -- or inline (f a b c) -- (b) because a polymorphic f wll get a type argument that the -- programmer can't avoid -- -- Also, don't forget about 'inline's type argument! match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) match_inline (Type _ : e : _) | (Var f, args1) <- collectArgs e, Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) -- Ignore the IdUnfoldingFun here! = Just (mkApps unf args1) match_inline _ = Nothing -- See Note [magicDictId magic] in `basicTypes/MkId.hs` -- for a description of what is going on here. match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ] | Just (fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap , Just (dictTy, _) <- splitFunTy_maybe fieldTy , Just dictTc <- tyConAppTyCon_maybe dictTy , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc = Just $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] [])) `App` y match_magicDict _ = Nothing ------------------------------------------------- -- Integer rules -- smallInteger (79::Int#) = 79::Integer -- wordToInteger (79::Word#) = 79::Integer -- Similarly Int64, Word64 match_IntToInteger :: RuleFun match_IntToInteger = match_IntToInteger_unop id match_WordToInteger :: RuleFun match_WordToInteger _ id_unf id [xl] | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType id) of Just (_, integerTy) -> Just (Lit (mkLitInteger x integerTy)) _ -> panic "match_WordToInteger: Id has the wrong type" match_WordToInteger _ _ _ _ = Nothing match_Int64ToInteger :: RuleFun match_Int64ToInteger _ id_unf id [xl] | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType id) of Just (_, integerTy) -> Just (Lit (mkLitInteger x integerTy)) _ -> panic "match_Int64ToInteger: Id has the wrong type" match_Int64ToInteger _ _ _ _ = Nothing match_Word64ToInteger :: RuleFun match_Word64ToInteger _ id_unf id [xl] | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType id) of Just (_, integerTy) -> Just (Lit (mkLitInteger x integerTy)) _ -> panic "match_Word64ToInteger: Id has the wrong type" match_Word64ToInteger _ _ _ _ = Nothing match_NaturalToInteger :: RuleFun match_NaturalToInteger _ id_unf id [xl] | Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType id) of Just (_, naturalTy) -> Just (Lit (LitNumber LitNumInteger x naturalTy)) _ -> panic "match_NaturalToInteger: Id has the wrong type" match_NaturalToInteger _ _ _ _ = Nothing match_NaturalFromInteger :: RuleFun match_NaturalFromInteger _ id_unf id [xl] | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl , x >= 0 = case splitFunTy_maybe (idType id) of Just (_, naturalTy) -> Just (Lit (LitNumber LitNumNatural x naturalTy)) _ -> panic "match_NaturalFromInteger: Id has the wrong type" match_NaturalFromInteger _ _ _ _ = Nothing match_WordToNatural :: RuleFun match_WordToNatural _ id_unf id [xl] | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType id) of Just (_, naturalTy) -> Just (Lit (LitNumber LitNumNatural x naturalTy)) _ -> panic "match_WordToNatural: Id has the wrong type" match_WordToNatural _ _ _ _ = Nothing ------------------------------------------------- {- Note [Rewriting bitInteger] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For most types the bitInteger operation can be implemented in terms of shifts. The integer-gmp package, however, can do substantially better than this if allowed to provide its own implementation. However, in so doing it previously lost constant-folding (see #8832). The bitInteger rule above provides constant folding specifically for this function. There is, however, a bit of trickiness here when it comes to ranges. While the AST encodes all integers as Integers, `bit` expects the bit index to be given as an Int. Hence we coerce to an Int in the rule definition. This will behave a bit funny for constants larger than the word size, but the user should expect some funniness given that they will have at very least ignored a warning in this case. -} match_bitInteger :: RuleFun -- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer match_bitInteger dflags id_unf fn [arg] | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg , x >= 0 , x <= (wordSizeInBits dflags - 1) -- Make sure x is small enough to yield a decently small iteger -- Attempting to construct the Integer for -- (bitInteger 9223372036854775807#) -- would be a bad idea (#14959) , let x_int = fromIntegral x :: Int = case splitFunTy_maybe (idType fn) of Just (_, integerTy) -> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy)) _ -> panic "match_IntToInteger_unop: Id has the wrong type" match_bitInteger _ _ _ _ = Nothing ------------------------------------------------- match_Integer_convert :: Num a => (DynFlags -> a -> Expr CoreBndr) -> RuleFun match_Integer_convert convert dflags id_unf _ [xl] | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl = Just (convert dflags (fromInteger x)) match_Integer_convert _ _ _ _ _ = Nothing match_Integer_unop :: (Integer -> Integer) -> RuleFun match_Integer_unop unop _ id_unf _ [xl] | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl = Just (Lit (LitNumber LitNumInteger (unop x) i)) match_Integer_unop _ _ _ _ _ = Nothing match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun match_IntToInteger_unop unop _ id_unf fn [xl] | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType fn) of Just (_, integerTy) -> Just (Lit (LitNumber LitNumInteger (unop x) integerTy)) _ -> panic "match_IntToInteger_unop: Id has the wrong type" match_IntToInteger_unop _ _ _ _ _ = Nothing match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun match_Integer_binop binop _ id_unf _ [xl,yl] | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl = Just (Lit (mkLitInteger (x `binop` y) i)) match_Integer_binop _ _ _ _ _ = Nothing match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun match_Natural_binop binop _ id_unf _ [xl,yl] | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl = Just (Lit (mkLitNatural (x `binop` y) i)) match_Natural_binop _ _ _ _ _ = Nothing match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun match_Natural_partial_binop binop _ id_unf _ [xl,yl] | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl , Just z <- x `binop` y = Just (Lit (mkLitNatural z i)) match_Natural_partial_binop _ _ _ _ _ = Nothing -- This helper is used for the quotRem and divMod functions match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun match_Integer_divop_both divop _ id_unf _ [xl,yl] | Just (LitNumber LitNumInteger x t) <- exprIsLiteral_maybe id_unf xl , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 , (r,s) <- x `divop` y = Just $ mkCoreUbxTup [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)] match_Integer_divop_both _ _ _ _ _ = Nothing -- This helper is used for the quot and rem functions match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun match_Integer_divop_one divop _ id_unf _ [xl,yl] | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 = Just (Lit (mkLitInteger (x `divop` y) i)) match_Integer_divop_one _ _ _ _ _ = Nothing match_Integer_shift_op :: (Integer -> Int -> Integer) -> RuleFun -- Used for shiftLInteger, shiftRInteger :: Integer -> Int# -> Integer -- See Note [Guarding against silly shifts] match_Integer_shift_op binop _ id_unf _ [xl,yl] | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl , y >= 0 , y <= 4 -- Restrict constant-folding of shifts on Integers, somewhat -- arbitrary. We can get huge shifts in inaccessible code -- (#15673) = Just (Lit (mkLitInteger (x `binop` fromIntegral y) i)) match_Integer_shift_op _ _ _ _ _ = Nothing match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun match_Integer_binop_Prim binop dflags id_unf _ [xl, yl] | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl = Just (if x `binop` y then trueValInt dflags else falseValInt dflags) match_Integer_binop_Prim _ _ _ _ _ = Nothing match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun match_Integer_binop_Ordering binop _ id_unf _ [xl, yl] | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl = Just $ case x `binop` y of LT -> ltVal EQ -> eqVal GT -> gtVal match_Integer_binop_Ordering _ _ _ _ _ = Nothing match_Integer_Int_encodeFloat :: RealFloat a => (a -> Expr CoreBndr) -> RuleFun match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl] | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl = Just (mkLit $ encodeFloat x (fromInteger y)) match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing --------------------------------------------------- -- constant folding for Float/Double -- -- This turns -- rationalToFloat n d -- into a literal Float, and similarly for Doubles. -- -- it's important to not match d == 0, because that may represent a -- literal "0/0" or similar, and we can't produce a literal value for -- NaN or +-Inf match_rationalTo :: RealFloat a => (a -> Expr CoreBndr) -> RuleFun match_rationalTo mkLit _ id_unf _ [xl, yl] | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 = Just (mkLit (fromRational (x % y))) match_rationalTo _ _ _ _ _ = Nothing match_decodeDouble :: RuleFun match_decodeDouble dflags id_unf fn [xl] | Just (LitDouble x) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType fn) of Just (_, res) | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res -> case decodeFloat (fromRational x :: Double) of (y, z) -> Just $ mkCoreUbxTup [integerTy, intHashTy] [Lit (mkLitInteger y integerTy), Lit (mkLitInt dflags (toInteger z))] _ -> pprPanic "match_decodeDouble: Id has the wrong type" (ppr fn <+> dcolon <+> ppr (idType fn)) match_decodeDouble _ _ _ _ = Nothing match_XToIntegerToX :: Name -> RuleFun match_XToIntegerToX n _ _ _ [App (Var x) y] | idName x == n = Just y match_XToIntegerToX _ _ _ _ _ = Nothing match_smallIntegerTo :: PrimOp -> RuleFun match_smallIntegerTo primOp _ _ _ [App (Var x) y] | idName x == smallIntegerName = Just $ App (Var (mkPrimOpId primOp)) y match_smallIntegerTo _ _ _ _ _ = Nothing -------------------------------------------------------- -- Note [Constant folding through nested expressions] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- We use rewrites rules to perform constant folding. It means that we don't -- have a global view of the expression we are trying to optimise. As a -- consequence we only perform local (small-step) transformations that either: -- 1) reduce the number of operations -- 2) rearrange the expression to increase the odds that other rules will -- match -- -- We don't try to handle more complex expression optimisation cases that would -- require a global view. For example, rewriting expressions to increase -- sharing (e.g., Horner's method); optimisations that require local -- transformations increasing the number of operations; rearrangements to -- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0). -- -- We already have rules to perform constant folding on expressions with the -- following shape (where a and/or b are literals): -- -- D) op -- /\ -- / \ -- / \ -- a b -- -- To support nested expressions, we match three other shapes of expression -- trees: -- -- A) op1 B) op1 C) op1 -- /\ /\ /\ -- / \ / \ / \ -- / \ / \ / \ -- a op2 op2 c op2 op3 -- /\ /\ /\ /\ -- / \ / \ / \ / \ -- b c a b a b c d -- -- -- R1) +/- simplification: -- ops = + or -, two literals (not siblings) -- -- Examples: -- A: 5 + (10-x) ==> 15-x -- B: (10+x) + 5 ==> 15+x -- C: (5+a)-(5-b) ==> 0+(a+b) -- -- R2) * simplification -- ops = *, two literals (not siblings) -- -- Examples: -- A: 5 * (10*x) ==> 50*x -- B: (10*x) * 5 ==> 50*x -- C: (5*a)*(5*b) ==> 25*(a*b) -- -- R3) * distribution over +/- -- op1 = *, op2 = + or -, two literals (not siblings) -- -- This transformation doesn't reduce the number of operations but switches -- the outer and the inner operations so that the outer is (+) or (-) instead -- of (*). It increases the odds that other rules will match after this one. -- -- Examples: -- A: 5 * (10-x) ==> 50 - (5*x) -- B: (10+x) * 5 ==> 50 + (5*x) -- C: Not supported as it would increase the number of operations: -- (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b -- -- R4) Simple factorization -- -- op1 = + or -, op2/op3 = *, -- one literal for each innermost * operation (except in the D case), -- the two other terms are equals -- -- Examples: -- A: x - (10*x) ==> (-9)*x -- B: (10*x) + x ==> 11*x -- C: (5*x)-(x*3) ==> 2*x -- D: x+x ==> 2*x -- -- R5) +/- propagation -- -- ops = + or -, one literal -- -- This transformation doesn't reduce the number of operations but propagates -- the constant to the outer level. It increases the odds that other rules -- will match after this one. -- -- Examples: -- A: x - (10-y) ==> (x+y) - 10 -- B: (10+x) - y ==> 10 + (x-y) -- C: N/A (caught by the A and B cases) -- -------------------------------------------------------- -- | Rules to perform constant folding into nested expressions -- --See Note [Constant folding through nested expressions] numFoldingRules :: PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr numFoldingRules op dict = do [e1,e2] <- getArgs dflags <- getDynFlags let PrimOps{..} = dict dflags if not (gopt Opt_NumConstantFolding dflags) then mzero else case BinOpApp e1 op e2 of -- R1) +/- simplification x :++: (y :++: v) -> return $ mkL (x+y) `add` v x :++: (L y :-: v) -> return $ mkL (x+y) `sub` v x :++: (v :-: L y) -> return $ mkL (x-y) `add` v L x :-: (y :++: v) -> return $ mkL (x-y) `sub` v L x :-: (L y :-: v) -> return $ mkL (x-y) `add` v L x :-: (v :-: L y) -> return $ mkL (x+y) `sub` v (y :++: v) :-: L x -> return $ mkL (y-x) `add` v (L y :-: v) :-: L x -> return $ mkL (y-x) `sub` v (v :-: L y) :-: L x -> return $ mkL (0-y-x) `add` v (x :++: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (w `add` v) (w :-: L x) :+: (L y :-: v) -> return $ mkL (y-x) `add` (w `sub` v) (w :-: L x) :+: (v :-: L y) -> return $ mkL (0-x-y) `add` (w `add` v) (L x :-: w) :+: (L y :-: v) -> return $ mkL (x+y) `sub` (w `add` v) (L x :-: w) :+: (v :-: L y) -> return $ mkL (x-y) `add` (v `sub` w) (w :-: L x) :+: (y :++: v) -> return $ mkL (y-x) `add` (w `add` v) (L x :-: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (v `sub` w) (y :++: v) :+: (w :-: L x) -> return $ mkL (y-x) `add` (w `add` v) (y :++: v) :+: (L x :-: w) -> return $ mkL (x+y) `add` (v `sub` w) (v :-: L y) :-: (w :-: L x) -> return $ mkL (x-y) `add` (v `sub` w) (v :-: L y) :-: (L x :-: w) -> return $ mkL (0-x-y) `add` (v `add` w) (L y :-: v) :-: (w :-: L x) -> return $ mkL (x+y) `sub` (v `add` w) (L y :-: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (w `sub` v) (x :++: w) :-: (y :++: v) -> return $ mkL (x-y) `add` (w `sub` v) (w :-: L x) :-: (y :++: v) -> return $ mkL (0-y-x) `add` (w `sub` v) (L x :-: w) :-: (y :++: v) -> return $ mkL (x-y) `sub` (v `add` w) (y :++: v) :-: (w :-: L x) -> return $ mkL (y+x) `add` (v `sub` w) (y :++: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (v `add` w) -- R2) * simplification x :**: (y :**: v) -> return $ mkL (x*y) `mul` v (x :**: w) :*: (y :**: v) -> return $ mkL (x*y) `mul` (w `mul` v) -- R3) * distribution over +/- x :**: (y :++: v) -> return $ mkL (x*y) `add` (mkL x `mul` v) x :**: (L y :-: v) -> return $ mkL (x*y) `sub` (mkL x `mul` v) x :**: (v :-: L y) -> return $ (mkL x `mul` v) `sub` mkL (x*y) -- R4) Simple factorization v :+: w | w `cheapEqExpr` v -> return $ mkL 2 `mul` v w :+: (y :**: v) | w `cheapEqExpr` v -> return $ mkL (1+y) `mul` v w :-: (y :**: v) | w `cheapEqExpr` v -> return $ mkL (1-y) `mul` v (y :**: v) :+: w | w `cheapEqExpr` v -> return $ mkL (y+1) `mul` v (y :**: v) :-: w | w `cheapEqExpr` v -> return $ mkL (y-1) `mul` v (x :**: w) :+: (y :**: v) | w `cheapEqExpr` v -> return $ mkL (x+y) `mul` v (x :**: w) :-: (y :**: v) | w `cheapEqExpr` v -> return $ mkL (x-y) `mul` v -- R5) +/- propagation w :+: (y :++: v) -> return $ mkL y `add` (w `add` v) (y :++: v) :+: w -> return $ mkL y `add` (w `add` v) w :-: (y :++: v) -> return $ (w `sub` v) `sub` mkL y (y :++: v) :-: w -> return $ mkL y `add` (v `sub` w) w :-: (L y :-: v) -> return $ (w `add` v) `sub` mkL y (L y :-: v) :-: w -> return $ mkL y `sub` (w `add` v) w :+: (L y :-: v) -> return $ mkL y `add` (w `sub` v) w :+: (v :-: L y) -> return $ (w `add` v) `sub` mkL y (L y :-: v) :+: w -> return $ mkL y `add` (w `sub` v) (v :-: L y) :+: w -> return $ (w `add` v) `sub` mkL y _ -> mzero -- | Match the application of a binary primop pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr pattern BinOpApp x op y = OpVal op `App` x `App` y -- | Match a primop pattern OpVal :: PrimOp -> Arg CoreBndr pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where OpVal op = Var (mkPrimOpId op) -- | Match a literal pattern L :: Integer -> Arg CoreBndr pattern L l <- Lit (isLitValue_maybe -> Just l) -- | Match an addition pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr pattern x :+: y <- BinOpApp x (isAddOp -> True) y -- | Match an addition with a literal (handle commutativity) pattern (:++:) :: Integer -> Arg CoreBndr -> CoreExpr pattern l :++: x <- (isAdd -> Just (l,x)) isAdd :: CoreExpr -> Maybe (Integer,CoreExpr) isAdd e = case e of L l :+: x -> Just (l,x) x :+: L l -> Just (l,x) _ -> Nothing -- | Match a multiplication pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr pattern x :*: y <- BinOpApp x (isMulOp -> True) y -- | Match a multiplication with a literal (handle commutativity) pattern (:**:) :: Integer -> Arg CoreBndr -> CoreExpr pattern l :**: x <- (isMul -> Just (l,x)) isMul :: CoreExpr -> Maybe (Integer,CoreExpr) isMul e = case e of L l :*: x -> Just (l,x) x :*: L l -> Just (l,x) _ -> Nothing -- | Match a subtraction pattern (:-:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr pattern x :-: y <- BinOpApp x (isSubOp -> True) y isSubOp :: PrimOp -> Bool isSubOp IntSubOp = True isSubOp WordSubOp = True isSubOp _ = False isAddOp :: PrimOp -> Bool isAddOp IntAddOp = True isAddOp WordAddOp = True isAddOp _ = False isMulOp :: PrimOp -> Bool isMulOp IntMulOp = True isMulOp WordMulOp = True isMulOp _ = False -- | Explicit "type-class"-like dictionary for numeric primops -- -- Depends on DynFlags because creating a literal value depends on DynFlags data PrimOps = PrimOps { add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers , sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers , mul :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Multiply two numbers , mkL :: Integer -> CoreExpr -- ^ Create a literal value } intPrimOps :: DynFlags -> PrimOps intPrimOps dflags = PrimOps { add = \x y -> BinOpApp x IntAddOp y , sub = \x y -> BinOpApp x IntSubOp y , mul = \x y -> BinOpApp x IntMulOp y , mkL = intResult' dflags } wordPrimOps :: DynFlags -> PrimOps wordPrimOps dflags = PrimOps { add = \x y -> BinOpApp x WordAddOp y , sub = \x y -> BinOpApp x WordSubOp y , mul = \x y -> BinOpApp x WordMulOp y , mkL = wordResult' dflags } -------------------------------------------------------- -- Constant folding through case-expressions -- -- cf Scrutinee Constant Folding in simplCore/SimplUtils -------------------------------------------------------- -- | Match the scrutinee of a case and potentially return a new scrutinee and a -- function to apply to each literal alternative. caseRules :: DynFlags -> CoreExpr -- Scrutinee -> Maybe ( CoreExpr -- New scrutinee , AltCon -> Maybe AltCon -- How to fix up the alt pattern -- Nothing <=> Unreachable -- See Note [Unreachable caseRules alternatives] , Id -> CoreExpr) -- How to reconstruct the original scrutinee -- from the new case-binder -- e.g case e of b { -- ...; -- con bs -> rhs; -- ... } -- ==> -- case e' of b' { -- ...; -- fixup_altcon[con] bs -> let b = mk_orig[b] in rhs; -- ... } caseRules dflags (App (App (Var f) v) (Lit l)) -- v `op` x# | Just op <- isPrimOpId_maybe f , Just x <- isLitValue_maybe l , Just adjust_lit <- adjustDyadicRight op x = Just (v, tx_lit_con dflags adjust_lit , \v -> (App (App (Var f) (Var v)) (Lit l))) caseRules dflags (App (App (Var f) (Lit l)) v) -- x# `op` v | Just op <- isPrimOpId_maybe f , Just x <- isLitValue_maybe l , Just adjust_lit <- adjustDyadicLeft x op = Just (v, tx_lit_con dflags adjust_lit , \v -> (App (App (Var f) (Lit l)) (Var v))) caseRules dflags (App (Var f) v ) -- op v | Just op <- isPrimOpId_maybe f , Just adjust_lit <- adjustUnary op = Just (v, tx_lit_con dflags adjust_lit , \v -> App (Var f) (Var v)) -- See Note [caseRules for tagToEnum] caseRules dflags (App (App (Var f) type_arg) v) | Just TagToEnumOp <- isPrimOpId_maybe f = Just (v, tx_con_tte dflags , \v -> (App (App (Var f) type_arg) (Var v))) -- See Note [caseRules for dataToTag] caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x | Just DataToTagOp <- isPrimOpId_maybe f , Just (tc, _) <- tcSplitTyConApp_maybe ty , isAlgTyCon tc = Just (v, tx_con_dtt ty , \v -> App (App (Var f) (Type ty)) (Var v)) caseRules _ _ = Nothing tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon tx_lit_con _ _ DEFAULT = Just DEFAULT tx_lit_con dflags adjust (LitAlt l) = Just $ LitAlt (mapLitValue dflags adjust l) tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt) -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the -- literal alternatives remain in Word/Int target ranges -- (See Note [Word/Int underflow/overflow] in Literal and #13172). adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer) -- Given (x `op` lit) return a function 'f' s.t. f (x `op` lit) = x adjustDyadicRight op lit = case op of WordAddOp -> Just (\y -> y-lit ) IntAddOp -> Just (\y -> y-lit ) WordSubOp -> Just (\y -> y+lit ) IntSubOp -> Just (\y -> y+lit ) XorOp -> Just (\y -> y `xor` lit) XorIOp -> Just (\y -> y `xor` lit) _ -> Nothing adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer) -- Given (lit `op` x) return a function 'f' s.t. f (lit `op` x) = x adjustDyadicLeft lit op = case op of WordAddOp -> Just (\y -> y-lit ) IntAddOp -> Just (\y -> y-lit ) WordSubOp -> Just (\y -> lit-y ) IntSubOp -> Just (\y -> lit-y ) XorOp -> Just (\y -> y `xor` lit) XorIOp -> Just (\y -> y `xor` lit) _ -> Nothing adjustUnary :: PrimOp -> Maybe (Integer -> Integer) -- Given (op x) return a function 'f' s.t. f (op x) = x adjustUnary op = case op of NotOp -> Just (\y -> complement y) NotIOp -> Just (\y -> complement y) IntNegOp -> Just (\y -> negate y ) _ -> Nothing tx_con_tte :: DynFlags -> AltCon -> Maybe AltCon tx_con_tte _ DEFAULT = Just DEFAULT tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt) tx_con_tte dflags (DataAlt dc) -- See Note [caseRules for tagToEnum] = Just $ LitAlt $ mkLitInt dflags $ toInteger $ dataConTagZ dc tx_con_dtt :: Type -> AltCon -> Maybe AltCon tx_con_dtt _ DEFAULT = Just DEFAULT tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _)) | tag >= 0 , tag < n_data_cons = Just (DataAlt (data_cons !! tag)) -- tag is zero-indexed, as is (!!) | otherwise = Nothing where tag = fromInteger i :: ConTagZ tc = tyConAppTyCon ty n_data_cons = tyConFamilySize tc data_cons = tyConDataCons tc tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt) {- Note [caseRules for tagToEnum] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want to transform case tagToEnum x of False -> e1 True -> e2 into case x of 0# -> e1 1# -> e2 This rule eliminates a lot of boilerplate. For if (x>y) then e2 else e1 we generate case tagToEnum (x ># y) of False -> e1 True -> e2 and it is nice to then get rid of the tagToEnum. Beware (#14768): avoid the temptation to map constructor 0 to DEFAULT, in the hope of getting this case (x ># y) of DEFAULT -> e1 1# -> e2 That fails utterly in the case of data Colour = Red | Green | Blue case tagToEnum x of DEFAULT -> e1 Red -> e2 We don't want to get this! case x of DEFAULT -> e1 DEFAULT -> e2 Instead, we deal with turning one branch into DEFAULT in SimplUtils (add_default in mkCase3). Note [caseRules for dataToTag] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See also Note [dataToTag#] in primpops.txt.pp We want to transform case dataToTag x of DEFAULT -> e1 1# -> e2 into case x of DEFAULT -> e1 (:) _ _ -> e2 Note the need for some wildcard binders in the 'cons' case. For the time, we only apply this transformation when the type of `x` is a type headed by a normal tycon. In particular, we do not apply this in the case of a data family tycon, since that would require carefully applying coercion(s) between the data family and the data family instance's representation type, which caseRules isn't currently engineered to handle (#14680). Note [Unreachable caseRules alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Take care if we see something like case dataToTag x of DEFAULT -> e1 -1# -> e2 100 -> e3 because there isn't a data constructor with tag -1 or 100. In this case the out-of-range alterantive is dead code -- we know the range of tags for x. Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating an alternative that is unreachable. You may wonder how this can happen: check out #15436. -} ghc-lib-parser-8.10.2.20200808/compiler/utils/Pretty.hs0000644000000000000000000011317713713635745020316 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} ----------------------------------------------------------------------------- -- | -- Module : Pretty -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : David Terei -- Stability : stable -- Portability : portable -- -- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators -- -- Based on /The Design of a Pretty-printing Library/ -- in Advanced Functional Programming, -- Johan Jeuring and Erik Meijer (eds), LNCS 925 -- -- ----------------------------------------------------------------------------- {- Note [Differences between libraries/pretty and compiler/utils/Pretty.hs] For historical reasons, there are two different copies of `Pretty` in the GHC source tree: * `libraries/pretty` is a submodule containing https://github.com/haskell/pretty. This is the `pretty` library as released on hackage. It is used by several other libraries in the GHC source tree (e.g. template-haskell and Cabal). * `compiler/utils/Pretty.hs` (this module). It is used by GHC only. There is an ongoing effort in https://github.com/haskell/pretty/issues/1 and https://gitlab.haskell.org/ghc/ghc/issues/10735 to try to get rid of GHC's copy of Pretty. Currently, GHC's copy of Pretty resembles pretty-1.1.2.0, with the following major differences: * GHC's copy uses `Faststring` for performance reasons. * GHC's copy has received a backported bugfix for #12227, which was released as pretty-1.1.3.4 ("Remove harmful $! forcing in beside", https://github.com/haskell/pretty/pull/35). Other differences are minor. Both copies define some extra functions and instances not defined in the other copy. To see all differences, do this in a ghc git tree: $ cd libraries/pretty $ git checkout v1.1.2.0 $ cd - $ vimdiff compiler/utils/Pretty.hs \ libraries/pretty/src/Text/PrettyPrint/HughesPJ.hs For parity with `pretty-1.1.2.1`, the following two `pretty` commits would have to be backported: * "Resolve foldr-strictness stack overflow bug" (307b8173f41cd776eae8f547267df6d72bff2d68) * "Special-case reduce for horiz/vert" (c57c7a9dfc49617ba8d6e4fcdb019a3f29f1044c) This has not been done sofar, because these commits seem to cause more allocation in the compiler (see thomie's comments in https://github.com/haskell/pretty/pull/9). -} module Pretty ( -- * The document type Doc, TextDetails(..), -- * Constructing documents -- ** Converting values into documents char, text, ftext, ptext, ztext, sizedText, zeroWidthText, int, integer, float, double, rational, hex, -- ** Simple derived documents semi, comma, colon, space, equals, lparen, rparen, lbrack, rbrack, lbrace, rbrace, -- ** Wrapping documents in delimiters parens, brackets, braces, quotes, quote, doubleQuotes, maybeParens, -- ** Combining documents empty, (<>), (<+>), hcat, hsep, ($$), ($+$), vcat, sep, cat, fsep, fcat, nest, hang, hangNotEmpty, punctuate, -- * Predicates on documents isEmpty, -- * Rendering documents -- ** Rendering with a particular style Style(..), style, renderStyle, Mode(..), -- ** General rendering fullRender, txtPrinter, -- ** GHC-specific rendering printDoc, printDoc_, bufLeftRender -- performance hack ) where import GhcPrelude hiding (error) import BufWrite import FastString import PlainPanic import System.IO import Numeric (showHex) --for a RULES import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) ) import GHC.Ptr ( Ptr(..) ) -- --------------------------------------------------------------------------- -- The Doc calculus {- Laws for $$ ~~~~~~~~~~~ (x $$ y) $$ z = x $$ (y $$ z) empty $$ x = x x $$ empty = x ...ditto $+$... Laws for <> ~~~~~~~~~~~ (x <> y) <> z = x <> (y <> z) empty <> x = empty x <> empty = x ...ditto <+>... Laws for text ~~~~~~~~~~~~~ text s <> text t = text (s++t) text "" <> x = x, if x non-empty ** because of law n6, t2 only holds if x doesn't ** start with `nest'. Laws for nest ~~~~~~~~~~~~~ nest 0 x = x nest k (nest k' x) = nest (k+k') x nest k (x <> y) = nest k x <> nest k y nest k (x $$ y) = nest k x $$ nest k y nest k empty = empty x <> nest k y = x <> y, if x non-empty ** Note the side condition on ! It is this that ** makes it OK for empty to be a left unit for <>. Miscellaneous ~~~~~~~~~~~~~ (text s <> x) $$ y = text s <> ((text "" <> x) $$ nest (-length s) y) (x $$ y) <> z = x $$ (y <> z) if y non-empty Laws for list versions ~~~~~~~~~~~~~~~~~~~~~~ sep (ps++[empty]++qs) = sep (ps ++ qs) ...ditto hsep, hcat, vcat, fill... nest k (sep ps) = sep (map (nest k) ps) ...ditto hsep, hcat, vcat, fill... Laws for oneLiner ~~~~~~~~~~~~~~~~~ oneLiner (nest k p) = nest k (oneLiner p) oneLiner (x <> y) = oneLiner x <> oneLiner y You might think that the following version of would be neater: <3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ nest (-length s) y) But it doesn't work, for if x=empty, we would have text s $$ y = text s <> (empty $$ nest (-length s) y) = text s <> nest (-length s) y -} -- --------------------------------------------------------------------------- -- Operator fixity infixl 6 <> infixl 6 <+> infixl 5 $$, $+$ -- --------------------------------------------------------------------------- -- The Doc data type -- | The abstract type of documents. -- A Doc represents a *set* of layouts. A Doc with -- no occurrences of Union or NoDoc represents just one layout. data Doc = Empty -- empty | NilAbove Doc -- text "" $$ x | TextBeside !TextDetails {-# UNPACK #-} !Int Doc -- text s <> x | Nest {-# UNPACK #-} !Int Doc -- nest k x | Union Doc Doc -- ul `union` ur | NoDoc -- The empty set of documents | Beside Doc Bool Doc -- True <=> space between | Above Doc Bool Doc -- True <=> never overlap {- Here are the invariants: 1) The argument of NilAbove is never Empty. Therefore a NilAbove occupies at least two lines. 2) The argument of @TextBeside@ is never @Nest@. 3) The layouts of the two arguments of @Union@ both flatten to the same string. 4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@. 5) A @NoDoc@ may only appear on the first line of the left argument of an union. Therefore, the right argument of an union can never be equivalent to the empty set (@NoDoc@). 6) An empty document is always represented by @Empty@. It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s. 7) The first line of every layout in the left argument of @Union@ is longer than the first line of any layout in the right argument. (1) ensures that the left argument has a first line. In view of (3), this invariant means that the right argument must have at least two lines. Notice the difference between * NoDoc (no documents) * Empty (one empty document; no height and no width) * text "" (a document containing the empty string; one line high, but has no width) -} -- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside. type RDoc = Doc -- | The TextDetails data type -- -- A TextDetails represents a fragment of text that will be -- output at some point. data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment | Str String -- ^ A whole String fragment | PStr FastString -- a hashed string | ZStr FastZString -- a z-encoded string | LStr {-# UNPACK #-} !PtrString -- a '\0'-terminated array of bytes | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char -- a repeated character (e.g., ' ') instance Show Doc where showsPrec _ doc cont = fullRender (mode style) (lineLength style) (ribbonsPerLine style) txtPrinter cont doc -- --------------------------------------------------------------------------- -- Values and Predicates on GDocs and TextDetails -- | A document of height and width 1, containing a literal character. char :: Char -> Doc char c = textBeside_ (Chr c) 1 Empty -- | A document of height 1 containing a literal string. -- 'text' satisfies the following laws: -- -- * @'text' s '<>' 'text' t = 'text' (s'++'t)@ -- -- * @'text' \"\" '<>' x = x@, if @x@ non-empty -- -- The side condition on the last law is necessary because @'text' \"\"@ -- has height 1, while 'empty' has no height. text :: String -> Doc text s = textBeside_ (Str s) (length s) Empty {-# NOINLINE [0] text #-} -- Give the RULE a chance to fire -- It must wait till after phase 1 when -- the unpackCString first is manifested -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the -- intermediate packing/unpacking of the string. {-# RULES "text/str" forall a. text (unpackCString# a) = ptext (mkPtrString# a) #-} {-# RULES "text/unpackNBytes#" forall p n. text (unpackNBytes# p n) = ptext (PtrString (Ptr p) (I# n)) #-} ftext :: FastString -> Doc ftext s = textBeside_ (PStr s) (lengthFS s) Empty ptext :: PtrString -> Doc ptext s = textBeside_ (LStr s) (lengthPS s) Empty ztext :: FastZString -> Doc ztext s = textBeside_ (ZStr s) (lengthFZS s) Empty -- | Some text with any width. (@text s = sizedText (length s) s@) sizedText :: Int -> String -> Doc sizedText l s = textBeside_ (Str s) l Empty -- | Some text, but without any width. Use for non-printing text -- such as a HTML or Latex tags zeroWidthText :: String -> Doc zeroWidthText = sizedText 0 -- | The empty document, with no height and no width. -- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere -- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. empty :: Doc empty = Empty -- | Returns 'True' if the document is empty isEmpty :: Doc -> Bool isEmpty Empty = True isEmpty _ = False {- Q: What is the reason for negative indentation (i.e. argument to indent is < 0) ? A: This indicates an error in the library client's code. If we compose a <> b, and the first line of b is more indented than some other lines of b, the law (<> eats nests) may cause the pretty printer to produce an invalid layout: doc |0123345 ------------------ d1 |a...| d2 |...b| |c...| d1<>d2 |ab..| c|....| Consider a <> b, let `s' be the length of the last line of `a', `k' the indentation of the first line of b, and `k0' the indentation of the left-most line b_i of b. The produced layout will have negative indentation if `k - k0 > s', as the first line of b will be put on the (s+1)th column, effectively translating b horizontally by (k-s). Now if the i^th line of b has an indentation k0 < (k-s), it is translated out-of-page, causing `negative indentation'. -} semi :: Doc -- ^ A ';' character comma :: Doc -- ^ A ',' character colon :: Doc -- ^ A ':' character space :: Doc -- ^ A space character equals :: Doc -- ^ A '=' character lparen :: Doc -- ^ A '(' character rparen :: Doc -- ^ A ')' character lbrack :: Doc -- ^ A '[' character rbrack :: Doc -- ^ A ']' character lbrace :: Doc -- ^ A '{' character rbrace :: Doc -- ^ A '}' character semi = char ';' comma = char ',' colon = char ':' space = char ' ' equals = char '=' lparen = char '(' rparen = char ')' lbrack = char '[' rbrack = char ']' lbrace = char '{' rbrace = char '}' spaceText, nlText :: TextDetails spaceText = Chr ' ' nlText = Chr '\n' int :: Int -> Doc -- ^ @int n = text (show n)@ integer :: Integer -> Doc -- ^ @integer n = text (show n)@ float :: Float -> Doc -- ^ @float n = text (show n)@ double :: Double -> Doc -- ^ @double n = text (show n)@ rational :: Rational -> Doc -- ^ @rational n = text (show n)@ hex :: Integer -> Doc -- ^ See Note [Print Hexadecimal Literals] int n = text (show n) integer n = text (show n) float n = text (show n) double n = text (show n) rational n = text (show n) hex n = text ('0' : 'x' : padded) where str = showHex n "" strLen = max 1 (length str) len = 2 ^ (ceiling (logBase 2 (fromIntegral strLen :: Double)) :: Int) padded = replicate (len - strLen) '0' ++ str parens :: Doc -> Doc -- ^ Wrap document in @(...)@ brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ braces :: Doc -> Doc -- ^ Wrap document in @{...}@ quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ quote :: Doc -> Doc doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@ quotes p = char '`' <> p <> char '\'' quote p = char '\'' <> p doubleQuotes p = char '"' <> p <> char '"' parens p = char '(' <> p <> char ')' brackets p = char '[' <> p <> char ']' braces p = char '{' <> p <> char '}' {- Note [Print Hexadecimal Literals] Relevant discussions: * Phabricator: https://phabricator.haskell.org/D4465 * GHC Trac: https://gitlab.haskell.org/ghc/ghc/issues/14872 There is a flag `-dword-hex-literals` that causes literals of type `Word#` or `Word64#` to be displayed in hexadecimal instead of decimal when dumping GHC core. It also affects the presentation of these in GHC's error messages. Additionally, the hexadecimal encoding of these numbers is zero-padded so that its length is a power of two. As an example of what this does, consider the following haskell file `Literals.hs`: module Literals where alpha :: Int alpha = 100 + 200 beta :: Word -> Word beta x = x + div maxBound 255 + div 0xFFFFFFFF 255 + 0x0202 We get the following dumped core when we compile on a 64-bit machine with ghc -O2 -fforce-recomp -ddump-simpl -dsuppress-all -dhex-word-literals literals.hs: ==================== Tidy Core ==================== ... omitted for brevity ... -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} alpha alpha = I# 300# -- RHS size: {terms: 12, types: 3, coercions: 0, joins: 0/0} beta beta = \ x_aYE -> case x_aYE of { W# x#_a1v0 -> W# (plusWord# (plusWord# (plusWord# x#_a1v0 0x0101010101010101##) 0x01010101##) 0x0202##) } Notice that the word literals are in hexadecimals and that they have been padded with zeroes so that their lengths are 16, 8, and 4, respectively. -} -- | Apply 'parens' to 'Doc' if boolean is true. maybeParens :: Bool -> Doc -> Doc maybeParens False = id maybeParens True = parens -- --------------------------------------------------------------------------- -- Structural operations on GDocs -- | Perform some simplification of a built up @GDoc@. reduceDoc :: Doc -> RDoc reduceDoc (Beside p g q) = p `seq` g `seq` (beside p g $! reduceDoc q) reduceDoc (Above p g q) = p `seq` g `seq` (above p g $! reduceDoc q) reduceDoc p = p -- | List version of '<>'. hcat :: [Doc] -> Doc hcat = reduceAB . foldr (beside_' False) empty -- | List version of '<+>'. hsep :: [Doc] -> Doc hsep = reduceAB . foldr (beside_' True) empty -- | List version of '$$'. vcat :: [Doc] -> Doc vcat = reduceAB . foldr (above_' False) empty -- | Nest (or indent) a document by a given number of positions -- (which may also be negative). 'nest' satisfies the laws: -- -- * @'nest' 0 x = x@ -- -- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@ -- -- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@ -- -- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@ -- -- * @'nest' k 'empty' = 'empty'@ -- -- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty -- -- The side condition on the last law is needed because -- 'empty' is a left identity for '<>'. nest :: Int -> Doc -> Doc nest k p = mkNest k (reduceDoc p) -- | @hang d1 n d2 = sep [d1, nest n d2]@ hang :: Doc -> Int -> Doc -> Doc hang d1 n d2 = sep [d1, nest n d2] -- | Apply 'hang' to the arguments if the first 'Doc' is not empty. hangNotEmpty :: Doc -> Int -> Doc -> Doc hangNotEmpty d1 n d2 = if isEmpty d1 then d2 else hang d1 n d2 -- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ punctuate :: Doc -> [Doc] -> [Doc] punctuate _ [] = [] punctuate p (x:xs) = go x xs where go y [] = [y] go y (z:zs) = (y <> p) : go z zs -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it mkNest :: Int -> Doc -> Doc mkNest k _ | k `seq` False = undefined mkNest k (Nest k1 p) = mkNest (k + k1) p mkNest _ NoDoc = NoDoc mkNest _ Empty = Empty mkNest 0 p = p mkNest k p = nest_ k p -- mkUnion checks for an empty document mkUnion :: Doc -> Doc -> Doc mkUnion Empty _ = Empty mkUnion p q = p `union_` q beside_' :: Bool -> Doc -> Doc -> Doc beside_' _ p Empty = p beside_' g p q = Beside p g q above_' :: Bool -> Doc -> Doc -> Doc above_' _ p Empty = p above_' g p q = Above p g q reduceAB :: Doc -> Doc reduceAB (Above Empty _ q) = q reduceAB (Beside Empty _ q) = q reduceAB doc = doc nilAbove_ :: RDoc -> RDoc nilAbove_ = NilAbove -- Arg of a TextBeside is always an RDoc textBeside_ :: TextDetails -> Int -> RDoc -> RDoc textBeside_ = TextBeside nest_ :: Int -> RDoc -> RDoc nest_ = Nest union_ :: RDoc -> RDoc -> RDoc union_ = Union -- --------------------------------------------------------------------------- -- Vertical composition @$$@ -- | Above, except that if the last line of the first argument stops -- at least one position before the first line of the second begins, -- these two lines are overlapped. For example: -- -- > text "hi" $$ nest 5 (text "there") -- -- lays out as -- -- > hi there -- -- rather than -- -- > hi -- > there -- -- '$$' is associative, with identity 'empty', and also satisfies -- -- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty. -- ($$) :: Doc -> Doc -> Doc p $$ q = above_ p False q -- | Above, with no overlapping. -- '$+$' is associative, with identity 'empty'. ($+$) :: Doc -> Doc -> Doc p $+$ q = above_ p True q above_ :: Doc -> Bool -> Doc -> Doc above_ p _ Empty = p above_ Empty _ q = q above_ p g q = Above p g q above :: Doc -> Bool -> RDoc -> RDoc above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) above p@(Beside{}) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) above p g q = aboveNest p g 0 (reduceDoc q) -- Specification: aboveNest p g k q = p $g$ (nest k q) aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc aboveNest _ _ k _ | k `seq` False = undefined aboveNest NoDoc _ _ _ = NoDoc aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` aboveNest p2 g k q aboveNest Empty _ k q = mkNest k q aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q) -- p can't be Empty, so no need for mkNest aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest where !k1 = k - sl rest = case p of Empty -> nilAboveNest g k1 q _ -> aboveNest p g k1 q aboveNest (Above {}) _ _ _ = error "aboveNest Above" aboveNest (Beside {}) _ _ _ = error "aboveNest Beside" -- Specification: text s <> nilaboveNest g k q -- = text s <> (text "" $g$ nest k q) nilAboveNest :: Bool -> Int -> RDoc -> RDoc nilAboveNest _ k _ | k `seq` False = undefined nilAboveNest _ _ Empty = Empty -- Here's why the "text s <>" is in the spec! nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q nilAboveNest g k q | not g && k > 0 -- No newline if no overlap = textBeside_ (RStr k ' ') k q | otherwise -- Put them really above = nilAbove_ (mkNest k q) -- --------------------------------------------------------------------------- -- Horizontal composition @<>@ -- We intentionally avoid Data.Monoid.(<>) here due to interactions of -- Data.Monoid.(<>) and (<+>). See -- http://www.haskell.org/pipermail/libraries/2011-November/017066.html -- | Beside. -- '<>' is associative, with identity 'empty'. (<>) :: Doc -> Doc -> Doc p <> q = beside_ p False q -- | Beside, separated by space, unless one of the arguments is 'empty'. -- '<+>' is associative, with identity 'empty'. (<+>) :: Doc -> Doc -> Doc p <+> q = beside_ p True q beside_ :: Doc -> Bool -> Doc -> Doc beside_ p _ Empty = p beside_ Empty _ q = q beside_ p g q = Beside p g q -- Specification: beside g p q = p q beside :: Doc -> Bool -> RDoc -> RDoc beside NoDoc _ _ = NoDoc beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q beside Empty _ q = q beside (Nest k p) g q = nest_ k $! beside p g q beside p@(Beside p1 g1 q1) g2 q2 | g1 == g2 = beside p1 g1 $! beside q1 g2 q2 | otherwise = beside (reduceDoc p) g2 q2 beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q beside (NilAbove p) g q = nilAbove_ $! beside p g q beside (TextBeside s sl p) g q = textBeside_ s sl rest where rest = case p of Empty -> nilBeside g q _ -> beside p g q -- Specification: text "" <> nilBeside g p -- = text "" p nilBeside :: Bool -> RDoc -> RDoc nilBeside _ Empty = Empty -- Hence the text "" in the spec nilBeside g (Nest _ p) = nilBeside g p nilBeside g p | g = textBeside_ spaceText 1 p | otherwise = p -- --------------------------------------------------------------------------- -- Separate, @sep@ -- Specification: sep ps = oneLiner (hsep ps) -- `union` -- vcat ps -- | Either 'hsep' or 'vcat'. sep :: [Doc] -> Doc sep = sepX True -- Separate with spaces -- | Either 'hcat' or 'vcat'. cat :: [Doc] -> Doc cat = sepX False -- Don't sepX :: Bool -> [Doc] -> Doc sepX _ [] = empty sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps -- Specification: sep1 g k ys = sep (x : map (nest k) ys) -- = oneLiner (x nest k (hsep ys)) -- `union` x $$ nest k (vcat ys) sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc sep1 _ _ k _ | k `seq` False = undefined sep1 _ NoDoc _ _ = NoDoc sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` aboveNest q False k (reduceDoc (vcat ys)) sep1 g Empty k ys = mkNest k (sepX g ys) sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) sep1 _ (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys))) sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys) sep1 _ (Above {}) _ _ = error "sep1 Above" sep1 _ (Beside {}) _ _ = error "sep1 Beside" -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys -- Called when we have already found some text in the first item -- We have to eat up nests sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc sepNB g (Nest _ p) k ys = sepNB g p k ys -- Never triggered, because of invariant (2) sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion` -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) nilAboveNest False k (reduceDoc (vcat ys)) where rest | g = hsep ys | otherwise = hcat ys sepNB g p k ys = sep1 g p k ys -- --------------------------------------------------------------------------- -- @fill@ -- | \"Paragraph fill\" version of 'cat'. fcat :: [Doc] -> Doc fcat = fill False -- | \"Paragraph fill\" version of 'sep'. fsep :: [Doc] -> Doc fsep = fill True -- Specification: -- -- fill g docs = fillIndent 0 docs -- -- fillIndent k [] = [] -- fillIndent k [p] = p -- fillIndent k (p1:p2:ps) = -- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) -- (remove_nests (oneLiner p2) : ps) -- `Union` -- (p1 $*$ nest (-k) (fillIndent 0 ps)) -- -- $*$ is defined for layouts (not Docs) as -- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2 -- | otherwise = layout1 $+$ layout2 fill :: Bool -> [Doc] -> RDoc fill _ [] = empty fill g (p:ps) = fill1 g (reduceDoc p) 0 ps fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc fill1 _ _ k _ | k `seq` False = undefined fill1 _ NoDoc _ _ = NoDoc fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` aboveNest q False k (fill g ys) fill1 g Empty k ys = mkNest k (fill g ys) fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) fill1 _ (Above {}) _ _ = error "fill1 Above" fill1 _ (Beside {}) _ _ = error "fill1 Beside" fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc fillNB _ _ k _ | k `seq` False = undefined fillNB g (Nest _ p) k ys = fillNB g p k ys -- Never triggered, because of invariant (2) fillNB _ Empty _ [] = Empty fillNB g Empty k (Empty:ys) = fillNB g Empty k ys fillNB g Empty k (y:ys) = fillNBE g k y ys fillNB g p k ys = fill1 g p k ys fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc fillNBE g k y ys = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys) -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) `mkUnion` nilAboveNest False k (fill g (y:ys)) where k' = if g then k - 1 else k elideNest :: Doc -> Doc elideNest (Nest _ d) = d elideNest d = d -- --------------------------------------------------------------------------- -- Selecting the best layout best :: Int -- Line length -> Int -- Ribbon length -> RDoc -> RDoc -- No unions in here! best w0 r = get w0 where get :: Int -- (Remaining) width of line -> Doc -> Doc get w _ | w == 0 && False = undefined get _ Empty = Empty get _ NoDoc = NoDoc get w (NilAbove p) = nilAbove_ (get w p) get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p) get w (Nest k p) = nest_ k (get (w - k) p) get w (p `Union` q) = nicest w r (get w p) (get w q) get _ (Above {}) = error "best get Above" get _ (Beside {}) = error "best get Beside" get1 :: Int -- (Remaining) width of line -> Int -- Amount of first line already eaten up -> Doc -- This is an argument to TextBeside => eat Nests -> Doc -- No unions in here! get1 w _ _ | w == 0 && False = undefined get1 _ _ Empty = Empty get1 _ _ NoDoc = NoDoc get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p) get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p) get1 w sl (Nest _ p) = get1 w sl p get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) (get1 w sl q) get1 _ _ (Above {}) = error "best get1 Above" get1 _ _ (Beside {}) = error "best get1 Beside" nicest :: Int -> Int -> Doc -> Doc -> Doc nicest !w !r = nicest1 w r 0 nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p | otherwise = q fits :: Int -- Space available -> Doc -> Bool -- True if *first line* of Doc fits in space available fits n _ | n < 0 = False fits _ NoDoc = False fits _ Empty = True fits _ (NilAbove _) = True fits n (TextBeside _ sl p) = fits (n - sl) p fits _ (Above {}) = error "fits Above" fits _ (Beside {}) = error "fits Beside" fits _ (Union {}) = error "fits Union" fits _ (Nest {}) = error "fits Nest" -- | @first@ returns its first argument if it is non-empty, otherwise its second. first :: Doc -> Doc -> Doc first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused | otherwise = q nonEmptySet :: Doc -> Bool nonEmptySet NoDoc = False nonEmptySet (_ `Union` _) = True nonEmptySet Empty = True nonEmptySet (NilAbove _) = True nonEmptySet (TextBeside _ _ p) = nonEmptySet p nonEmptySet (Nest _ p) = nonEmptySet p nonEmptySet (Above {}) = error "nonEmptySet Above" nonEmptySet (Beside {}) = error "nonEmptySet Beside" -- @oneLiner@ returns the one-line members of the given set of @GDoc@s. oneLiner :: Doc -> Doc oneLiner NoDoc = NoDoc oneLiner Empty = Empty oneLiner (NilAbove _) = NoDoc oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) oneLiner (Nest k p) = nest_ k (oneLiner p) oneLiner (p `Union` _) = oneLiner p oneLiner (Above {}) = error "oneLiner Above" oneLiner (Beside {}) = error "oneLiner Beside" -- --------------------------------------------------------------------------- -- Rendering -- | A rendering style. data Style = Style { mode :: Mode -- ^ The rendering mode , lineLength :: Int -- ^ Length of line, in chars , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length } -- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@). style :: Style style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode } -- | Rendering mode. data Mode = PageMode -- ^ Normal | ZigZagMode -- ^ With zig-zag cuts | LeftMode -- ^ No indentation, infinitely long lines | OneLineMode -- ^ All on one line -- | Render the @Doc@ to a String using the given @Style@. renderStyle :: Style -> Doc -> String renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) txtPrinter "" -- | Default TextDetails printer txtPrinter :: TextDetails -> String -> String txtPrinter (Chr c) s = c:s txtPrinter (Str s1) s2 = s1 ++ s2 txtPrinter (PStr s1) s2 = unpackFS s1 ++ s2 txtPrinter (ZStr s1) s2 = zString s1 ++ s2 txtPrinter (LStr s1) s2 = unpackPtrString s1 ++ s2 txtPrinter (RStr n c) s2 = replicate n c ++ s2 -- | The general rendering interface. fullRender :: Mode -- ^ Rendering mode -> Int -- ^ Line length -> Float -- ^ Ribbons per line -> (TextDetails -> a -> a) -- ^ What to do with text -> a -- ^ What to do at the end -> Doc -- ^ The document -> a -- ^ Result fullRender OneLineMode _ _ txt end doc = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc) fullRender LeftMode _ _ txt end doc = easyDisplay nlText first txt end (reduceDoc doc) fullRender m lineLen ribbons txt rest doc = display m lineLen ribbonLen txt rest doc' where doc' = best bestLineLen ribbonLen (reduceDoc doc) bestLineLen, ribbonLen :: Int ribbonLen = round (fromIntegral lineLen / ribbons) bestLineLen = case m of ZigZagMode -> maxBound _ -> lineLen easyDisplay :: TextDetails -> (Doc -> Doc -> Doc) -> (TextDetails -> a -> a) -> a -> Doc -> a easyDisplay nlSpaceText choose txt end = lay where lay NoDoc = error "easyDisplay: NoDoc" lay (Union p q) = lay (choose p q) lay (Nest _ p) = lay p lay Empty = end lay (NilAbove p) = nlSpaceText `txt` lay p lay (TextBeside s _ p) = s `txt` lay p lay (Above {}) = error "easyDisplay Above" lay (Beside {}) = error "easyDisplay Beside" display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a display m !page_width !ribbon_width txt end doc = case page_width - ribbon_width of { gap_width -> case gap_width `quot` 2 of { shift -> let lay k _ | k `seq` False = undefined lay k (Nest k1 p) = lay (k + k1) p lay _ Empty = end lay k (NilAbove p) = nlText `txt` lay k p lay k (TextBeside s sl p) = case m of ZigZagMode | k >= gap_width -> nlText `txt` ( Str (replicate shift '/') `txt` ( nlText `txt` lay1 (k - shift) s sl p )) | k < 0 -> nlText `txt` ( Str (replicate shift '\\') `txt` ( nlText `txt` lay1 (k + shift) s sl p )) _ -> lay1 k s sl p lay _ (Above {}) = error "display lay Above" lay _ (Beside {}) = error "display lay Beside" lay _ NoDoc = error "display lay NoDoc" lay _ (Union {}) = error "display lay Union" lay1 !k s !sl p = let !r = k + sl in indent k (s `txt` lay2 r p) lay2 k _ | k `seq` False = undefined lay2 k (NilAbove p) = nlText `txt` lay k p lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p lay2 k (Nest _ p) = lay2 k p lay2 _ Empty = end lay2 _ (Above {}) = error "display lay2 Above" lay2 _ (Beside {}) = error "display lay2 Beside" lay2 _ NoDoc = error "display lay2 NoDoc" lay2 _ (Union {}) = error "display lay2 Union" indent !n r = RStr n ' ' `txt` r in lay 0 doc }} printDoc :: Mode -> Int -> Handle -> Doc -> IO () -- printDoc adds a newline to the end printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "") printDoc_ :: Mode -> Int -> Handle -> Doc -> IO () -- printDoc_ does not add a newline at the end, so that -- successive calls can output stuff on the same line -- Rather like putStr vs putStrLn printDoc_ LeftMode _ hdl doc = do { printLeftRender hdl doc; hFlush hdl } printDoc_ mode pprCols hdl doc = do { fullRender mode pprCols 1.5 put done doc ; hFlush hdl } where put (Chr c) next = hPutChar hdl c >> next put (Str s) next = hPutStr hdl s >> next put (PStr s) next = hPutStr hdl (unpackFS s) >> next -- NB. not hPutFS, we want this to go through -- the I/O library's encoding layer. (#3398) put (ZStr s) next = hPutFZS hdl s >> next put (LStr s) next = hPutPtrString hdl s >> next put (RStr n c) next = hPutStr hdl (replicate n c) >> next done = return () -- hPutChar hdl '\n' -- some versions of hPutBuf will barf if the length is zero hPutPtrString :: Handle -> PtrString -> IO () hPutPtrString _handle (PtrString _ 0) = return () hPutPtrString handle (PtrString a l) = hPutBuf handle a l -- Printing output in LeftMode is performance critical: it's used when -- dumping C and assembly output, so we allow ourselves a few dirty -- hacks: -- -- (1) we specialise fullRender for LeftMode with IO output. -- -- (2) we add a layer of buffering on top of Handles. Handles -- don't perform well with lots of hPutChars, which is mostly -- what we're doing here, because Handles have to be thread-safe -- and async exception-safe. We only have a single thread and don't -- care about exceptions, so we add a layer of fast buffering -- over the Handle interface. printLeftRender :: Handle -> Doc -> IO () printLeftRender hdl doc = do b <- newBufHandle hdl bufLeftRender b doc bFlush b bufLeftRender :: BufHandle -> Doc -> IO () bufLeftRender b doc = layLeft b (reduceDoc doc) layLeft :: BufHandle -> Doc -> IO () layLeft b _ | b `seq` False = undefined -- make it strict in b layLeft _ NoDoc = error "layLeft: NoDoc" layLeft b (Union p q) = layLeft b $! first p q layLeft b (Nest _ p) = layLeft b $! p layLeft b Empty = bPutChar b '\n' layLeft b (NilAbove p) = p `seq` (bPutChar b '\n' >> layLeft b p) layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p) where put b _ | b `seq` False = undefined put b (Chr c) = bPutChar b c put b (Str s) = bPutStr b s put b (PStr s) = bPutFS b s put b (ZStr s) = bPutFZS b s put b (LStr s) = bPutPtrString b s put b (RStr n c) = bPutReplicate b n c layLeft _ _ = panic "layLeft: Unhandled case" -- Define error=panic, for easier comparison with libraries/pretty. error :: String -> a error = panic ghc-lib-parser-8.10.2.20200808/compiler/prelude/PrimOp.hs0000644000000000000000000006362413713635745020536 0ustar0000000000000000{- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[PrimOp]{Primitive operations (machine-level)} -} {-# LANGUAGE CPP #-} module PrimOp ( PrimOp(..), PrimOpVecCat(..), allThePrimOps, primOpType, primOpSig, primOpTag, maxPrimOpTag, primOpOcc, primOpWrapperId, tagToEnumKey, primOpOutOfLine, primOpCodeSize, primOpOkForSpeculation, primOpOkForSideEffects, primOpIsCheap, primOpFixity, getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..), PrimCall(..) ) where #include "GhclibHsVersions.h" import GhcPrelude import TysPrim import TysWiredIn import CmmType import Demand import Id ( Id, mkVanillaGlobalWithInfo ) import IdInfo ( vanillaIdInfo, setCafInfo, CafInfo(NoCafRefs) ) import Name import PrelNames ( gHC_PRIMOPWRAPPERS ) import TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) import Type import RepType ( typePrimRep1, tyConPrimRep1 ) import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..), SourceText(..) ) import SrcLoc ( wiredInSrcSpan ) import ForeignCall ( CLabelString ) import Unique ( Unique, mkPrimOpIdUnique, mkPrimOpWrapperUnique ) import Outputable import FastString import Module ( UnitId ) {- ************************************************************************ * * \subsection[PrimOp-datatype]{Datatype for @PrimOp@ (an enumeration)} * * ************************************************************************ These are in \tr{state-interface.verb} order. -} -- supplies: -- data PrimOp = ... #include "primop-data-decl.hs-incl" -- supplies -- primOpTag :: PrimOp -> Int #include "primop-tag.hs-incl" primOpTag _ = error "primOpTag: unknown primop" instance Eq PrimOp where op1 == op2 = primOpTag op1 == primOpTag op2 instance Ord PrimOp where op1 < op2 = primOpTag op1 < primOpTag op2 op1 <= op2 = primOpTag op1 <= primOpTag op2 op1 >= op2 = primOpTag op1 >= primOpTag op2 op1 > op2 = primOpTag op1 > primOpTag op2 op1 `compare` op2 | op1 < op2 = LT | op1 == op2 = EQ | otherwise = GT instance Outputable PrimOp where ppr op = pprPrimOp op data PrimOpVecCat = IntVec | WordVec | FloatVec -- An @Enum@-derived list would be better; meanwhile... (ToDo) allThePrimOps :: [PrimOp] allThePrimOps = #include "primop-list.hs-incl" tagToEnumKey :: Unique tagToEnumKey = mkPrimOpIdUnique (primOpTag TagToEnumOp) {- ************************************************************************ * * \subsection[PrimOp-info]{The essential info about each @PrimOp@} * * ************************************************************************ The @String@ in the @PrimOpInfos@ is the ``base name'' by which the user may refer to the primitive operation. The conventional \tr{#}-for- unboxed ops is added on later. The reason for the funny characters in the names is so we do not interfere with the programmer's Haskell name spaces. We use @PrimKinds@ for the ``type'' information, because they're (slightly) more convenient to use than @TyCons@. -} data PrimOpInfo = Dyadic OccName -- string :: T -> T -> T Type | Monadic OccName -- string :: T -> T Type | Compare OccName -- string :: T -> T -> Int# Type | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T [TyVar] [Type] Type mkDyadic, mkMonadic, mkCompare :: FastString -> Type -> PrimOpInfo mkDyadic str ty = Dyadic (mkVarOccFS str) ty mkMonadic str ty = Monadic (mkVarOccFS str) ty mkCompare str ty = Compare (mkVarOccFS str) ty mkGenPrimOp :: FastString -> [TyVar] -> [Type] -> Type -> PrimOpInfo mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty {- ************************************************************************ * * \subsubsection{Strictness} * * ************************************************************************ Not all primops are strict! -} primOpStrictness :: PrimOp -> Arity -> StrictSig -- See Demand.StrictnessInfo for discussion of what the results -- The arity should be the arity of the primop; that's why -- this function isn't exported. #include "primop-strictness.hs-incl" {- ************************************************************************ * * \subsubsection{Fixity} * * ************************************************************************ -} primOpFixity :: PrimOp -> Maybe Fixity #include "primop-fixity.hs-incl" {- ************************************************************************ * * \subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops} * * ************************************************************************ @primOpInfo@ gives all essential information (from which everything else, notably a type, can be constructed) for each @PrimOp@. -} primOpInfo :: PrimOp -> PrimOpInfo #include "primop-primop-info.hs-incl" primOpInfo _ = error "primOpInfo: unknown primop" {- Here are a load of comments from the old primOp info: A @Word#@ is an unsigned @Int#@. @decodeFloat#@ is given w/ Integer-stuff (it's similar). @decodeDouble#@ is given w/ Integer-stuff (it's similar). Decoding of floating-point numbers is sorta Integer-related. Encoding is done with plain ccalls now (see PrelNumExtra.hs). A @Weak@ Pointer is created by the @mkWeak#@ primitive: mkWeak# :: k -> v -> f -> State# RealWorld -> (# State# RealWorld, Weak# v #) In practice, you'll use the higher-level data Weak v = Weak# v mkWeak :: k -> v -> IO () -> IO (Weak v) The following operation dereferences a weak pointer. The weak pointer may have been finalized, so the operation returns a result code which must be inspected before looking at the dereferenced value. deRefWeak# :: Weak# v -> State# RealWorld -> (# State# RealWorld, v, Int# #) Only look at v if the Int# returned is /= 0 !! The higher-level op is deRefWeak :: Weak v -> IO (Maybe v) Weak pointers can be finalized early by using the finalize# operation: finalizeWeak# :: Weak# v -> State# RealWorld -> (# State# RealWorld, Int#, IO () #) The Int# returned is either 0 if the weak pointer has already been finalized, or it has no finalizer (the third component is then invalid). 1 if the weak pointer is still alive, with the finalizer returned as the third component. A {\em stable name/pointer} is an index into a table of stable name entries. Since the garbage collector is told about stable pointers, it is safe to pass a stable pointer to external systems such as C routines. \begin{verbatim} makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) freeStablePtr :: StablePtr# a -> State# RealWorld -> State# RealWorld deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int# \end{verbatim} It may seem a bit surprising that @makeStablePtr#@ is a @IO@ operation since it doesn't (directly) involve IO operations. The reason is that if some optimisation pass decided to duplicate calls to @makeStablePtr#@ and we only pass one of the stable pointers over, a massive space leak can result. Putting it into the IO monad prevents this. (Another reason for putting them in a monad is to ensure correct sequencing wrt the side-effecting @freeStablePtr@ operation.) An important property of stable pointers is that if you call makeStablePtr# twice on the same object you get the same stable pointer back. Note that we can implement @freeStablePtr#@ using @_ccall_@ (and, besides, it's not likely to be used from Haskell) so it's not a primop. Question: Why @RealWorld@ - won't any instance of @_ST@ do the job? [ADR] Stable Names ~~~~~~~~~~~~ A stable name is like a stable pointer, but with three important differences: (a) You can't deRef one to get back to the original object. (b) You can convert one to an Int. (c) You don't need to 'freeStableName' The existence of a stable name doesn't guarantee to keep the object it points to alive (unlike a stable pointer), hence (a). Invariants: (a) makeStableName always returns the same value for a given object (same as stable pointers). (b) if two stable names are equal, it implies that the objects from which they were created were the same. (c) stableNameToInt always returns the same Int for a given stable name. These primops are pretty weird. tagToEnum# :: Int -> a (result type must be an enumerated type) The constraints aren't currently checked by the front end, but the code generator will fall over if they aren't satisfied. ************************************************************************ * * Which PrimOps are out-of-line * * ************************************************************************ Some PrimOps need to be called out-of-line because they either need to perform a heap check or they block. -} primOpOutOfLine :: PrimOp -> Bool #include "primop-out-of-line.hs-incl" {- ************************************************************************ * * Failure and side effects * * ************************************************************************ Note [Checking versus non-checking primops] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In GHC primops break down into two classes: a. Checking primops behave, for instance, like division. In this case the primop may throw an exception (e.g. division-by-zero) and is consequently is marked with the can_fail flag described below. The ability to fail comes at the expense of precluding some optimizations. b. Non-checking primops behavior, for instance, like addition. While addition can overflow it does not produce an exception. So can_fail is set to False, and we get more optimisation opportunities. But we must never throw an exception, so we cannot rewrite to a call to error. It is important that a non-checking primop never be transformed in a way that would cause it to bottom. Doing so would violate Core's let/app invariant (see Note [CoreSyn let/app invariant] in CoreSyn) which is critical to the simplifier's ability to float without fear of changing program meaning. Note [PrimOp can_fail and has_side_effects] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Both can_fail and has_side_effects mean that the primop has some effect that is not captured entirely by its result value. ---------- has_side_effects --------------------- A primop "has_side_effects" if it has some *write* effect, visible elsewhere - writing to the world (I/O) - writing to a mutable data structure (writeIORef) - throwing a synchronous Haskell exception Often such primops have a type like State -> input -> (State, output) so the state token guarantees ordering. In general we rely *only* on data dependencies of the state token to enforce write-effect ordering * NB1: if you inline unsafePerformIO, you may end up with side-effecting ops whose 'state' output is discarded. And programmers may do that by hand; see #9390. That is why we (conservatively) do not discard write-effecting primops even if both their state and result is discarded. * NB2: We consider primops, such as raiseIO#, that can raise a (Haskell) synchronous exception to "have_side_effects" but not "can_fail". We must be careful about not discarding such things; see the paper "A semantics for imprecise exceptions". * NB3: *Read* effects (like reading an IORef) don't count here, because it doesn't matter if we don't do them, or do them more than once. *Sequencing* is maintained by the data dependency of the state token. ---------- can_fail ---------------------------- A primop "can_fail" if it can fail with an *unchecked* exception on some elements of its input domain. Main examples: division (fails on zero demoninator) array indexing (fails if the index is out of bounds) An "unchecked exception" is one that is an outright error, (not turned into a Haskell exception,) such as seg-fault or divide-by-zero error. Such can_fail primops are ALWAYS surrounded with a test that checks for the bad cases, but we need to be very careful about code motion that might move it out of the scope of the test. Note [Transformations affected by can_fail and has_side_effects] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The can_fail and has_side_effects properties have the following effect on program transformations. Summary table is followed by details. can_fail has_side_effects Discard YES NO Float in YES YES Float out NO NO Duplicate YES NO * Discarding. case (a `op` b) of _ -> rhs ===> rhs You should not discard a has_side_effects primop; e.g. case (writeIntArray# a i v s of (# _, _ #) -> True Arguably you should be able to discard this, since the returned stat token is not used, but that relies on NEVER inlining unsafePerformIO, and programmers sometimes write this kind of stuff by hand (#9390). So we (conservatively) never discard a has_side_effects primop. However, it's fine to discard a can_fail primop. For example case (indexIntArray# a i) of _ -> True We can discard indexIntArray#; it has can_fail, but not has_side_effects; see #5658 which was all about this. Notice that indexIntArray# is (in a more general handling of effects) read effect, but we don't care about that here, and treat read effects as *not* has_side_effects. Similarly (a `/#` b) can be discarded. It can seg-fault or cause a hardware exception, but not a synchronous Haskell exception. Synchronous Haskell exceptions, e.g. from raiseIO#, are treated as has_side_effects and hence are not discarded. * Float in. You can float a can_fail or has_side_effects primop *inwards*, but not inside a lambda (see Duplication below). * Float out. You must not float a can_fail primop *outwards* lest you escape the dynamic scope of the test. Example: case d ># 0# of True -> case x /# d of r -> r +# 1 False -> 0 Here we must not float the case outwards to give case x/# d of r -> case d ># 0# of True -> r +# 1 False -> 0 Nor can you float out a has_side_effects primop. For example: if blah then case writeMutVar# v True s0 of (# s1 #) -> s1 else s0 Notice that s0 is mentioned in both branches of the 'if', but only one of these two will actually be consumed. But if we float out to case writeMutVar# v True s0 of (# s1 #) -> if blah then s1 else s0 the writeMutVar will be performed in both branches, which is utterly wrong. * Duplication. You cannot duplicate a has_side_effect primop. You might wonder how this can occur given the state token threading, but just look at Control.Monad.ST.Lazy.Imp.strictToLazy! We get something like this p = case readMutVar# s v of (# s', r #) -> (S# s', r) s' = case p of (s', r) -> s' r = case p of (s', r) -> r (All these bindings are boxed.) If we inline p at its two call sites, we get a catastrophe: because the read is performed once when s' is demanded, and once when 'r' is demanded, which may be much later. Utterly wrong. #3207 is real example of this happening. However, it's fine to duplicate a can_fail primop. That is really the only difference between can_fail and has_side_effects. Note [Implementation: how can_fail/has_side_effects affect transformations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ How do we ensure that that floating/duplication/discarding are done right in the simplifier? Two main predicates on primpops test these flags: primOpOkForSideEffects <=> not has_side_effects primOpOkForSpeculation <=> not (has_side_effects || can_fail) * The "no-float-out" thing is achieved by ensuring that we never let-bind a can_fail or has_side_effects primop. The RHS of a let-binding (which can float in and out freely) satisfies exprOkForSpeculation; this is the let/app invariant. And exprOkForSpeculation is false of can_fail and has_side_effects. * So can_fail and has_side_effects primops will appear only as the scrutinees of cases, and that's why the FloatIn pass is capable of floating case bindings inwards. * The no-duplicate thing is done via primOpIsCheap, by making has_side_effects things (very very very) not-cheap! -} primOpHasSideEffects :: PrimOp -> Bool #include "primop-has-side-effects.hs-incl" primOpCanFail :: PrimOp -> Bool #include "primop-can-fail.hs-incl" primOpOkForSpeculation :: PrimOp -> Bool -- See Note [PrimOp can_fail and has_side_effects] -- See comments with CoreUtils.exprOkForSpeculation -- primOpOkForSpeculation => primOpOkForSideEffects primOpOkForSpeculation op = primOpOkForSideEffects op && not (primOpOutOfLine op || primOpCanFail op) -- I think the "out of line" test is because out of line things can -- be expensive (eg sine, cosine), and so we may not want to speculate them primOpOkForSideEffects :: PrimOp -> Bool primOpOkForSideEffects op = not (primOpHasSideEffects op) {- Note [primOpIsCheap] ~~~~~~~~~~~~~~~~~~~~ @primOpIsCheap@, as used in \tr{SimplUtils.hs}. For now (HACK WARNING), we just borrow some other predicates for a what-should-be-good-enough test. "Cheap" means willing to call it more than once, and/or push it inside a lambda. The latter could change the behaviour of 'seq' for primops that can fail, so we don't treat them as cheap. -} primOpIsCheap :: PrimOp -> Bool -- See Note [PrimOp can_fail and has_side_effects] primOpIsCheap op = primOpOkForSpeculation op -- In March 2001, we changed this to -- primOpIsCheap op = False -- thereby making *no* primops seem cheap. But this killed eta -- expansion on case (x ==# y) of True -> \s -> ... -- which is bad. In particular a loop like -- doLoop n = loop 0 -- where -- loop i | i == n = return () -- | otherwise = bar i >> loop (i+1) -- allocated a closure every time round because it doesn't eta expand. -- -- The problem that originally gave rise to the change was -- let x = a +# b *# c in x +# x -- were we don't want to inline x. But primopIsCheap doesn't control -- that (it's exprIsDupable that does) so the problem doesn't occur -- even if primOpIsCheap sometimes says 'True'. {- ************************************************************************ * * PrimOp code size * * ************************************************************************ primOpCodeSize ~~~~~~~~~~~~~~ Gives an indication of the code size of a primop, for the purposes of calculating unfolding sizes; see CoreUnfold.sizeExpr. -} primOpCodeSize :: PrimOp -> Int #include "primop-code-size.hs-incl" primOpCodeSizeDefault :: Int primOpCodeSizeDefault = 1 -- CoreUnfold.primOpSize already takes into account primOpOutOfLine -- and adds some further costs for the args in that case. primOpCodeSizeForeignCall :: Int primOpCodeSizeForeignCall = 4 {- ************************************************************************ * * PrimOp types * * ************************************************************************ -} primOpType :: PrimOp -> Type -- you may want to use primOpSig instead primOpType op = case primOpInfo op of Dyadic _occ ty -> dyadic_fun_ty ty Monadic _occ ty -> monadic_fun_ty ty Compare _occ ty -> compare_fun_ty ty GenPrimOp _occ tyvars arg_tys res_ty -> mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty) primOpOcc :: PrimOp -> OccName primOpOcc op = case primOpInfo op of Dyadic occ _ -> occ Monadic occ _ -> occ Compare occ _ -> occ GenPrimOp occ _ _ _ -> occ {- Note [Primop wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~ Previously hasNoBinding would claim that PrimOpIds didn't have a curried function definition. This caused quite some trouble as we would be forced to eta expand unsaturated primop applications very late in the Core pipeline. Not only would this produce unnecessary thunks, but it would also result in nasty inconsistencies in CAFfy-ness determinations (see #16846 and Note [CAFfyness inconsistencies due to late eta expansion] in TidyPgm). However, it was quite unnecessary for hasNoBinding to claim this; primops in fact *do* have curried definitions which are found in GHC.PrimopWrappers, which is auto-generated by utils/genprimops from prelude/primops.txt.pp. These wrappers are standard Haskell functions mirroring the types of the primops they wrap. For instance, in the case of plusInt# we would have: module GHC.PrimopWrappers where import GHC.Prim as P plusInt# a b = P.plusInt# a b We now take advantage of these curried definitions by letting hasNoBinding claim that PrimOpIds have a curried definition and then rewrite any unsaturated PrimOpId applications that we find during CoreToStg as applications of the associated wrapper (e.g. `GHC.Prim.plusInt# 3#` will get rewritten to `GHC.PrimopWrappers.plusInt# 3#`).` The Id of the wrapper for a primop can be found using 'PrimOp.primOpWrapperId'. Nota Bene: GHC.PrimopWrappers is needed *regardless*, because it's used by GHCi, which does not implement primops direct at all. -} -- | Returns the 'Id' of the wrapper associated with the given 'PrimOp'. -- See Note [Primop wrappers]. primOpWrapperId :: PrimOp -> Id primOpWrapperId op = mkVanillaGlobalWithInfo name ty info where info = setCafInfo vanillaIdInfo NoCafRefs name = mkExternalName uniq gHC_PRIMOPWRAPPERS (primOpOcc op) wiredInSrcSpan uniq = mkPrimOpWrapperUnique (primOpTag op) ty = primOpType op isComparisonPrimOp :: PrimOp -> Bool isComparisonPrimOp op = case primOpInfo op of Compare {} -> True _ -> False -- primOpSig is like primOpType but gives the result split apart: -- (type variables, argument types, result type) -- It also gives arity, strictness info primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictSig) primOpSig op = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity) where arity = length arg_tys (tyvars, arg_tys, res_ty) = case (primOpInfo op) of Monadic _occ ty -> ([], [ty], ty ) Dyadic _occ ty -> ([], [ty,ty], ty ) Compare _occ ty -> ([], [ty,ty], intPrimTy) GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) data PrimOpResultInfo = ReturnsPrim PrimRep | ReturnsAlg TyCon -- Some PrimOps need not return a manifest primitive or algebraic value -- (i.e. they might return a polymorphic value). These PrimOps *must* -- be out of line, or the code generator won't work. getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo getPrimOpResultInfo op = case (primOpInfo op) of Dyadic _ ty -> ReturnsPrim (typePrimRep1 ty) Monadic _ ty -> ReturnsPrim (typePrimRep1 ty) Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon) GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc) | otherwise -> ReturnsAlg tc where tc = tyConAppTyCon ty -- All primops return a tycon-app result -- The tycon can be an unboxed tuple or sum, though, -- which gives rise to a ReturnAlg {- We do not currently make use of whether primops are commutable. We used to try to move constants to the right hand side for strength reduction. -} {- commutableOp :: PrimOp -> Bool #include "primop-commutable.hs-incl" -} -- Utils: dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type dyadic_fun_ty ty = mkVisFunTys [ty, ty] ty monadic_fun_ty ty = mkVisFunTy ty ty compare_fun_ty ty = mkVisFunTys [ty, ty] intPrimTy -- Output stuff: pprPrimOp :: PrimOp -> SDoc pprPrimOp other_op = pprOccName (primOpOcc other_op) {- ************************************************************************ * * \subsubsection[PrimCall]{User-imported primitive calls} * * ************************************************************************ -} data PrimCall = PrimCall CLabelString UnitId instance Outputable PrimCall where ppr (PrimCall lbl pkgId) = text "__primcall" <+> ppr pkgId <+> ppr lbl ghc-lib-parser-8.10.2.20200808/compiler/parser/RdrHsSyn.hs0000644000000000000000000037513713713635745020705 0ustar0000000000000000-- -- (c) The University of Glasgow 2002-2006 -- -- Functions over HsSyn specialised to RdrName. {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module RdrHsSyn ( mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString, mkHsDo, mkSpliceDecl, mkRoleAnnotDecl, mkClassDecl, mkTyData, mkDataFamInst, mkTySynonym, mkTyFamInstEqn, mkStandaloneKindSig, mkTyFamInst, mkFamDecl, mkLHsSigType, mkInlinePragma, mkPatSynMatchGroup, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp mkTyClD, mkInstD, mkRdrRecordCon, mkRdrRecordUpd, setRdrNameSpace, filterCTuple, cvBindGroup, cvBindsAndSigs, cvTopDecls, placeHolderPunRhs, -- Stuff to do with Foreign declarations mkImport, parseCImport, mkExport, mkExtName, -- RdrName -> CLabelString mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName mkConDeclH98, -- Bunch of functions in the parser monad for -- checking and constructing values checkImportDecl, checkExpBlockArguments, checkPrecP, -- Int -> P Int checkContext, -- HsType -> P HsContext checkPattern, -- HsExp -> P HsPat checkPattern_msg, isBangRdr, isTildeRdr, checkMonadComp, -- P (HsStmtContext RdrName) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSigLhs, LRuleTyTmVar, RuleTyTmVar(..), mkRuleBndrs, mkRuleTyVarBndrs, checkRuleTyVarBndrNames, checkRecordSyntax, checkEmptyGADTs, addFatalError, hintBangPat, TyEl(..), mergeOps, mergeDataCon, -- Help with processing exports ImpExpSubSpec(..), ImpExpQcSpec(..), mkModuleImpExp, mkTypeImpExp, mkImpExpSubSpec, checkImportSpec, -- Token symbols forallSym, starSym, -- Warnings and errors warnStarIsType, warnPrepositiveQualifiedModule, failOpFewArgs, failOpNotEnabledImportQualifiedPost, failOpImportQualifiedTwice, SumOrTuple (..), -- Expression/command/pattern ambiguity resolution PV, runPV, ECP(ECP, runECP_PV), runECP_P, DisambInfixOp(..), DisambECP(..), ecpFromExp, ecpFromCmd, PatBuilder, patBuilderBang, ) where import GhcPrelude import GHC.Hs -- Lots of it import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) import DataCon ( DataCon, dataConTyCon ) import ConLike ( ConLike(..) ) import CoAxiom ( Role, fsFromRole ) import RdrName import Name import BasicTypes import TcEvidence ( idHsWrapper ) import Lexer import Lexeme ( isLexCon ) import Type ( TyThing(..), funTyCon ) import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon, nilDataConName, nilDataConKey, listTyConName, listTyConKey, eqTyCon_RDR, tupleTyConName, cTupleTyConNameArity_maybe ) import ForeignCall import PrelNames ( allNameStrings ) import SrcLoc import Unique ( hasKey ) import OrdList ( OrdList, fromOL ) import Bag ( emptyBag, consBag ) import Outputable import FastString import Maybes import Util import ApiAnnotation import Data.List import DynFlags ( WarningFlag(..), DynFlags ) import ErrUtils ( Messages ) import Control.Monad import Text.ParserCombinators.ReadP as ReadP import Data.Char import qualified Data.Monoid as Monoid import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) #include "GhclibHsVersions.h" {- ********************************************************************** Construction functions for Rdr stuff ********************************************************************* -} -- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and -- datacon by deriving them from the name of the class. We fill in the names -- for the tycon and datacon corresponding to the class, by deriving them -- from the name of the class itself. This saves recording the names in the -- interface file (which would be equally good). -- Similarly for mkConDecl, mkClassOpSig and default-method names. -- *** See Note [The Naming story] in GHC.Hs.Decls **** mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) mkTyClD (dL->L loc d) = cL loc (TyClD noExtField d) mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) mkInstD (dL->L loc d) = cL loc (InstD noExtField d) mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a,[LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) -> P (LTyClDecl GhcPs) mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls ; let cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan ; return (cL loc (ClassDecl { tcdCExt = noExtField, tcdCtxt = cxt , tcdLName = cls, tcdTyVars = tyvars , tcdFixity = fixity , tcdFDs = snd (unLoc fds) , tcdSigs = mkClassOpSigs sigs , tcdMeths = binds , tcdATs = ats, tcdATDefs = at_defs , tcdDocs = docs })) } mkTyData :: SrcSpan -> NewOrData -> Maybe (Located CType) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (LTyClDecl GhcPs) mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (cL loc (DataDecl { tcdDExt = noExtField, tcdLName = tc, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn })) } mkDataDefn :: NewOrData -> Maybe (Located CType) -> Maybe (LHsContext GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (HsDataDefn GhcPs) mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv = do { checkDatatypeContext mcxt ; let cxt = fromMaybe (noLoc []) mcxt ; return (HsDataDefn { dd_ext = noExtField , dd_ND = new_or_data, dd_cType = cType , dd_ctxt = cxt , dd_cons = data_cons , dd_kindSig = ksig , dd_derivs = maybe_deriv }) } mkTySynonym :: SrcSpan -> LHsType GhcPs -- LHS -> LHsType GhcPs -- RHS -> P (LTyClDecl GhcPs) mkTySynonym loc lhs rhs = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan ; return (cL loc (SynDecl { tcdSExt = noExtField , tcdLName = tc, tcdTyVars = tyvars , tcdFixity = fixity , tcdRhs = rhs })) } mkStandaloneKindSig :: SrcSpan -> Located [Located RdrName] -- LHS -> LHsKind GhcPs -- RHS -> P (LStandaloneKindSig GhcPs) mkStandaloneKindSig loc lhs rhs = do { vs <- mapM check_lhs_name (unLoc lhs) ; v <- check_singular_lhs (reverse vs) ; return $ cL loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) } where check_lhs_name v@(unLoc->name) = if isUnqual name && isTcOcc (rdrNameOcc name) then return v else addFatalError (getLoc v) $ hang (text "Expected an unqualified type constructor:") 2 (ppr v) check_singular_lhs vs = case vs of [] -> panic "mkStandaloneKindSig: empty left-hand side" [v] -> return v _ -> addFatalError (getLoc lhs) $ vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:") 2 (pprWithCommas ppr vs) , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ] mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs] -> LHsType GhcPs -> LHsType GhcPs -> P (TyFamInstEqn GhcPs,[AddAnn]) mkTyFamInstEqn bndrs lhs rhs = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; return (mkHsImplicitBndrs (FamEqn { feqn_ext = noExtField , feqn_tycon = tc , feqn_bndrs = bndrs , feqn_pats = tparams , feqn_fixity = fixity , feqn_rhs = rhs }), ann) } mkDataFamInst :: SrcSpan -> NewOrData -> Maybe (Located CType) -> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs] , LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (LInstDecl GhcPs) mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) ksig data_cons maybe_deriv = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (cL loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs (FamEqn { feqn_ext = noExtField , feqn_tycon = tc , feqn_bndrs = bndrs , feqn_pats = tparams , feqn_fixity = fixity , feqn_rhs = defn }))))) } mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> P (LInstDecl GhcPs) mkTyFamInst loc eqn = return (cL loc (TyFamInstD noExtField (TyFamInstDecl eqn))) mkFamDecl :: SrcSpan -> FamilyInfo GhcPs -> LHsType GhcPs -- LHS -> Located (FamilyResultSig GhcPs) -- Optional result signature -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation -> P (LTyClDecl GhcPs) mkFamDecl loc info lhs ksig injAnn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan ; return (cL loc (FamDecl noExtField (FamilyDecl { fdExt = noExtField , fdInfo = info, fdLName = tc , fdTyVars = tyvars , fdFixity = fixity , fdResultSig = ksig , fdInjectivityAnn = injAnn }))) } where equals_or_where = case info of DataFamily -> empty OpenTypeFamily -> empty ClosedTypeFamily {} -> whereDots mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs -- If the user wrote -- [pads| ... ] then return a QuasiQuoteD -- $(e) then return a SpliceD -- but if she wrote, say, -- f x then behave as if she'd written $(f x) -- ie a SpliceD -- -- Typed splices are not allowed at the top level, thus we do not represent them -- as spliced declaration. See #10945 mkSpliceDecl lexpr@(dL->L loc expr) | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice) | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice) | otherwise = SpliceD noExtField (SpliceDecl noExtField (cL loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice) mkRoleAnnotDecl :: SrcSpan -> Located RdrName -- type being annotated -> [Located (Maybe FastString)] -- roles -> P (LRoleAnnotDecl GhcPs) mkRoleAnnotDecl loc tycon roles = do { roles' <- mapM parse_role roles ; return $ cL loc $ RoleAnnotDecl noExtField tycon roles' } where role_data_type = dataTypeOf (undefined :: Role) all_roles = map fromConstr $ dataTypeConstrs role_data_type possible_roles = [(fsFromRole role, role) | role <- all_roles] parse_role (dL->L loc_role Nothing) = return $ cL loc_role Nothing parse_role (dL->L loc_role (Just role)) = case lookup role possible_roles of Just found_role -> return $ cL loc_role $ Just found_role Nothing -> let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in addFatalError loc_role (text "Illegal role name" <+> quotes (ppr role) $$ suggestions nearby) parse_role _ = panic "parse_role: Impossible Match" -- due to #15884 suggestions [] = empty suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r) -- will this last case ever happen?? suggestions list = hang (text "Perhaps you meant one of these:") 2 (pprWithCommas (quotes . ppr) list) {- ********************************************************************** #cvBinds-etc# Converting to @HsBinds@, etc. ********************************************************************* -} -- | Function definitions are restructured here. Each is assumed to be recursive -- initially, and non recursive definitions are discovered by the dependency -- analyser. -- | Groups together bindings for a single function cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] cvTopDecls decls = go (fromOL decls) where go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] go [] = [] go ((dL->L l (ValD x b)) : ds) = cL l' (ValD x b') : go ds' where (dL->L l' b', ds') = getMonoBind (cL l b) ds go (d : ds) = d : go ds -- Declaration list may only contain value bindings and signatures. cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) cvBindGroup binding = do { (mbs, sigs, fam_ds, tfam_insts , dfam_insts, _) <- cvBindsAndSigs binding ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) return $ ValBinds noExtField mbs sigs } cvBindsAndSigs :: OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) -- Input decls contain just value bindings and signatures -- and in case of class or instance declarations also -- associated type declarations. They might also contain Haddock comments. cvBindsAndSigs fb = go (fromOL fb) where go [] = return (emptyBag, [], [], [], [], []) go ((dL->L l (ValD _ b)) : ds) = do { (bs, ss, ts, tfis, dfis, docs) <- go ds' ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) } where (b', ds') = getMonoBind (cL l b) ds go ((dL->L l decl) : ds) = do { (bs, ss, ts, tfis, dfis, docs) <- go ds ; case decl of SigD _ s -> return (bs, cL l s : ss, ts, tfis, dfis, docs) TyClD _ (FamDecl _ t) -> return (bs, ss, cL l t : ts, tfis, dfis, docs) InstD _ (TyFamInstD { tfid_inst = tfi }) -> return (bs, ss, ts, cL l tfi : tfis, dfis, docs) InstD _ (DataFamInstD { dfid_inst = dfi }) -> return (bs, ss, ts, tfis, cL l dfi : dfis, docs) DocD _ d -> return (bs, ss, ts, tfis, dfis, cL l d : docs) SpliceD _ d -> addFatalError l $ hang (text "Declaration splices are allowed only" <+> text "at the top level:") 2 (ppr d) _ -> pprPanic "cvBindsAndSigs" (ppr decl) } ----------------------------------------------------------------------------- -- Group function bindings into equation groups getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs] -> (LHsBind GhcPs, [LHsDecl GhcPs]) -- Suppose (b',ds') = getMonoBind b ds -- ds is a list of parsed bindings -- b is a MonoBinds that has just been read off the front -- Then b' is the result of grouping more equations from ds that -- belong with b into a single MonoBinds, and ds' is the depleted -- list of parsed bindings. -- -- All Haddock comments between equations inside the group are -- discarded. -- -- No AndMonoBinds or EmptyMonoBinds here; just single equations getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1) , fun_matches = MG { mg_alts = (dL->L _ mtchs1) } })) binds | has_args mtchs1 = go mtchs1 loc1 binds [] where go mtchs loc ((dL->L loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2) , fun_matches = MG { mg_alts = (dL->L _ mtchs2) } }))) : binds) _ | f1 == f2 = go (mtchs2 ++ mtchs) (combineSrcSpans loc loc2) binds [] go mtchs loc (doc_decl@(dL->L loc2 (DocD {})) : binds) doc_decls = let doc_decls' = doc_decl : doc_decls in go mtchs (combineSrcSpans loc loc2) binds doc_decls' go mtchs loc binds doc_decls = ( cL loc (makeFunBind fun_id1 (reverse mtchs)) , (reverse doc_decls) ++ binds) -- Reverse the final matches, to get it back in the right order -- Do the same thing with the trailing doc comments getMonoBind bind binds = (bind, binds) has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool has_args [] = panic "RdrHsSyn:has_args" has_args ((dL->L _ (Match { m_pats = args })) : _) = not (null args) -- Don't group together FunBinds if they have -- no arguments. This is necessary now that variable bindings -- with no arguments are now treated as FunBinds rather -- than pattern bindings (tests/rename/should_fail/rnfail002). has_args ((dL->L _ (XMatch nec)) : _) = noExtCon nec has_args (_ : _) = panic "has_args:Impossible Match" -- due to #15884 {- ********************************************************************** #PrefixToHS-utils# Utilities for conversion ********************************************************************* -} {- Note [Parsing data constructors is hard] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The problem with parsing data constructors is that they look a lot like types. Compare: (s1) data T = C t1 t2 (s2) type T = C t1 t2 Syntactically, there's little difference between these declarations, except in (s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor. This similarity would pose no problem if we knew ahead of time if we are parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple (but wrong!) rule comes to mind: in 'data' declarations assume we are parsing data constructors, and in other contexts (e.g. 'type' declarations) assume we are parsing type constructors. This simple rule does not work because of two problematic cases: (p1) data T = C t1 t2 :+ t3 (p2) data T = C t1 t2 => t3 In (p1) we encounter (:+) and it turns out we are parsing an infix data declaration, so (C t1 t2) is a type and 'C' is a type constructor. In (p2) we encounter (=>) and it turns out we are parsing an existential context, so (C t1 t2) is a constraint and 'C' is a type constructor. As the result, in order to determine whether (C t1 t2) declares a data constructor, a type, or a context, we would need unlimited lookahead which 'happy' is not so happy with. To further complicate matters, the interpretation of (!) and (~) is different in constructors and types: (b1) type T = C ! D (b2) data T = C ! D (b3) data T = C ! D => E In (b1) and (b3), (!) is a type operator with two arguments: 'C' and 'D'. At the same time, in (b2) it is a strictness annotation: 'C' is a data constructor with a single strict argument 'D'. For the programmer, these cases are usually easy to tell apart due to whitespace conventions: (b2) data T = C !D -- no space after the bang hints that -- it is a strictness annotation For the parser, on the other hand, this whitespace does not matter. We cannot tell apart (b2) from (b3) until we encounter (=>), so it requires unlimited lookahead. The solution that accounts for all of these issues is to initially parse data declarations and types as a reversed list of TyEl: data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs) | TyElBang | TyElTilde | ... For example, both occurences of (C ! D) in the following example are parsed into equal lists of TyEl: data T = C ! D => C ! D results in [ TyElOpd (HsTyVar "D") , TyElBang , TyElOpd (HsTyVar "C") ] Note that elements are in reverse order. Also, 'C' is parsed as a type constructor (HsTyVar) even when it is a data constructor. We fix this in `tyConToDataCon`. By the time the list of TyEl is assembled, we have looked ahead enough to decide whether to reduce using `mergeOps` (for types) or `mergeDataCon` (for data constructors). These functions are where the actual job of parsing is done. -} -- | Reinterpret a type constructor, including type operators, as a data -- constructor. -- See Note [Parsing data constructors is hard] tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName) tyConToDataCon loc tc | isTcOcc occ || isDataOcc occ , isLexCon (occNameFS occ) = return (cL loc (setRdrNameSpace tc srcDataName)) | otherwise = Left (loc, msg) where occ = rdrNameOcc tc msg = text "Not a data constructor:" <+> quotes (ppr tc) mkPatSynMatchGroup :: Located RdrName -> Located (OrdList (LHsDecl GhcPs)) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) = do { matches <- mapM fromDecl (fromOL decls) ; when (null matches) (wrongNumberErr loc) ; return $ mkMatchGroup FromSource matches } where fromDecl (dL->L loc decl@(ValD _ (PatBind _ pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details)) rhs _))) = do { unless (name == patsyn_name) $ wrongNameBindingErr loc decl ; match <- case details of PrefixCon pats -> return $ Match { m_ext = noExtField , m_ctxt = ctxt, m_pats = pats , m_grhss = rhs } where ctxt = FunRhs { mc_fun = ln , mc_fixity = Prefix , mc_strictness = NoSrcStrict } InfixCon p1 p2 -> return $ Match { m_ext = noExtField , m_ctxt = ctxt , m_pats = [p1, p2] , m_grhss = rhs } where ctxt = FunRhs { mc_fun = ln , mc_fixity = Infix , mc_strictness = NoSrcStrict } RecCon{} -> recordPatSynErr loc pat ; return $ cL loc match } fromDecl (dL->L loc decl) = extraDeclErr loc decl extraDeclErr loc decl = addFatalError loc $ text "pattern synonym 'where' clause must contain a single binding:" $$ ppr decl wrongNameBindingErr loc decl = addFatalError loc $ text "pattern synonym 'where' clause must bind the pattern synonym's name" <+> quotes (ppr patsyn_name) $$ ppr decl wrongNumberErr loc = addFatalError loc $ text "pattern synonym 'where' clause cannot be empty" $$ text "In the pattern synonym declaration for: " <+> ppr (patsyn_name) recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr loc pat = addFatalError loc $ text "record syntax not supported for pattern synonym declarations:" $$ ppr pat mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs -> ConDecl GhcPs mkConDeclH98 name mb_forall mb_cxt args = ConDeclH98 { con_ext = noExtField , con_name = name , con_forall = noLoc $ isJust mb_forall , con_ex_tvs = mb_forall `orElse` [] , con_mb_cxt = mb_cxt , con_args = args , con_doc = Nothing } mkGadtDecl :: [Located RdrName] -> LHsType GhcPs -- Always a HsForAllTy -> (ConDecl GhcPs, [AddAnn]) mkGadtDecl names ty = (ConDeclGADT { con_g_ext = noExtField , con_names = names , con_forall = cL l $ isLHsForAllTy ty' , con_qvars = mkHsQTvs tvs , con_mb_cxt = mcxt , con_args = args , con_res_ty = res_ty , con_doc = Nothing } , anns1 ++ anns2) where (ty'@(dL->L l _),anns1) = peel_parens ty [] (tvs, rho) = splitLHsForAllTyInvis ty' (mcxt, tau, anns2) = split_rho rho [] split_rho (dL->L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann = (Just cxt, tau, ann) split_rho (dL->L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l) split_rho tau ann = (Nothing, tau, ann) (args, res_ty) = split_tau tau -- See Note [GADT abstract syntax] in GHC.Hs.Decls split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty)) = (RecCon (cL loc rf), res_ty) split_tau tau = (PrefixCon [], tau) peel_parens (dL->L l (HsParTy _ ty)) ann = peel_parens ty (ann++mkParensApiAnn l) peel_parens ty ann = (ty, ann) setRdrNameSpace :: RdrName -> NameSpace -> RdrName -- ^ This rather gruesome function is used mainly by the parser. -- When parsing: -- -- > data T a = T | T1 Int -- -- we parse the data constructors as /types/ because of parser ambiguities, -- so then we need to change the /type constr/ to a /data constr/ -- -- The exact-name case /can/ occur when parsing: -- -- > data [] a = [] | a : [a] -- -- For the exact-name case we return an original name. setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) setRdrNameSpace (Exact n) ns | Just thing <- wiredInNameTyThing_maybe n = setWiredInNameSpace thing ns -- Preserve Exact Names for wired-in things, -- notably tuples and lists | isExternalName n = Orig (nameModule n) occ | otherwise -- This can happen when quoting and then -- splicing a fixity declaration for a type = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)) where occ = setOccNameSpace ns (nameOccName n) setWiredInNameSpace :: TyThing -> NameSpace -> RdrName setWiredInNameSpace (ATyCon tc) ns | isDataConNameSpace ns = ty_con_data_con tc | isTcClsNameSpace ns = Exact (getName tc) -- No-op setWiredInNameSpace (AConLike (RealDataCon dc)) ns | isTcClsNameSpace ns = data_con_ty_con dc | isDataConNameSpace ns = Exact (getName dc) -- No-op setWiredInNameSpace thing ns = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing) ty_con_data_con :: TyCon -> RdrName ty_con_data_con tc | isTupleTyCon tc , Just dc <- tyConSingleDataCon_maybe tc = Exact (getName dc) | tc `hasKey` listTyConKey = Exact nilDataConName | otherwise -- See Note [setRdrNameSpace for wired-in names] = Unqual (setOccNameSpace srcDataName (getOccName tc)) data_con_ty_con :: DataCon -> RdrName data_con_ty_con dc | let tc = dataConTyCon dc , isTupleTyCon tc = Exact (getName tc) | dc `hasKey` nilDataConKey = Exact listTyConName | otherwise -- See Note [setRdrNameSpace for wired-in names] = Unqual (setOccNameSpace tcClsName (getOccName dc)) -- | Replaces constraint tuple names with corresponding boxed ones. filterCTuple :: RdrName -> RdrName filterCTuple (Exact n) | Just arity <- cTupleTyConNameArity_maybe n = Exact $ tupleTyConName BoxedTuple arity filterCTuple rdr = rdr {- Note [setRdrNameSpace for wired-in names] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In GHC.Types, which declares (:), we have infixr 5 : The ambiguity about which ":" is meant is resolved by parsing it as a data constructor, but then using dataTcOccs to try the type constructor too; and that in turn calls setRdrNameSpace to change the name-space of ":" to tcClsName. There isn't a corresponding ":" type constructor, but it's painful to make setRdrNameSpace partial, so we just make an Unqual name instead. It really doesn't matter! -} eitherToP :: Either (SrcSpan, SDoc) a -> P a -- Adapts the Either monad to the P monad eitherToP (Left (loc, doc)) = addFatalError loc doc eitherToP (Right thing) = return thing checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] -> P ( LHsQTyVars GhcPs -- the synthesized type variables , [AddAnn] ) -- action which adds annotations -- ^ Check whether the given list of type parameters are all type variables -- (possibly with a kind signature). checkTyVars pp_what equals_or_where tc tparms = do { (tvs, anns) <- fmap unzip $ mapM check tparms ; return (mkHsQTvs tvs, concat anns) } where check (HsTypeArg _ ki@(L loc _)) = addFatalError loc $ vcat [ text "Unexpected type application" <+> text "@" <> ppr ki , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)] check (HsValArg ty) = chkParens [] ty check (HsArgPar sp) = addFatalError sp $ vcat [text "Malformed" <+> pp_what <+> text "declaration for" <+> quotes (ppr tc)] -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr GhcPs, [AddAnn]) chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty chkParens acc ty = do tv <- chk ty return (tv, reverse acc) -- Check that the name space is correct! chk :: LHsType GhcPs -> P (LHsTyVarBndr GhcPs) chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k)) | isRdrTyVar tv = return (cL l (KindedTyVar noExtField (cL lv tv) k)) chk (dL->L l (HsTyVar _ _ (dL->L ltv tv))) | isRdrTyVar tv = return (cL l (UserTyVar noExtField (cL ltv tv))) chk t@(dL->L loc _) = addFatalError loc $ vcat [ text "Unexpected type" <+> quotes (ppr t) , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes tc' , vcat[ (text "A" <+> pp_what <+> ptext (sLit "declaration should have form")) , nest 2 (pp_what <+> tc' <+> hsep (map text (takeList tparms allNameStrings)) <+> equals_or_where) ] ] -- Avoid printing a constraint tuple in the error message. Print -- a plain old tuple instead (since that's what the user probably -- wrote). See #14907 tc' = ppr $ fmap filterCTuple tc whereDots, equalsDots :: SDoc -- Second argument to checkTyVars whereDots = text "where ..." equalsDots = text "= ..." checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () checkDatatypeContext Nothing = return () checkDatatypeContext (Just c) = do allowed <- getBit DatatypeContextsBit unless allowed $ addError (getLoc c) (text "Illegal datatype context (use DatatypeContexts):" <+> pprLHsContext c) type LRuleTyTmVar = Located RuleTyTmVar data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs)) -- ^ Essentially a wrapper for a @RuleBndr GhcPs@ -- turns RuleTyTmVars into RuleBnrs - this is straightforward mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs] mkRuleBndrs = fmap (fmap cvt_one) where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExtField v cvt_one (RuleTyTmVar v (Just sig)) = RuleBndrSig noExtField v (mkLHsSigWcType sig) -- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs] mkRuleTyVarBndrs = fmap (fmap cvt_one) where cvt_one (RuleTyTmVar v Nothing) = UserTyVar noExtField (fmap tm_to_ty v) cvt_one (RuleTyTmVar v (Just sig)) = KindedTyVar noExtField (fmap tm_to_ty v) sig -- takes something in namespace 'varName' to something in namespace 'tvName' tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ) tm_to_ty _ = panic "mkRuleTyVarBndrs" -- See note [Parsing explicit foralls in Rules] in Parser.y checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P () checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) where check (dL->L loc (Unqual occ)) = do when ((occNameString occ ==) `any` ["forall","family","role"]) (addFatalError loc (text $ "parse error on input " ++ occNameString occ)) check _ = panic "checkRuleTyVarBndrNames" checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a) checkRecordSyntax lr@(dL->L loc r) = do allowed <- getBit TraditionalRecordSyntaxBit unless allowed $ addError loc $ text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r return lr -- | Check if the gadt_constrlist is empty. Only raise parse error for -- `data T where` to avoid affecting existing error message, see #8258. checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs]) -> P (Located ([AddAnn], [LConDecl GhcPs])) checkEmptyGADTs gadts@(dL->L span (_, [])) -- Empty GADT declaration. = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax unless gadtSyntax $ addError span $ vcat [ text "Illegal keyword 'where' in data declaration" , text "Perhaps you intended to use GADTs or a similar language" , text "extension to enable syntax: data T where" ] return gadts checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration. checkTyClHdr :: Bool -- True <=> class header -- False <=> type header -> LHsType GhcPs -> P (Located RdrName, -- the head symbol (type or class name) [LHsTypeArg GhcPs], -- parameters of head symbol LexicalFixity, -- the declaration is in infix format [AddAnn]) -- API Annotation for HsParTy when stripping parens -- Well-formedness check and decomposition of type and class heads. -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) -- Int :*: Bool into (:*:, [Int, Bool]) -- returning the pieces checkTyClHdr is_cls ty = goL ty [] [] Prefix where goL (dL->L l ty) acc ann fix = go l ty acc ann fix -- workaround to define '*' despite StarIsType go lp (HsParTy _ (dL->L l (HsStarTy _ isUni))) acc ann fix = do { warnStarBndr l ; let name = mkOccName tcClsName (starSym isUni) ; return (cL l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) } go _ (HsTyVar _ _ ltc@(dL->L _ tc)) acc ann fix | isRdrTc tc = return (ltc, acc, fix, ann) go _ (HsOpTy _ t1 ltc@(dL->L _ tc) t2) acc ann _fix | isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann) go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix = return (cL l (nameRdrName tup_name), map HsValArg ts, fix, ann) where arity = length ts tup_name | is_cls = cTupleTyConName arity | otherwise = getName (tupleTyCon Boxed arity) -- See Note [Unit tuples] in GHC.Hs.Types (TODO: is this still relevant?) go l _ _ _ _ = addFatalError l (text "Malformed head of type or class declaration:" <+> ppr ty) -- | Yield a parse error if we have a function applied directly to a do block -- etc. and BlockArguments is not enabled. checkExpBlockArguments :: LHsExpr GhcPs -> PV () checkCmdBlockArguments :: LHsCmd GhcPs -> PV () (checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd) where checkExpr :: LHsExpr GhcPs -> PV () checkExpr expr = case unLoc expr of HsDo _ DoExpr _ -> check "do block" expr HsDo _ MDoExpr _ -> check "mdo block" expr HsLam {} -> check "lambda expression" expr HsCase {} -> check "case expression" expr HsLamCase {} -> check "lambda-case expression" expr HsLet {} -> check "let expression" expr HsIf {} -> check "if expression" expr HsProc {} -> check "proc expression" expr _ -> return () checkCmd :: LHsCmd GhcPs -> PV () checkCmd cmd = case unLoc cmd of HsCmdLam {} -> check "lambda command" cmd HsCmdCase {} -> check "case command" cmd HsCmdIf {} -> check "if command" cmd HsCmdLet {} -> check "let command" cmd HsCmdDo {} -> check "do command" cmd _ -> return () check :: (HasSrcSpan a, Outputable a) => String -> a -> PV () check element a = do blockArguments <- getBit BlockArgumentsBit unless blockArguments $ addError (getLoc a) $ text "Unexpected " <> text element <> text " in function application:" $$ nest 4 (ppr a) $$ text "You could write it with parentheses" $$ text "Or perhaps you meant to enable BlockArguments?" -- | Validate the context constraints and break up a context into a list -- of predicates. -- -- @ -- (Eq a, Ord b) --> [Eq a, Ord b] -- Eq a --> [Eq a] -- (Eq a) --> [Eq a] -- (((Eq a))) --> [Eq a] -- @ checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) checkContext (dL->L l orig_t) = check [] (cL l orig_t) where check anns (dL->L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts)) -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can -- be used as context constraints. = return (anns ++ mkParensApiAnn lp,cL l ts) -- Ditto () check anns (dL->L lp1 (HsParTy _ ty)) -- to be sure HsParTy doesn't get into the way = check anns' ty where anns' = if l == lp1 then anns else (anns ++ mkParensApiAnn lp1) -- no need for anns, returning original check _anns t = checkNoDocs msg t *> return ([],cL l [cL l orig_t]) msg = text "data constructor context" -- | Check recursively if there are any 'HsDocTy's in the given type. -- This only works on a subset of types produced by 'btype_no_ops' checkNoDocs :: SDoc -> LHsType GhcPs -> P () checkNoDocs msg ty = go ty where go (dL->L _ (HsAppKindTy _ ty ki)) = go ty *> go ki go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2 go (dL->L l (HsDocTy _ t ds)) = addError l $ hsep [ text "Unexpected haddock", quotes (ppr ds) , text "on", msg, quotes (ppr t) ] go _ = pure () checkImportDecl :: Maybe (Located Token) -> Maybe (Located Token) -> P () checkImportDecl mPre mPost = do let whenJust mg f = maybe (pure ()) f mg importQualifiedPostEnabled <- getBit ImportQualifiedPostBit -- Error if 'qualified' found in postpostive position and -- 'ImportQualifiedPost' is not in effect. whenJust mPost $ \post -> when (not importQualifiedPostEnabled) $ failOpNotEnabledImportQualifiedPost (getLoc post) -- Error if 'qualified' occurs in both pre and postpositive -- positions. whenJust mPost $ \post -> when (isJust mPre) $ failOpImportQualifiedTwice (getLoc post) -- Warn if 'qualified' found in prepositive position and -- 'Opt_WarnPrepositiveQualifiedModule' is enabled. whenJust mPre $ \pre -> warnPrepositiveQualifiedModule (getLoc pre) -- ------------------------------------------------------------------------- -- Checking Patterns. -- We parse patterns as expressions and check for valid patterns below, -- converting the expression into a pattern at the same time. checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern = runPV . checkLPat checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs) checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat) checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e@(dL->L l _) = checkPat l e [] checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs) checkPat loc (dL->L l e@(PatBuilderVar (dL->L _ c))) args | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args))) | not (null args) && patIsRec c = localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $ patFail l (ppr e) checkPat loc e args -- OK to let this happen even if bang-patterns -- are not enabled, because there is no valid -- non-bang-pattern parse of (C ! e) | Just (e', args') <- splitBang e = do { args'' <- mapM checkLPat args' ; checkPat loc e' (args'' ++ args) } checkPat loc (dL->L _ (PatBuilderApp f e)) args = do p <- checkLPat e checkPat loc f (p : args) checkPat loc (dL->L _ e) [] = do p <- checkAPat loc e return (cL loc p) checkPat loc e _ = patFail loc (ppr e) checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat loc e0 = do nPlusKPatterns <- getBit NPlusKPatternsBit case e0 of PatBuilderPat p -> return p PatBuilderVar x -> return (VarPat noExtField x) -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve -- NB. Negative *primitive* literals are already handled by the lexer PatBuilderOverLit pos_lit -> return (mkNPat (cL loc pos_lit) Nothing) PatBuilderBang lb e -- (! x) -> do { hintBangPat loc e0 ; e' <- checkLPat e ; addAnnotation loc AnnBang lb ; return (BangPat noExtField e') } -- n+k patterns PatBuilderOpApp (dL->L nloc (PatBuilderVar (dL->L _ n))) (dL->L _ plus) (dL->L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) | nPlusKPatterns && (plus == plus_RDR) -> return (mkNPlusKPat (cL nloc n) (cL lloc lit)) PatBuilderOpApp l (dL->L cl c) r | isRdrDataCon c -> do l <- checkLPat l r <- checkLPat r return (ConPatIn (cL cl c) (InfixCon l r)) PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExtField)) _ -> patFail loc (ppr e0) placeHolderPunRhs :: DisambECP b => PV (Located b) -- The RHS of a punned record field will be filled in by the renamer -- It's better not to make it an error, in case we want to print it when -- debugging placeHolderPunRhs = mkHsVarPV (noLoc pun_RDR) plus_RDR, pun_RDR :: RdrName plus_RDR = mkUnqual varName (fsLit "+") -- Hack pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") isBangRdr, isTildeRdr :: RdrName -> Bool isBangRdr (Unqual occ) = occNameFS occ == fsLit "!" isBangRdr _ = False isTildeRdr = (==eqTyCon_RDR) checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs)) -> PV (LHsRecField GhcPs (LPat GhcPs)) checkPatField (dL->L l fld) = do p <- checkLPat (hsRecFieldArg fld) return (cL l (fld { hsRecFieldArg = p })) patFail :: SrcSpan -> SDoc -> PV a patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e patIsRec :: RdrName -> Bool patIsRec e = e == mkUnqual varName (fsLit "rec") --------------------------------------------------------------------------- -- Check Equation Syntax checkValDef :: SrcStrictness -> Located (PatBuilder GhcPs) -> Maybe (LHsType GhcPs) -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkValDef _strictness lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding = do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat checkPatBind lhs' grhss checkValDef strictness lhs Nothing g@(dL->L l (_,grhss)) = do { mb_fun <- isFunLhs lhs ; case mb_fun of Just (fun, is_infix, pats, ann) -> checkFunBind strictness ann (getLoc lhs) fun is_infix pats (cL l grhss) Nothing -> do lhs' <- checkPattern lhs checkPatBind lhs' g } checkFunBind :: SrcStrictness -> [AddAnn] -> SrcSpan -> Located RdrName -> LexicalFixity -> [Located (PatBuilder GhcPs)] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkFunBind strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss) = do ps <- mapM checkPattern pats let match_span = combineSrcSpans lhs_loc rhs_span -- Add back the annotations stripped from any HsPar values in the lhs -- mapM_ (\a -> a match_span) ann return (ann, makeFunBind fun [cL match_span (Match { m_ext = noExtField , m_ctxt = FunRhs { mc_fun = fun , mc_fixity = is_infix , mc_strictness = strictness } , m_pats = ps , m_grhss = grhss })]) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs -- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too makeFunBind fn ms = FunBind { fun_ext = noExtField, fun_id = fn, fun_matches = mkMatchGroup FromSource ms, fun_co_fn = idHsWrapper, fun_tick = [] } checkPatBind :: LPat GhcPs -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkPatBind lhs (dL->L _ (_,grhss)) = return ([],PatBind noExtField lhs grhss ([],[])) checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v))) | isUnqual v , not (isDataOcc (rdrNameOcc v)) = return lrdr checkValSigLhs lhs@(dL->L l _) = addFatalError l ((text "Invalid type signature:" <+> ppr lhs <+> text ":: ...") $$ text hint) where hint | foreign_RDR `looks_like` lhs = "Perhaps you meant to use ForeignFunctionInterface?" | default_RDR `looks_like` lhs = "Perhaps you meant to use DefaultSignatures?" | pattern_RDR `looks_like` lhs = "Perhaps you meant to use PatternSynonyms?" | otherwise = "Should be of form :: " -- A common error is to forget the ForeignFunctionInterface flag -- so check for that, and suggest. cf #3805 -- Sadly 'foreign import' still barfs 'parse error' because -- 'import' is a keyword looks_like s (dL->L _ (HsVar _ (dL->L _ v))) = v == s looks_like s (dL->L _ (HsApp _ lhs _)) = looks_like s lhs looks_like _ _ = False foreign_RDR = mkUnqual varName (fsLit "foreign") default_RDR = mkUnqual varName (fsLit "default") pattern_RDR = mkUnqual varName (fsLit "pattern") checkDoAndIfThenElse :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c) => a -> Bool -> b -> Bool -> c -> PV () checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr | semiThen || semiElse = do doAndIfThenElse <- getBit DoAndIfThenElseBit unless doAndIfThenElse $ do addError (combineLocs guardExpr elseExpr) (text "Unexpected semi-colons in conditional:" $$ nest 4 expr $$ text "Perhaps you meant to use DoAndIfThenElse?") | otherwise = return () where pprOptSemi True = semi pprOptSemi False = empty expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+> text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+> text "else" <+> ppr elseExpr -- The parser left-associates, so there should -- not be any OpApps inside the e's splitBang :: Located (PatBuilder GhcPs) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)]) -- Splits (f ! g a b) into (f, [(! g), a, b]) splitBang (dL->L _ (PatBuilderOpApp l_arg op r_arg)) | isBangRdr (unLoc op) = Just (l_arg, cL l' (PatBuilderBang (getLoc op) arg1) : argns) where l' = combineLocs op arg1 (arg1,argns) = split_bang r_arg [] split_bang (dL->L _ (PatBuilderApp f e)) es = split_bang f (e:es) split_bang e es = (e,es) splitBang _ = Nothing -- See Note [isFunLhs vs mergeDataCon] isFunLhs :: Located (PatBuilder GhcPs) -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn])) -- A variable binding is parsed as a FunBind. -- Just (fun, is_infix, arg_pats) if e is a function LHS -- -- The whole LHS is parsed as a single expression. -- Any infix operators on the LHS will parse left-associatively -- E.g. f !x y !z -- will parse (rather strangely) as -- (f ! x y) ! z -- It's up to isFunLhs to sort out the mess -- -- a .!. !b isFunLhs e = go e [] [] where go (dL->L loc (PatBuilderVar (dL->L _ f))) es ann | not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann)) go (dL->L _ (PatBuilderApp f e)) es ann = go f (e:es) ann go (dL->L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) -- Things of the form `!x` are also FunBinds -- See Note [FunBind vs PatBind] go (dL->L _ (PatBuilderBang _ (L _ (PatBuilderVar (dL -> L l var))))) [] ann | not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann)) -- For infix function defns, there should be only one infix *function* -- (though there may be infix *datacons* involved too). So we don't -- need fixity info to figure out which function is being defined. -- a `K1` b `op` c `K2` d -- must parse as -- (a `K1` b) `op` (c `K2` d) -- The renamer checks later that the precedences would yield such a parse. -- -- There is a complication to deal with bang patterns. -- -- ToDo: what about this? -- x + 1 `op` y = ... go e@(L loc (PatBuilderOpApp l (dL->L loc' op) r)) es ann | Just (e',es') <- splitBang e = do { bang_on <- getBit BangPatBit ; if bang_on then go e' (es' ++ es) ann else return (Just (cL loc' op, Infix, (l:r:es), ann)) } -- No bangs; behave just like the next case | not (isRdrDataCon op) -- We have found the function! = return (Just (cL loc' op, Infix, (l:r:es), ann)) | otherwise -- Infix data con; keep going = do { mb_l <- go l es ann ; case mb_l of Just (op', Infix, j : k : es', ann') -> return (Just (op', Infix, j : op_app : es', ann')) where op_app = cL loc (PatBuilderOpApp k (cL loc' op) r) _ -> return Nothing } go _ _ _ = return Nothing -- | Either an operator or an operand. data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs) | TyElKindApp SrcSpan (LHsType GhcPs) -- See Note [TyElKindApp SrcSpan interpretation] | TyElTilde | TyElBang | TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness) | TyElDocPrev HsDocString {- Note [TyElKindApp SrcSpan interpretation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A TyElKindApp captures type application written in haskell as @ Foo where Foo is some type. The SrcSpan reflects both elements, and there are AnnAt and AnnVal API Annotations attached to this SrcSpan for the specific locations of each within it. -} instance Outputable TyEl where ppr (TyElOpr name) = ppr name ppr (TyElOpd ty) = ppr ty ppr (TyElKindApp _ ki) = text "@" <> ppr ki ppr TyElTilde = text "~" ppr TyElBang = text "!" ppr (TyElUnpackedness (_, _, unpk)) = ppr unpk ppr (TyElDocPrev doc) = ppr doc tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness) tyElStrictness TyElTilde = Just (AnnTilde, SrcLazy) tyElStrictness TyElBang = Just (AnnBang, SrcStrict) tyElStrictness _ = Nothing -- | Extract a strictness/unpackedness annotation from the front of a reversed -- 'TyEl' list. pStrictMark :: [Located TyEl] -- reversed TyEl -> Maybe ( Located HsSrcBang {- a strictness/upnackedness marker -} , [AddAnn] , [Located TyEl] {- remaining TyEl -}) pStrictMark ((dL->L l1 x1) : (dL->L l2 x2) : xs) | Just (strAnnId, str) <- tyElStrictness x1 , TyElUnpackedness (unpkAnns, prag, unpk) <- x2 = Just ( cL (combineSrcSpans l1 l2) (HsSrcBang prag unpk str) , unpkAnns ++ [AddAnn strAnnId l1] , xs ) pStrictMark ((dL->L l x1) : xs) | Just (strAnnId, str) <- tyElStrictness x1 = Just ( cL l (HsSrcBang NoSourceText NoSrcUnpack str) , [AddAnn strAnnId l] , xs ) pStrictMark ((dL->L l x1) : xs) | TyElUnpackedness (anns, prag, unpk) <- x1 = Just ( cL l (HsSrcBang prag unpk NoSrcStrict) , anns , xs ) pStrictMark _ = Nothing pBangTy :: LHsType GhcPs -- a type to be wrapped inside HsBangTy -> [Located TyEl] -- reversed TyEl -> ( Bool {- has a strict mark been consumed? -} , LHsType GhcPs {- the resulting BangTy -} , P () {- add annotations -} , [Located TyEl] {- remaining TyEl -}) pBangTy lt@(dL->L l1 _) xs = case pStrictMark xs of Nothing -> (False, lt, pure (), xs) Just (dL->L l2 strictMark, anns, xs') -> let bl = combineSrcSpans l1 l2 bt = HsBangTy noExtField strictMark lt in (True, cL bl bt, addAnnsAt bl anns, xs') -- | Merge a /reversed/ and /non-empty/ soup of operators and operands -- into a type. -- -- User input: @F x y + G a b * X@ -- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F] -- Output corresponds to what the user wrote assuming all operators are of the -- same fixity and right-associative. -- -- It's a bit silly that we're doing it at all, as the renamer will have to -- rearrange this, and it'd be easier to keep things separate. -- -- See Note [Parsing data constructors is hard] mergeOps :: [Located TyEl] -> P (LHsType GhcPs) mergeOps ((dL->L l1 (TyElOpd t)) : xs) | (_, t', addAnns, xs') <- pBangTy (cL l1 t) xs , null xs' -- We accept a BangTy only when there are no preceding TyEl. = addAnns >> return t' mergeOps all_xs = go (0 :: Int) [] id all_xs where -- NB. When modifying clauses in 'go', make sure that the reasoning in -- Note [Non-empty 'acc' in mergeOps clause [end]] is still correct. -- clause [unpk]: -- handle (NO)UNPACK pragmas go k acc ops_acc ((dL->L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) = if not (null acc) && null xs then do { acc' <- eitherToP $ mergeOpsAcc acc ; let a = ops_acc acc' strictMark = HsSrcBang unpkSrc unpk NoSrcStrict bl = combineSrcSpans l (getLoc a) bt = HsBangTy noExtField strictMark a ; addAnnsAt bl anns ; return (cL bl bt) } else addFatalError l unpkError where unpkSDoc = case unpkSrc of NoSourceText -> ppr unpk SourceText str -> text str <> text " #-}" unpkError | not (null xs) = unpkSDoc <+> text "cannot appear inside a type." | null acc && k == 0 = unpkSDoc <+> text "must be applied to a type." | otherwise = -- See Note [Impossible case in mergeOps clause [unpk]] panic "mergeOps.UNPACK: impossible position" -- clause [doc]: -- we do not expect to encounter any docs go _ _ _ ((dL->L l (TyElDocPrev _)):_) = failOpDocPrev l -- to improve error messages, we do a bit of guesswork to determine if the -- user intended a '!' or a '~' as a strictness annotation go k acc ops_acc ((dL->L l x) : xs) | Just (_, str) <- tyElStrictness x , let guess [] = True guess ((dL->L _ (TyElOpd _)):_) = False guess ((dL->L _ (TyElOpr _)):_) = True guess ((dL->L _ (TyElKindApp _ _)):_) = False guess ((dL->L _ (TyElTilde)):_) = True guess ((dL->L _ (TyElBang)):_) = True guess ((dL->L _ (TyElUnpackedness _)):_) = True guess ((dL->L _ (TyElDocPrev _)):xs') = guess xs' guess _ = panic "mergeOps.go.guess: Impossible Match" -- due to #15884 in guess xs = if not (null acc) && (k > 1 || length acc > 1) then do { a <- eitherToP (mergeOpsAcc acc) ; failOpStrictnessCompound (cL l str) (ops_acc a) } else failOpStrictnessPosition (cL l str) -- clause [opr]: -- when we encounter an operator, we must have accumulated -- something for its rhs, and there must be something left -- to build its lhs. go k acc ops_acc ((dL->L l (TyElOpr op)):xs) = if null acc || null (filter isTyElOpd xs) then failOpFewArgs (cL l op) else do { acc' <- eitherToP (mergeOpsAcc acc) ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc acc')) xs } where isTyElOpd (dL->L _ (TyElOpd _)) = True isTyElOpd _ = False -- clause [opr.1]: interpret 'TyElTilde' as an operator go k acc ops_acc ((dL->L l TyElTilde):xs) = let op = eqTyCon_RDR in go k acc ops_acc (cL l (TyElOpr op):xs) -- clause [opr.2]: interpret 'TyElBang' as an operator go k acc ops_acc ((dL->L l TyElBang):xs) = let op = mkUnqual tcClsName (fsLit "!") in go k acc ops_acc (cL l (TyElOpr op):xs) -- clause [opd]: -- whenever an operand is encountered, it is added to the accumulator go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (HsValArg (cL l a):acc) ops_acc xs -- clause [tyapp]: -- whenever a type application is encountered, it is added to the accumulator go k acc ops_acc ((dL->L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs -- clause [end] -- See Note [Non-empty 'acc' in mergeOps clause [end]] go _ acc ops_acc [] = do { acc' <- eitherToP (mergeOpsAcc acc) ; return (ops_acc acc') } go _ _ _ _ = panic "mergeOps.go: Impossible Match" -- due to #15884 mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> Either (SrcSpan, SDoc) (LHsType GhcPs) mergeOpsAcc [] = panic "mergeOpsAcc: empty input" mergeOpsAcc (HsTypeArg _ (L loc ki):_) = Left (loc, text "Unexpected type application:" <+> ppr ki) mergeOpsAcc (HsValArg ty : xs) = go1 ty xs where go1 :: LHsType GhcPs -> [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> Either (SrcSpan, SDoc) (LHsType GhcPs) go1 lhs [] = Right lhs go1 lhs (x:xs) = case x of HsValArg ty -> go1 (mkHsAppTy lhs ty) xs HsTypeArg loc ki -> let ty = mkHsAppKindTy loc lhs ki in go1 ty xs HsArgPar _ -> go1 lhs xs mergeOpsAcc (HsArgPar _: xs) = mergeOpsAcc xs {- Note [Impossible case in mergeOps clause [unpk]] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This case should never occur. Let us consider all possible variations of 'acc', 'xs', and 'k': acc xs k ============================== null | null 0 -- "must be applied to a type" null | not null 0 -- "must be applied to a type" not null | null 0 -- successful parse not null | not null 0 -- "cannot appear inside a type" null | null >0 -- handled in clause [opr] null | not null >0 -- "cannot appear inside a type" not null | null >0 -- successful parse not null | not null >0 -- "cannot appear inside a type" The (null acc && null xs && k>0) case is handled in clause [opr] by the following check: if ... || null (filter isTyElOpd xs) then failOpFewArgs (L l op) We know that this check has been performed because k>0, and by the time we reach the end of the list (null xs), the only way for (null acc) to hold is that there was not a single TyElOpd between the operator and the end of the list. But this case is caught by the check and reported as 'failOpFewArgs'. -} {- Note [Non-empty 'acc' in mergeOps clause [end]] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In clause [end] we need to know that 'acc' is non-empty to call 'mergeAcc' without a check. Running 'mergeOps' with an empty input list is forbidden, so we do not consider this possibility. This means we'll hit at least one other clause before we reach clause [end]. * Clauses [unpk] and [doc] do not call 'go' recursively, so we cannot hit clause [end] from there. * Clause [opd] makes 'acc' non-empty, so if we hit clause [end] after it, 'acc' will be non-empty. * Clause [opr] checks that (filter isTyElOpd xs) is not null - so we are going to hit clause [opd] at least once before we reach clause [end], making 'acc' non-empty. * There are no other clauses. Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause [end]. -} pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) pInfixSide ((dL->L l (TyElOpd t)):xs) | (True, t', addAnns, xs') <- pBangTy (cL l t) xs = Just (t', addAnns, xs') pInfixSide (el:xs1) | Just t1 <- pLHsTypeArg el = go [t1] xs1 where go :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) go acc (el:xs) | Just t <- pLHsTypeArg el = go (t:acc) xs go acc xs = case mergeOpsAcc acc of Left _ -> Nothing Right acc' -> Just (acc', pure (), xs) pInfixSide _ = Nothing pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs)) pLHsTypeArg (dL->L l (TyElOpd a)) = Just (HsValArg (L l a)) pLHsTypeArg (dL->L _ (TyElKindApp l a)) = Just (HsTypeArg l a) pLHsTypeArg _ = Nothing pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl]) pDocPrev = go Nothing where go mTrailingDoc ((dL->L l (TyElDocPrev doc)):xs) = go (mTrailingDoc `mplus` Just (cL l doc)) xs go mTrailingDoc xs = (mTrailingDoc, xs) orErr :: Maybe a -> b -> Either b a orErr (Just a) _ = Right a orErr Nothing b = Left b {- Note [isFunLhs vs mergeDataCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When parsing a function LHS, we do not know whether to treat (!) as a strictness annotation or an infix operator: f ! a = ... Without -XBangPatterns, this parses as (!) f a = ... with -XBangPatterns, this parses as f (!a) = ... So in function declarations we opted to always parse as if -XBangPatterns were off, and then rejig in 'isFunLhs'. There are two downsides to this approach: 1. It is not particularly elegant, as there's a point in our pipeline where the representation is awfully incorrect. For instance, f !a b !c = ... will be first parsed as (f ! a b) ! c = ... 2. There are cases that it fails to cover, for instance infix declarations: !a + !b = ... will trigger an error. Unfortunately, we cannot define different productions in the 'happy' grammar depending on whether -XBangPatterns are enabled. When parsing data constructors, we face a similar issue: (a) data T1 = C ! D (b) data T2 = C ! D => ... In (a) the first bang is a strictness annotation, but in (b) it is a type operator. A 'happy'-based parser does not have unlimited lookahead to check for =>, so we must first parse (C ! D) into a common representation. If we tried to mirror the approach used in functions, we would parse both sides of => as types, and then rejig. However, we take a different route and use an intermediate data structure, a reversed list of 'TyEl'. See Note [Parsing data constructors is hard] for details. This approach does not suffer from the issues of 'isFunLhs': 1. A sequence of 'TyEl' is a dedicated intermediate representation, not an incorrectly parsed type. Therefore, we do not have confusing states in our pipeline. (Except for representing data constructors as type variables). 2. We can handle infix data constructors with strictness annotations: data T a b = !a :+ !b -} -- | Merge a /reversed/ and /non-empty/ soup of operators and operands -- into a data constructor. -- -- User input: @C !A B -- ^ doc@ -- Input to 'mergeDataCon': ["doc", B, !, A, C] -- Output: (C, PrefixCon [!A, B], "doc") -- -- See Note [Parsing data constructors is hard] -- See Note [isFunLhs vs mergeDataCon] mergeDataCon :: [Located TyEl] -> P ( Located RdrName -- constructor name , HsConDeclDetails GhcPs -- constructor field information , Maybe LHsDocString -- docstring to go on the constructor ) mergeDataCon all_xs = do { (addAnns, a) <- eitherToP res ; addAnns ; return a } where -- We start by splitting off the trailing documentation comment, -- if any exists. (mTrailingDoc, all_xs') = pDocPrev all_xs -- Determine whether the trailing documentation comment exists and is the -- only docstring in this constructor declaration. -- -- When true, it means that it applies to the constructor itself: -- data T = C -- A -- B -- ^ Comment on C (singleDoc == True) -- -- When false, it means that it applies to the last field: -- data T = C -- ^ Comment on C -- A -- ^ Comment on A -- B -- ^ Comment on B (singleDoc == False) singleDoc = isJust mTrailingDoc && null [ () | (dL->L _ (TyElDocPrev _)) <- all_xs' ] -- The result of merging the list of reversed TyEl into a -- data constructor, along with [AddAnn]. res = goFirst all_xs' -- Take the trailing docstring into account when interpreting -- the docstring near the constructor. -- -- data T = C -- ^ docstring right after C -- A -- B -- ^ trailing docstring -- -- 'mkConDoc' must be applied to the docstring right after C, so that it -- falls back to the trailing docstring when appropriate (see singleDoc). mkConDoc mDoc | singleDoc = mDoc `mplus` mTrailingDoc | otherwise = mDoc -- The docstring for the last field of a data constructor. trailingFieldDoc | singleDoc = Nothing | otherwise = mTrailingDoc goFirst [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] = do { data_con <- tyConToDataCon l tc ; return (pure (), (data_con, PrefixCon [], mTrailingDoc)) } goFirst ((dL->L l (TyElOpd (HsRecTy _ fields))):xs) | (mConDoc, xs') <- pDocPrev xs , [ dL->L l' (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] <- xs' = do { data_con <- tyConToDataCon l' tc ; let mDoc = mTrailingDoc `mplus` mConDoc ; return (pure (), (data_con, RecCon (cL l fields), mDoc)) } goFirst [dL->L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))] = return ( pure () , ( cL l (getRdrName (tupleDataCon Boxed (length ts))) , PrefixCon ts , mTrailingDoc ) ) goFirst ((dL->L l (TyElOpd t)):xs) | (_, t', addAnns, xs') <- pBangTy (cL l t) xs = go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs' goFirst (L l (TyElKindApp _ _):_) = goInfix Monoid.<> Left (l, kindAppErr) goFirst xs = go (pure ()) mTrailingDoc [] xs go addAnns mLastDoc ts [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] = do { data_con <- tyConToDataCon l tc ; return (addAnns, (data_con, PrefixCon ts, mkConDoc mLastDoc)) } go addAnns mLastDoc ts ((dL->L l (TyElDocPrev doc)):xs) = go addAnns (mLastDoc `mplus` Just (cL l doc)) ts xs go addAnns mLastDoc ts ((dL->L l (TyElOpd t)):xs) | (_, t', addAnns', xs') <- pBangTy (cL l t) xs , t'' <- mkLHsDocTyMaybe t' mLastDoc = go (addAnns >> addAnns') Nothing (t'':ts) xs' go _ _ _ ((dL->L _ (TyElOpr _)):_) = -- Encountered an operator: backtrack to the beginning and attempt -- to parse as an infix definition. goInfix go _ _ _ (L l (TyElKindApp _ _):_) = goInfix Monoid.<> Left (l, kindAppErr) go _ _ _ _ = Left malformedErr where malformedErr = ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs') , text "Cannot parse data constructor" <+> text "in a data/newtype declaration:" $$ nest 2 (hsep . reverse $ map ppr all_xs')) goInfix = do { let xs0 = all_xs' ; (rhs_t, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr ; let (mOpDoc, xs2) = pDocPrev xs1 ; (op, xs3) <- case xs2 of (dL->L l (TyElOpr op)) : xs3 -> do { data_con <- tyConToDataCon l op ; return (data_con, xs3) } _ -> Left malformedErr ; let (mLhsDoc, xs4) = pDocPrev xs3 ; (lhs_t, lhs_addAnns, xs5) <- pInfixSide xs4 `orErr` malformedErr ; unless (null xs5) (Left malformedErr) ; let rhs = mkLHsDocTyMaybe rhs_t trailingFieldDoc lhs = mkLHsDocTyMaybe lhs_t mLhsDoc addAnns = lhs_addAnns >> rhs_addAnns ; return (addAnns, (op, InfixCon lhs rhs, mkConDoc mOpDoc)) } where malformedErr = ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs') , text "Cannot parse an infix data constructor" <+> text "in a data/newtype declaration:" $$ nest 2 (hsep . reverse $ map ppr all_xs')) kindAppErr = text "Unexpected kind application" <+> text "in a data/newtype declaration:" $$ nest 2 (hsep . reverse $ map ppr all_xs') --------------------------------------------------------------------------- -- | Check for monad comprehensions -- -- If the flag MonadComprehensions is set, return a 'MonadComp' context, -- otherwise use the usual 'ListComp' context checkMonadComp :: PV (HsStmtContext Name) checkMonadComp = do monadComprehensions <- getBit MonadComprehensionsBit return $ if monadComprehensions then MonadComp else ListComp -- ------------------------------------------------------------------------- -- Expression/command/pattern ambiguity. -- See Note [Ambiguous syntactic categories] -- -- See Note [Parser-Validator] -- See Note [Ambiguous syntactic categories] newtype ECP = ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) } runECP_P :: DisambECP b => ECP -> P (Located b) runECP_P p = runPV (runECP_PV p) ecpFromExp :: LHsExpr GhcPs -> ECP ecpFromExp a = ECP (ecpFromExp' a) ecpFromCmd :: LHsCmd GhcPs -> ECP ecpFromCmd a = ECP (ecpFromCmd' a) -- | Disambiguate infix operators. -- See Note [Ambiguous syntactic categories] class DisambInfixOp b where mkHsVarOpPV :: Located RdrName -> PV (Located b) mkHsConOpPV :: Located RdrName -> PV (Located b) mkHsInfixHolePV :: SrcSpan -> PV (Located b) instance p ~ GhcPs => DisambInfixOp (HsExpr p) where mkHsVarOpPV v = return $ cL (getLoc v) (HsVar noExtField v) mkHsConOpPV v = return $ cL (getLoc v) (HsVar noExtField v) mkHsInfixHolePV l = return $ cL l hsHoleExpr instance DisambInfixOp RdrName where mkHsConOpPV (dL->L l v) = return $ cL l v mkHsVarOpPV (dL->L l v) = return $ cL l v mkHsInfixHolePV l = addFatalError l $ text "Invalid infix hole, expected an infix operator" -- | Disambiguate constructs that may appear when we do not know ahead of time whether we are -- parsing an expression, a command, or a pattern. -- See Note [Ambiguous syntactic categories] class b ~ (Body b) GhcPs => DisambECP b where -- | See Note [Body in DisambECP] type Body b :: * -> * -- | Return a command without ambiguity, or fail in a non-command context. ecpFromCmd' :: LHsCmd GhcPs -> PV (Located b) -- | Return an expression without ambiguity, or fail in a non-expression context. ecpFromExp' :: LHsExpr GhcPs -> PV (Located b) -- | Disambiguate "\... -> ..." (lambda) mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b) -- | Disambiguate "let ... in ..." mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located b) -- | Infix operator representation type InfixOp b -- | Bring superclass constraints on FunArg into scope. -- See Note [UndecidableSuperClasses for associated types] superInfixOp :: (DisambInfixOp (InfixOp b) => PV (Located b )) -> PV (Located b) -- | Disambiguate "f # x" (infix operator) mkHsOpAppPV :: SrcSpan -> Located b -> Located (InfixOp b) -> Located b -> PV (Located b) -- | Disambiguate "case ... of ..." mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> MatchGroup GhcPs (Located b) -> PV (Located b) -- | Function argument representation type FunArg b -- | Bring superclass constraints on FunArg into scope. -- See Note [UndecidableSuperClasses for associated types] superFunArg :: (DisambECP (FunArg b) => PV (Located b)) -> PV (Located b) -- | Disambiguate "f x" (function application) mkHsAppPV :: SrcSpan -> Located b -> Located (FunArg b) -> PV (Located b) -- | Disambiguate "if ... then ... else ..." mkHsIfPV :: SrcSpan -> LHsExpr GhcPs -> Bool -- semicolon? -> Located b -> Bool -- semicolon? -> Located b -> PV (Located b) -- | Disambiguate "do { ... }" (do notation) mkHsDoPV :: SrcSpan -> Located [LStmt GhcPs (Located b)] -> PV (Located b) -- | Disambiguate "( ... )" (parentheses) mkHsParPV :: SrcSpan -> Located b -> PV (Located b) -- | Disambiguate a variable "f" or a data constructor "MkF". mkHsVarPV :: Located RdrName -> PV (Located b) -- | Disambiguate a monomorphic literal mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b) -- | Disambiguate an overloaded literal mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (Located b) -- | Disambiguate a wildcard mkHsWildCardPV :: SrcSpan -> PV (Located b) -- | Disambiguate "a :: t" (type annotation) mkHsTySigPV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b) -- | Disambiguate "[a,b,c]" (list syntax) mkHsExplicitListPV :: SrcSpan -> [Located b] -> PV (Located b) -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b) -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) mkHsRecordPV :: SrcSpan -> SrcSpan -> Located b -> ([LHsRecField GhcPs (Located b)], Maybe SrcSpan) -> PV (Located b) -- | Disambiguate "-a" (negation) mkHsNegAppPV :: SrcSpan -> Located b -> PV (Located b) -- | Disambiguate "(# a)" (right operator section) mkHsSectionR_PV :: SrcSpan -> Located (InfixOp b) -> Located b -> PV (Located b) -- | Disambiguate "(a -> b)" (view pattern) mkHsViewPatPV :: SrcSpan -> LHsExpr GhcPs -> Located b -> PV (Located b) -- | Disambiguate "a@b" (as-pattern) mkHsAsPatPV :: SrcSpan -> Located RdrName -> Located b -> PV (Located b) -- | Disambiguate "~a" (lazy pattern) mkHsLazyPatPV :: SrcSpan -> Located b -> PV (Located b) -- | Disambiguate tuple sections and unboxed sums mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b) {- Note [UndecidableSuperClasses for associated types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Assume we have a class C with an associated type T: class C a where type T a ... If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses: {-# LANGUAGE UndecidableSuperClasses #-} class C (T a) => C a where type T a ... Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes making GHC loop. The workaround is to bring this constraint into scope manually with a helper method: class C a where type T a superT :: (C (T a) => r) -> r In order to avoid ambiguous types, 'r' must mention 'a'. For consistency, we use this approach for all constraints on associated types, even when -XUndecidableSuperClasses are not required. -} {- Note [Body in DisambECP] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that require their argument to take a form of (body GhcPs) for some (body :: * -> *). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the superclass constraints of DisambECP. The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop this requirement. It is possible and would allow removing the type index of PatBuilder, but leads to worse type inference, breaking some code in the typechecker. -} instance p ~ GhcPs => DisambECP (HsCmd p) where type Body (HsCmd p) = HsCmd ecpFromCmd' = return ecpFromExp' (dL-> L l e) = cmdFail l (ppr e) mkHsLamPV l mg = return $ cL l (HsCmdLam noExtField mg) mkHsLetPV l bs e = return $ cL l (HsCmdLet noExtField bs e) type InfixOp (HsCmd p) = HsExpr p superInfixOp m = m mkHsOpAppPV l c1 op c2 = do let cmdArg c = cL (getLoc c) $ HsCmdTop noExtField c return $ cL l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2] mkHsCasePV l c mg = return $ cL l (HsCmdCase noExtField c mg) type FunArg (HsCmd p) = HsExpr p superFunArg m = m mkHsAppPV l c e = do checkCmdBlockArguments c checkExpBlockArguments e return $ cL l (HsCmdApp noExtField c e) mkHsIfPV l c semi1 a semi2 b = do checkDoAndIfThenElse c semi1 a semi2 b return $ cL l (mkHsCmdIf c a b) mkHsDoPV l stmts = return $ cL l (HsCmdDo noExtField stmts) mkHsParPV l c = return $ cL l (HsCmdPar noExtField c) mkHsVarPV (dL->L l v) = cmdFail l (ppr v) mkHsLitPV (dL->L l a) = cmdFail l (ppr a) mkHsOverLitPV (dL->L l a) = cmdFail l (ppr a) mkHsWildCardPV l = cmdFail l (text "_") mkHsTySigPV l a sig = cmdFail l (ppr a <+> text "::" <+> ppr sig) mkHsExplicitListPV l xs = cmdFail l $ brackets (fsep (punctuate comma (map ppr xs))) mkHsSplicePV (dL->L l sp) = cmdFail l (ppr sp) mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $ ppr a <+> ppr (mk_rec_fields fbinds ddLoc) mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a) mkHsSectionR_PV l op c = cmdFail l $ let pp_op = fromMaybe (panic "cannot print infix operator") (ppr_infix_expr (unLoc op)) in pp_op <> ppr c mkHsViewPatPV l a b = cmdFail l $ ppr a <+> text "->" <+> ppr b mkHsAsPatPV l v c = cmdFail l $ pprPrefixOcc (unLoc v) <> text "@" <> ppr c mkHsLazyPatPV l c = cmdFail l $ text "~" <> ppr c mkSumOrTuplePV l boxity a = cmdFail l (pprSumOrTuple boxity a) cmdFail :: SrcSpan -> SDoc -> PV a cmdFail loc e = addFatalError loc $ hang (text "Parse error in command:") 2 (ppr e) instance p ~ GhcPs => DisambECP (HsExpr p) where type Body (HsExpr p) = HsExpr ecpFromCmd' (dL -> L l c) = do addError l $ vcat [ text "Arrow command found where an expression was expected:", nest 2 (ppr c) ] return (cL l hsHoleExpr) ecpFromExp' = return mkHsLamPV l mg = return $ cL l (HsLam noExtField mg) mkHsLetPV l bs c = return $ cL l (HsLet noExtField bs c) type InfixOp (HsExpr p) = HsExpr p superInfixOp m = m mkHsOpAppPV l e1 op e2 = do return $ cL l $ OpApp noExtField e1 op e2 mkHsCasePV l e mg = return $ cL l (HsCase noExtField e mg) type FunArg (HsExpr p) = HsExpr p superFunArg m = m mkHsAppPV l e1 e2 = do checkExpBlockArguments e1 checkExpBlockArguments e2 return $ cL l (HsApp noExtField e1 e2) mkHsIfPV l c semi1 a semi2 b = do checkDoAndIfThenElse c semi1 a semi2 b return $ cL l (mkHsIf c a b) mkHsDoPV l stmts = return $ cL l (HsDo noExtField DoExpr stmts) mkHsParPV l e = return $ cL l (HsPar noExtField e) mkHsVarPV v@(getLoc -> l) = return $ cL l (HsVar noExtField v) mkHsLitPV (dL->L l a) = return $ cL l (HsLit noExtField a) mkHsOverLitPV (dL->L l a) = return $ cL l (HsOverLit noExtField a) mkHsWildCardPV l = return $ cL l hsHoleExpr mkHsTySigPV l a sig = return $ cL l (ExprWithTySig noExtField a (mkLHsSigWcType sig)) mkHsExplicitListPV l xs = return $ cL l (ExplicitList noExtField Nothing xs) mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp mkHsRecordPV l lrec a (fbinds, ddLoc) = do r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc) checkRecordSyntax (cL l r) mkHsNegAppPV l a = return $ cL l (NegApp noExtField a noSyntaxExpr) mkHsSectionR_PV l op e = return $ cL l (SectionR noExtField op e) mkHsViewPatPV l a b = patSynErr l (ppr a <+> text "->" <+> ppr b) empty mkHsAsPatPV l v e = do opt_TypeApplications <- getBit TypeApplicationsBit let msg | opt_TypeApplications = "Type application syntax requires a space before '@'" | otherwise = "Did you mean to enable TypeApplications?" patSynErr l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) (text msg) mkHsLazyPatPV l e = patSynErr l (text "~" <> ppr e) empty mkSumOrTuplePV = mkSumOrTupleExpr patSynErr :: SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs) patSynErr l e explanation = do { addError l $ sep [text "Pattern syntax in expression context:", nest 4 (ppr e)] $$ explanation ; return (cL l hsHoleExpr) } hsHoleExpr :: HsExpr (GhcPass id) hsHoleExpr = HsUnboundVar noExtField (TrueExprHole (mkVarOcc "_")) -- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] data PatBuilder p = PatBuilderPat (Pat p) | PatBuilderBang SrcSpan (Located (PatBuilder p)) | PatBuilderPar (Located (PatBuilder p)) | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) | PatBuilderVar (Located RdrName) | PatBuilderOverLit (HsOverLit GhcPs) patBuilderBang :: SrcSpan -> Located (PatBuilder p) -> Located (PatBuilder p) patBuilderBang bang p = cL (bang `combineSrcSpans` getLoc p) $ PatBuilderBang bang p instance Outputable (PatBuilder GhcPs) where ppr (PatBuilderPat p) = ppr p ppr (PatBuilderBang _ (L _ p)) = text "!" <+> ppr p ppr (PatBuilderPar (L _ p)) = parens (ppr p) ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2 ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2 ppr (PatBuilderVar v) = ppr v ppr (PatBuilderOverLit l) = ppr l instance DisambECP (PatBuilder GhcPs) where type Body (PatBuilder GhcPs) = PatBuilder ecpFromCmd' (dL-> L l c) = addFatalError l $ text "Command syntax in pattern:" <+> ppr c ecpFromExp' (dL-> L l e) = addFatalError l $ text "Expression syntax in pattern:" <+> ppr e mkHsLamPV l _ = addFatalError l $ text "Lambda-syntax in pattern." $$ text "Pattern matching on functions is not possible." mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern" type InfixOp (PatBuilder GhcPs) = RdrName superInfixOp m = m mkHsOpAppPV l p1 op p2 = do warnSpaceAfterBang op (getLoc p2) return $ cL l $ PatBuilderOpApp p1 op p2 mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern" type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs superFunArg m = m mkHsAppPV l p1 p2 = return $ cL l (PatBuilderApp p1 p2) mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern" mkHsDoPV l _ = addFatalError l $ text "do-notation in pattern" mkHsParPV l p = return $ cL l (PatBuilderPar p) mkHsVarPV v@(getLoc -> l) = return $ cL l (PatBuilderVar v) mkHsLitPV lit@(dL->L l a) = do checkUnboxedStringLitPat lit return $ cL l (PatBuilderPat (LitPat noExtField a)) mkHsOverLitPV (dL->L l a) = return $ cL l (PatBuilderOverLit a) mkHsWildCardPV l = return $ cL l (PatBuilderPat (WildPat noExtField)) mkHsTySigPV l b sig = do p <- checkLPat b return $ cL l (PatBuilderPat (SigPat noExtField p (mkLHsSigWcType sig))) mkHsExplicitListPV l xs = do ps <- traverse checkLPat xs return (cL l (PatBuilderPat (ListPat noExtField ps))) mkHsSplicePV (dL->L l sp) = return $ cL l (PatBuilderPat (SplicePat noExtField sp)) mkHsRecordPV l _ a (fbinds, ddLoc) = do r <- mkPatRec a (mk_rec_fields fbinds ddLoc) checkRecordSyntax (cL l r) mkHsNegAppPV l (dL->L lp p) = do lit <- case p of PatBuilderOverLit pos_lit -> return (cL lp pos_lit) _ -> patFail l (text "-" <> ppr p) return $ cL l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr))) mkHsSectionR_PV l op p | isBangRdr (unLoc op) = return $ cL l $ PatBuilderBang (getLoc op) p | otherwise = patFail l (pprInfixOcc (unLoc op) <> ppr p) mkHsViewPatPV l a b = do p <- checkLPat b return $ cL l (PatBuilderPat (ViewPat noExtField a p)) mkHsAsPatPV l v e = do p <- checkLPat e return $ cL l (PatBuilderPat (AsPat noExtField v p)) mkHsLazyPatPV l e = do p <- checkLPat e return $ cL l (PatBuilderPat (LazyPat noExtField p)) mkSumOrTuplePV = mkSumOrTuplePat checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV () checkUnboxedStringLitPat (dL->L loc lit) = case lit of HsStringPrim _ _ -- Trac #13260 -> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit) _ -> return () mkPatRec :: Located (PatBuilder GhcPs) -> HsRecFields GhcPs (Located (PatBuilder GhcPs)) -> PV (PatBuilder GhcPs) mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) | isRdrDataCon (unLoc c) = do fs <- mapM checkPatField fs return (PatBuilderPat (ConPatIn c (RecCon (HsRecFields fs dd)))) mkPatRec p _ = addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p -- | Warn about missing space after bang warnSpaceAfterBang :: Located RdrName -> SrcSpan -> PV () warnSpaceAfterBang (dL->L opLoc op) argLoc = do bang_on <- getBit BangPatBit when (not bang_on && noSpace && isBangRdr op) $ addWarning Opt_WarnSpaceAfterBang span msg where span = combineSrcSpans opLoc argLoc noSpace = srcSpanEnd opLoc == srcSpanStart argLoc msg = text "Did you forget to enable BangPatterns?" $$ text "If you mean to bind (!) then perhaps you want" $$ text "to add a space after the bang for clarity." {- Note [Ambiguous syntactic categories] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are places in the grammar where we do not know whether we are parsing an expression or a pattern without unlimited lookahead (which we do not have in 'happy'): View patterns: f (Con a b ) = ... -- 'Con a b' is a pattern f (Con a b -> x) = ... -- 'Con a b' is an expression do-notation: do { Con a b <- x } -- 'Con a b' is a pattern do { Con a b } -- 'Con a b' is an expression Guards: x | True <- p && q = ... -- 'True' is a pattern x | True = ... -- 'True' is an expression Top-level value/function declarations (FunBind/PatBind): f !a -- TH splice f !a = ... -- function declaration Until we encounter the = sign, we don't know if it's a top-level TemplateHaskell splice where ! is an infix operator, or if it's a function declaration where ! is a strictness annotation. There are also places in the grammar where we do not know whether we are parsing an expression or a command: proc x -> do { (stuff) -< x } -- 'stuff' is an expression proc x -> do { (stuff) } -- 'stuff' is a command Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff' as an expression or a command. In fact, do-notation is subject to both ambiguities: proc x -> do { (stuff) -< x } -- 'stuff' is an expression proc x -> do { (stuff) <- f -< x } -- 'stuff' is a pattern proc x -> do { (stuff) } -- 'stuff' is a command There are many possible solutions to this problem. For an overview of the ones we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives] The solution that keeps basic definitions (such as HsExpr) clean, keeps the concerns local to the parser, and does not require duplication of hsSyn types, or an extra pass over the entire AST, is to parse into an overloaded parser-validator (a so-called tagless final encoding): class DisambECP b where ... instance p ~ GhcPs => DisambECP (HsCmd p) where ... instance p ~ GhcPs => DisambECP (HsExp p) where ... instance p ~ GhcPs => DisambECP (PatBuilder p) where ... The 'DisambECP' class contains functions to build and validate 'b'. For example, to add parentheses we have: mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b) 'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat, see Note [PatBuilder]). Consider the 'alts' production used to parse case-of alternatives: alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } We abstract over LHsExpr GhcPs, and it becomes: alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } : alts1 { $1 >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { $2 >>= \ $2 -> return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } Compared to the initial definition, the added bits are: forall b. DisambECP b => PV ( ... ) -- in the type signature $1 >>= \ $1 -> return $ -- in one reduction rule $2 >>= \ $2 -> return $ -- in another reduction rule The overhead is constant relative to the size of the rest of the reduction rule, so this approach scales well to large parser productions. -} {- Note [Resolving parsing ambiguities: non-taken alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Alternative I, extra constructors in GHC.Hs.Expr ------------------------------------------------ We could add extra constructors to HsExpr to represent command-specific and pattern-specific syntactic constructs. Under this scheme, we parse patterns and commands as expressions and rejig later. This is what GHC used to do, and it polluted 'HsExpr' with irrelevant constructors: * for commands: 'HsArrForm', 'HsArrApp' * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat' (As of now, we still do that for patterns, but we plan to fix it). There are several issues with this: * The implementation details of parsing are leaking into hsSyn definitions. * Code that uses HsExpr has to panic on these impossible-after-parsing cases. * HsExpr is arbitrarily selected as the extension basis. Why not extend HsCmd or HsPat with extra constructors instead? * We cannot handle corner cases. For instance, the following function declaration LHS is not a valid expression (see #1087): !a + !b = ... * There are points in the pipeline where the representation was awfully incorrect. For instance, f !a b !c = ... is first parsed as (f ! a b) ! c = ... Alternative II, extra constructors in GHC.Hs.Expr for GhcPs ----------------------------------------------------------- We could address some of the problems with Alternative I by using Trees That Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to the output of parsing, not to its intermediate results, so we wouldn't want them there either. Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs --------------------------------------------------------------- We could introduce a new pass, GhcPrePs, to keep GhcPs pristine. Unfortunately, creating a new pass would significantly bloat conversion code and slow down the compiler by adding another linear-time pass over the entire AST. For example, in order to build HsExpr GhcPrePs, we would need to build HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds GhcPrePs. Alternative IV, sum type and bottom-up data flow ------------------------------------------------ Expressions and commands are disjoint. There are no user inputs that could be interpreted as either an expression or a command depending on outer context: 5 -- definitely an expression x -< y -- definitely a command Even though we have both 'HsLam' and 'HsCmdLam', we can look at the body to disambiguate: \p -> 5 -- definitely an expression \p -> x -< y -- definitely a command This means we could use a bottom-up flow of information to determine whether we are parsing an expression or a command, using a sum type for intermediate results: Either (LHsExpr GhcPs) (LHsCmd GhcPs) There are two problems with this: * We cannot handle the ambiguity between expressions and patterns, which are not disjoint. * Bottom-up flow of information leads to poor error messages. Consider if ... then 5 else (x -< y) Do we report that '5' is not a valid command or that (x -< y) is not a valid expression? It depends on whether we want the entire node to be 'HsIf' or 'HsCmdIf', and this information flows top-down, from the surrounding parsing context (are we in 'proc'?) Alternative V, backtracking with parser combinators --------------------------------------------------- One might think we could sidestep the issue entirely by using a backtracking parser and doing something along the lines of (try pExpr <|> pPat). Turns out, this wouldn't work very well, as there can be patterns inside expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns (e.g. view patterns). To handle this, we would need to backtrack while backtracking, and unbound levels of backtracking lead to very fragile performance. Alternative VI, an intermediate data type ----------------------------------------- There are common syntactic elements of expressions, commands, and patterns (e.g. all of them must have balanced parentheses), and we can capture this common structure in an intermediate data type, Frame: data Frame = FrameVar RdrName -- ^ Identifier: Just, map, BS.length | FrameTuple [LTupArgFrame] Boxity -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,) | FrameTySig LFrame (LHsSigWcType GhcPs) -- ^ Type signature: x :: ty | FramePar (SrcSpan, SrcSpan) LFrame -- ^ Parentheses | FrameIf LFrame LFrame LFrame -- ^ If-expression: if p then x else y | FrameCase LFrame [LFrameMatch] -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 } | FrameDo (HsStmtContext Name) [LFrameStmt] -- ^ Do-expression: do { s1; a <- s2; s3 } ... | FrameExpr (HsExpr GhcPs) -- unambiguously an expression | FramePat (HsPat GhcPs) -- unambiguously a pattern | FrameCommand (HsCmd GhcPs) -- unambiguously a command To determine which constructors 'Frame' needs to have, we take the union of intersections between HsExpr, HsCmd, and HsPat. The intersection between HsPat and HsExpr: HsPat = VarPat | TuplePat | SigPat | ParPat | ... HsExpr = HsVar | ExplicitTuple | ExprWithTySig | HsPar | ... ------------------------------------------------------------------- Frame = FrameVar | FrameTuple | FrameTySig | FramePar | ... The intersection between HsCmd and HsExpr: HsCmd = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar HsExpr = HsIf | HsCase | HsDo | HsPar ------------------------------------------------ Frame = FrameIf | FrameCase | FrameDo | FramePar The intersection between HsCmd and HsPat: HsPat = ParPat | ... HsCmd = HsCmdPar | ... ----------------------- Frame = FramePar | ... Take the union of each intersection and this yields the final 'Frame' data type. The problem with this approach is that we end up duplicating a good portion of hsSyn: Frame for HsExpr, HsPat, HsCmd TupArgFrame for HsTupArg FrameMatch for Match FrameStmt for StmtLR FrameGRHS for GRHS FrameGRHSs for GRHSs ... Alternative VII, a product type ------------------------------- We could avoid the intermediate representation of Alternative VI by parsing into a product of interpretations directly: -- See Note [Parser-Validator] type ExpCmdPat = ( PV (LHsExpr GhcPs) , PV (LHsCmd GhcPs) , PV (LHsPat GhcPs) ) This means that in positions where we do not know whether to produce expression, a pattern, or a command, we instead produce a parser-validator for each possible option. Then, as soon as we have parsed far enough to resolve the ambiguity, we pick the appropriate component of the product, discarding the rest: checkExpOf3 (e, _, _) = e -- interpret as an expression checkCmdOf3 (_, c, _) = c -- interpret as a command checkPatOf3 (_, _, p) = p -- interpret as a pattern We can easily define ambiguities between arbitrary subsets of interpretations. For example, when we know ahead of type that only an expression or a command is possible, but not a pattern, we can use a smaller type: -- See Note [Parser-Validator] type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs)) checkExpOf2 (e, _) = e -- interpret as an expression checkCmdOf2 (_, c) = c -- interpret as a command However, there is a slight problem with this approach, namely code duplication in parser productions. Consider the 'alts' production used to parse case-of alternatives: alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } Under the new scheme, we have to completely duplicate its type signature and each reduction rule: alts :: { ( PV (Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression , PV (Located ([AddAnn],[LMatch GhcPs (LHsCmd GhcPs)])) -- as a command ) } : alts1 { ( checkExpOf2 $1 >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) , checkCmdOf2 $1 >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) ) } | ';' alts { ( checkExpOf2 $2 >>= \ $2 -> return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) , checkCmdOf2 $2 >>= \ $2 -> return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) ) } And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs', 'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code! Alternative VIII, a function from a GADT ---------------------------------------- We could avoid code duplication of the Alternative VII by representing the product as a function from a GADT: data ExpCmdG b where ExpG :: ExpCmdG HsExpr CmdG :: ExpCmdG HsCmd type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs)) checkExp :: ExpCmd -> PV (LHsExpr GhcPs) checkCmd :: ExpCmd -> PV (LHsCmd GhcPs) checkExp f = f ExpG -- interpret as an expression checkCmd f = f CmdG -- interpret as a command Consider the 'alts' production used to parse case-of alternatives: alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } We abstract over LHsExpr, and it becomes: alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } : alts1 { \tag -> $1 tag >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { \tag -> $2 tag >>= \ $2 -> return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } Note that 'ExpCmdG' is a singleton type, the value is completely determined by the type: when (b~HsExpr), tag = ExpG when (b~HsCmd), tag = CmdG This is a clear indication that we can use a class to pass this value behind the scenes: class ExpCmdI b where expCmdG :: ExpCmdG b instance ExpCmdI HsExpr where expCmdG = ExpG instance ExpCmdI HsCmd where expCmdG = CmdG And now the 'alts' production is simplified, as we no longer need to thread 'tag' explicitly: alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } : alts1 { $1 >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { $2 >>= \ $2 -> return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } This encoding works well enough, but introduces an extra GADT unlike the tagless final encoding, and there's no need for this complexity. -} {- Note [PatBuilder] ~~~~~~~~~~~~~~~~~~~~ Unlike HsExpr or HsCmd, the Pat type cannot accomodate all intermediate forms, so we introduce the notion of a PatBuilder. Consider a pattern like this: Con a b c We parse arguments to "Con" one at a time in the fexp aexp parser production, building the result with mkHsAppPV, so the intermediate forms are: 1. Con 2. Con a 3. Con a b 4. Con a b c In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like this (pseudocode): 1. "Con" 2. HsApp "Con" "a" 3. HsApp (HsApp "Con" "a") "b" 3. HsApp (HsApp (HsApp "Con" "a") "b") "c" Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for the intermediate forms. Worse yet, some intermediate forms are not valid patterns at all. For example: Con !a !b c This is parsed as ((Con ! a) ! (b c)) with ! as an infix operator, and then rearranged in 'splitBang'. But of course, neither (b c) nor (Con ! a) are valid patterns, so we cannot represent them as Pat. We also need an intermediate representation to postpone disambiguation between FunBind and PatBind. Consider: a `Con` b = ... a `fun` b = ... How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We learn this by inspecting an intermediate representation in 'isFunLhs' and seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate representation capable of representing both a FunBind and a PatBind, so Pat is insufficient. PatBuilder is an extension of Pat that is capable of representing intermediate parsing results for patterns and function bindings: data PatBuilder p = PatBuilderPat (Pat p) | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) ... It can represent any pattern via 'PatBuilderPat', but it also has a variety of other constructors which were added by following a simple principle: we never pattern match on the pattern stored inside 'PatBuilderPat'. For example, in 'splitBang' we need to match on space-separated and bang-separated patterns, so these are represented with dedicated constructors 'PatBuilderApp' and 'PatBuilderOpApp'. In 'isFunLhs', we pattern match on variables, so we have a dedicated 'PatBuilderVar' constructor for this despite the existence of 'VarPat'. -} --------------------------------------------------------------------------- -- Miscellaneous utilities -- | Check if a fixity is valid. We support bypassing the usual bound checks -- for some special operators. checkPrecP :: Located (SourceText,Int) -- ^ precedence -> Located (OrdList (Located RdrName)) -- ^ operators -> P () checkPrecP (dL->L l (_,i)) (dL->L _ ol) | 0 <= i, i <= maxPrecedence = pure () | all specialOp ol = pure () | otherwise = addFatalError l (text ("Precedence out of range: " ++ show i)) where specialOp op = unLoc op `elem` [ eqTyCon_RDR , getRdrName funTyCon ] mkRecConstrOrUpdate :: LHsExpr GhcPs -> SrcSpan -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) -> PV (HsExpr GhcPs) mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd) | isRdrDataCon c = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd)) mkRecConstrOrUpdate exp _ (fs,dd) | Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update") | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs mkRdrRecordUpd exp flds = RecordUpd { rupd_ext = noExtField , rupd_expr = exp , rupd_flds = flds } mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs mkRdrRecordCon con flds = RecordCon { rcon_ext = noExtField, rcon_con_name = con, rcon_flds = flds } mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs , rec_dotdot = Just (cL s (length fs)) } mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun) = HsRecField (L loc (Unambiguous noExtField rdr)) arg pun mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc nec)) _ _) = noExtCon nec mk_rec_upd_field (HsRecField _ _ _) = panic "mk_rec_upd_field: Impossible Match" -- due to #15884 mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma -- The (Maybe Activation) is because the user can omit -- the activation spec (and usually does) mkInlinePragma src (inl, match_info) mb_act = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes , inl_inline = inl , inl_sat = Nothing , inl_act = act , inl_rule = match_info } where act = case mb_act of Just act -> act Nothing -> -- No phase specified case inl of NoInline -> NeverActive _other -> AlwaysActive ----------------------------------------------------------------------------- -- utilities for foreign declarations -- construct a foreign import declaration -- mkImport :: Located CCallConv -> Located Safety -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) -> P (HsDecl GhcPs) mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = case unLoc cconv of CCallConv -> mkCImport CApiConv -> mkCImport StdCallConv -> mkCImport PrimCallConv -> mkOtherImport JavaScriptCallConv -> mkOtherImport where -- Parse a C-like entity string of the following form: -- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper" -- If 'cid' is missing, the function name 'v' is used instead as symbol -- name (cf section 8.5.1 in Haskell 2010 report). mkCImport = do let e = unpackFS entity case parseCImport cconv safety (mkExtName (unLoc v)) e (cL loc esrc) of Nothing -> addFatalError loc (text "Malformed entity string") Just importSpec -> returnSpec importSpec -- currently, all the other import conventions only support a symbol name in -- the entity string. If it is missing, we use the function name instead. mkOtherImport = returnSpec importSpec where entity' = if nullFS entity then mkExtName (unLoc v) else entity funcTarget = CFunction (StaticTarget esrc entity' Nothing True) importSpec = CImport cconv safety Nothing funcTarget (cL loc esrc) returnSpec spec = return $ ForD noExtField $ ForeignImport { fd_i_ext = noExtField , fd_name = v , fd_sig_ty = ty , fd_fi = spec } -- the string "foo" is ambiguous: either a header or a C identifier. The -- C identifier case comes first in the alternatives below, so we pick -- that one. parseCImport :: Located CCallConv -> Located Safety -> FastString -> String -> Located SourceText -> Maybe ForeignImport parseCImport cconv safety nm str sourceText = listToMaybe $ map fst $ filter (null.snd) $ readP_to_S parse str where parse = do skipSpaces r <- choice [ string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)), string "wrapper" >> return (mk Nothing CWrapper), do optional (token "static" >> skipSpaces) ((mk Nothing <$> cimp nm) +++ (do h <- munch1 hdr_char skipSpaces mk (Just (Header (SourceText h) (mkFastString h))) <$> cimp nm)) ] skipSpaces return r token str = do _ <- string str toks <- look case toks of c : _ | id_char c -> pfail _ -> return () mk h n = CImport cconv safety h n sourceText hdr_char c = not (isSpace c) -- header files are filenames, which can contain -- pretty much any char (depending on the platform), -- so just accept any non-space character id_first_char c = isAlpha c || c == '_' id_char c = isAlphaNum c || c == '_' cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) +++ (do isFun <- case unLoc cconv of CApiConv -> option True (do token "value" skipSpaces return False) _ -> return True cid' <- cid return (CFunction (StaticTarget NoSourceText cid' Nothing isFun))) where cid = return nm +++ (do c <- satisfy id_first_char cs <- many (satisfy id_char) return (mkFastString (c:cs))) -- construct a foreign export declaration -- mkExport :: Located CCallConv -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) -> P (HsDecl GhcPs) mkExport (dL->L lc cconv) (dL->L le (StringLiteral esrc entity), v, ty) = return $ ForD noExtField $ ForeignExport { fd_e_ext = noExtField, fd_name = v, fd_sig_ty = ty , fd_fe = CExport (cL lc (CExportStatic esrc entity' cconv)) (cL le esrc) } where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity -- Supplying the ext_name in a foreign decl is optional; if it -- isn't there, the Haskell name is assumed. Note that no transformation -- of the Haskell name is then performed, so if you foreign export (++), -- it's external name will be "++". Too bad; it's important because we don't -- want z-encoding (e.g. names with z's in them shouldn't be doubled) -- mkExtName :: RdrName -> CLabelString mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) -------------------------------------------------------------------------------- -- Help with module system imports/exports data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [Located ImpExpQcSpec] | ImpExpAllWith [Located ImpExpQcSpec] data ImpExpQcSpec = ImpExpQcName (Located RdrName) | ImpExpQcType (Located RdrName) | ImpExpQcWildcard mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) mkModuleImpExp (dL->L l specname) subs = case subs of ImpExpAbs | isVarNameSpace (rdrNameSpace name) -> return $ IEVar noExtField (cL l (ieNameFromSpec specname)) | otherwise -> IEThingAbs noExtField . cL l <$> nameT ImpExpAll -> IEThingAll noExtField . cL l <$> nameT ImpExpList xs -> (\newName -> IEThingWith noExtField (cL l newName) NoIEWildcard (wrapped xs) []) <$> nameT ImpExpAllWith xs -> do allowed <- getBit PatternSynonymsBit if allowed then let withs = map unLoc xs pos = maybe NoIEWildcard IEWildcard (findIndex isImpExpQcWildcard withs) ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs in (\newName -> IEThingWith noExtField (cL l newName) pos ies []) <$> nameT else addFatalError l (text "Illegal export form (use PatternSynonyms to enable)") where name = ieNameVal specname nameT = if isVarNameSpace (rdrNameSpace name) then addFatalError l (text "Expecting a type constructor but found a variable," <+> quotes (ppr name) <> text "." $$ if isSymOcc $ rdrNameOcc name then text "If" <+> quotes (ppr name) <+> text "is a type constructor" <+> text "then enable ExplicitNamespaces and use the 'type' keyword." else empty) else return $ ieNameFromSpec specname ieNameVal (ImpExpQcName ln) = unLoc ln ieNameVal (ImpExpQcType ln) = unLoc ln ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard" ieNameFromSpec (ImpExpQcName ln) = IEName ln ieNameFromSpec (ImpExpQcType ln) = IEType ln ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" wrapped = map (onHasSrcSpan ieNameFromSpec) mkTypeImpExp :: Located RdrName -- TcCls or Var name space -> P (Located RdrName) mkTypeImpExp name = do allowed <- getBit ExplicitNamespacesBit unless allowed $ addError (getLoc name) $ text "Illegal keyword 'type' (use ExplicitNamespaces to enable)" return (fmap (`setRdrNameSpace` tcClsName) name) checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) checkImportSpec ie@(dL->L _ specs) = case [l | (dL->L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of [] -> return ie (l:_) -> importSpecError l where importSpecError l = addFatalError l (text "Illegal import form, this syntax can only be used to bundle" $+$ text "pattern synonyms with types in module exports.") -- In the correct order mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec) mkImpExpSubSpec [] = return ([], ImpExpList []) mkImpExpSubSpec [dL->L _ ImpExpQcWildcard] = return ([], ImpExpAll) mkImpExpSubSpec xs = if (any (isImpExpQcWildcard . unLoc) xs) then return $ ([], ImpExpAllWith xs) else return $ ([], ImpExpList xs) isImpExpQcWildcard :: ImpExpQcSpec -> Bool isImpExpQcWildcard ImpExpQcWildcard = True isImpExpQcWildcard _ = False ----------------------------------------------------------------------------- -- Warnings and failures warnPrepositiveQualifiedModule :: SrcSpan -> P () warnPrepositiveQualifiedModule span = addWarning Opt_WarnPrepositiveQualifiedModule span msg where msg = text "Found" <+> quotes (text "qualified") <+> text "in prepositive position" $$ text "Suggested fix: place " <+> quotes (text "qualified") <+> text "after the module name instead." failOpNotEnabledImportQualifiedPost :: SrcSpan -> P () failOpNotEnabledImportQualifiedPost loc = addError loc msg where msg = text "Found" <+> quotes (text "qualified") <+> text "in postpositive position. " $$ text "To allow this, enable language extension 'ImportQualifiedPost'" failOpImportQualifiedTwice :: SrcSpan -> P () failOpImportQualifiedTwice loc = addError loc msg where msg = text "Multiple occurences of 'qualified'" warnStarIsType :: SrcSpan -> P () warnStarIsType span = addWarning Opt_WarnStarIsType span msg where msg = text "Using" <+> quotes (text "*") <+> text "(or its Unicode variant) to mean" <+> quotes (text "Data.Kind.Type") $$ text "relies on the StarIsType extension, which will become" $$ text "deprecated in the future." $$ text "Suggested fix: use" <+> quotes (text "Type") <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead." warnStarBndr :: SrcSpan -> P () warnStarBndr span = addWarning Opt_WarnStarBinder span msg where msg = text "Found binding occurrence of" <+> quotes (text "*") <+> text "yet StarIsType is enabled." $$ text "NB. To use (or export) this operator in" <+> text "modules with StarIsType," $$ text " including the definition module, you must qualify it." failOpFewArgs :: Located RdrName -> P a failOpFewArgs (dL->L loc op) = do { star_is_type <- getBit StarIsTypeBit ; let msg = too_few $$ starInfo star_is_type op ; addFatalError loc msg } where too_few = text "Operator applied to too few arguments:" <+> ppr op failOpDocPrev :: SrcSpan -> P a failOpDocPrev loc = addFatalError loc msg where msg = text "Unexpected documentation comment." failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = addFatalError loc msg where msg = text "Strictness annotation applied to a compound type." $$ text "Did you mean to add parentheses?" $$ nest 2 (ppr str <> parens (ppr ty)) failOpStrictnessPosition :: Located SrcStrictness -> P a failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg where msg = text "Strictness annotation cannot appear in this position." ----------------------------------------------------------------------------- -- Misc utils data PV_Context = PV_Context { pv_options :: ParserFlags , pv_hint :: SDoc -- See Note [Parser-Validator Hint] } data PV_Accum = PV_Accum { pv_messages :: DynFlags -> Messages , pv_annotations :: [(ApiAnnKey,[SrcSpan])] , pv_comment_q :: [Located AnnotationComment] , pv_annotations_comments :: [(SrcSpan,[Located AnnotationComment])] } data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum -- See Note [Parser-Validator] newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a } instance Functor PV where fmap = liftM instance Applicative PV where pure a = a `seq` PV (\_ acc -> PV_Ok acc a) (<*>) = ap instance Monad PV where m >>= f = PV $ \ctx acc -> case unPV m ctx acc of PV_Ok acc' a -> unPV (f a) ctx acc' PV_Failed acc' -> PV_Failed acc' runPV :: PV a -> P a runPV = runPV_msg empty runPV_msg :: SDoc -> PV a -> P a runPV_msg msg m = P $ \s -> let pv_ctx = PV_Context { pv_options = options s , pv_hint = msg } pv_acc = PV_Accum { pv_messages = messages s , pv_annotations = annotations s , pv_comment_q = comment_q s , pv_annotations_comments = annotations_comments s } mkPState acc' = s { messages = pv_messages acc' , annotations = pv_annotations acc' , comment_q = pv_comment_q acc' , annotations_comments = pv_annotations_comments acc' } in case unPV m pv_ctx pv_acc of PV_Ok acc' a -> POk (mkPState acc') a PV_Failed acc' -> PFailed (mkPState acc') localPV_msg :: (SDoc -> SDoc) -> PV a -> PV a localPV_msg f m = let modifyHint ctx = ctx{pv_hint = f (pv_hint ctx)} in PV (\ctx acc -> unPV m (modifyHint ctx) acc) instance MonadP PV where addError srcspan msg = PV $ \ctx acc@PV_Accum{pv_messages=m} -> let msg' = msg $$ pv_hint ctx in PV_Ok acc{pv_messages=appendError srcspan msg' m} () addWarning option srcspan warning = PV $ \PV_Context{pv_options=o} acc@PV_Accum{pv_messages=m} -> PV_Ok acc{pv_messages=appendWarning o option srcspan warning m} () addFatalError srcspan msg = addError srcspan msg >> PV (const PV_Failed) getBit ext = PV $ \ctx acc -> let b = ext `xtest` pExtsBitmap (pv_options ctx) in PV_Ok acc $! b addAnnotation l a v = PV $ \_ acc -> let (comment_q', new_ann_comments) = allocateComments l (pv_comment_q acc) annotations_comments' = new_ann_comments ++ pv_annotations_comments acc annotations' = ((l,a), [v]) : pv_annotations acc acc' = acc { pv_annotations = annotations' , pv_comment_q = comment_q' , pv_annotations_comments = annotations_comments' } in PV_Ok acc' () {- Note [Parser-Validator] ~~~~~~~~~~~~~~~~~~~~~~~~~~ When resolving ambiguities, we need to postpone failure to make a choice later. For example, if we have ambiguity between some A and B, our parser could be abParser :: P (Maybe A, Maybe B) This way we can represent four possible outcomes of parsing: (Just a, Nothing) -- definitely A (Nothing, Just b) -- definitely B (Just a, Just b) -- either A or B (Nothing, Nothing) -- neither A nor B However, if we want to report informative parse errors, accumulate warnings, and add API annotations, we are better off using 'P' instead of 'Maybe': abParser :: P (P A, P B) So we have an outer layer of P that consumes the input and builds the inner layer, which validates the input. For clarity, we introduce the notion of a parser-validator: a parser that does not consume any input, but may fail or use other effects. Thus we have: abParser :: P (PV A, PV B) -} {- Note [Parser-Validator Hint] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A PV computation is parametrized by a hint for error messages, which can be set depending on validation context. We use this in checkPattern to fix #984. Consider this example, where the user has forgotten a 'do': f _ = do x <- computation case () of _ -> result <- computation case () of () -> undefined GHC parses it as follows: f _ = do x <- computation (case () of _ -> result) <- computation case () of () -> undefined Note that this fragment is parsed as a pattern: case () of _ -> result We attempt to detect such cases and add a hint to the error messages: T984.hs:6:9: Parse error in pattern: case () of { _ -> result } Possibly caused by a missing 'do'? The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed as the 'pv_hint' field 'PV_Context'. When validating in a context other than 'bindpat' (a pattern to the left of <-), we set the hint to 'empty' and it has no effect on the error messages. -} -- | Hint about bang patterns, assuming @BangPatterns@ is off. hintBangPat :: SrcSpan -> PatBuilder GhcPs -> PV () hintBangPat span e = do bang_on <- getBit BangPatBit unless bang_on $ addFatalError span (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e) data SumOrTuple b = Sum ConTag Arity (Located b) | Tuple [Located (Maybe (Located b))] pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc pprSumOrTuple boxity = \case Sum alt arity e -> parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> parClose Tuple xs -> parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs) <> parClose where ppr_bars n = hsep (replicate n (Outputable.char '|')) (parOpen, parClose) = case boxity of Boxed -> (text "(", text ")") Unboxed -> (text "(#", text "#)") mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs) -- Tuple mkSumOrTupleExpr l boxity (Tuple es) = return $ cL l (ExplicitTuple noExtField (map toTupArg es) boxity) where toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs toTupArg = mapLoc (maybe missingTupArg (Present noExtField)) -- Sum mkSumOrTupleExpr l Unboxed (Sum alt arity e) = return $ cL l (ExplicitSum noExtField alt arity e) mkSumOrTupleExpr l Boxed a@Sum{} = addFatalError l (hang (text "Boxed sums not supported:") 2 (pprSumOrTuple Boxed a)) mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)) -- Tuple mkSumOrTuplePat l boxity (Tuple ps) = do ps' <- traverse toTupPat ps return $ cL l (PatBuilderPat (TuplePat noExtField ps' boxity)) where toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs) toTupPat (dL -> L l p) = case p of Nothing -> addFatalError l (text "Tuple section in pattern context") Just p' -> checkLPat p' -- Sum mkSumOrTuplePat l Unboxed (Sum alt arity p) = do p' <- checkLPat p return $ cL l (PatBuilderPat (SumPat noExtField p' alt arity)) mkSumOrTuplePat l Boxed a@Sum{} = addFatalError l (hang (text "Boxed sums not supported:") 2 (pprSumOrTuple Boxed a)) mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy x op y = let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y in cL loc (mkHsOpTy x op y) mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs mkLHsDocTy t doc = let loc = getLoc t `combineSrcSpans` getLoc doc in cL loc (HsDocTy noExtField t doc) mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t) ----------------------------------------------------------------------------- -- Token symbols starSym :: Bool -> String starSym True = "★" starSym False = "*" forallSym :: Bool -> String forallSym True = "∀" forallSym False = "forall" ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/RdrName.hs0000644000000000000000000015147513713635744021327 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} {-# LANGUAGE CPP, DeriveDataTypeable #-} -- | -- #name_types# -- GHC uses several kinds of name internally: -- -- * 'OccName.OccName': see "OccName#name_types" -- -- * 'RdrName.RdrName' is the type of names that come directly from the parser. They -- have not yet had their scoping and binding resolved by the renamer and can be -- thought of to a first approximation as an 'OccName.OccName' with an optional module -- qualifier -- -- * 'Name.Name': see "Name#name_types" -- -- * 'Id.Id': see "Id#name_types" -- -- * 'Var.Var': see "Var#name_types" module RdrName ( -- * The main type RdrName(..), -- Constructors exported only to BinIface -- ** Construction mkRdrUnqual, mkRdrQual, mkUnqual, mkVarUnqual, mkQual, mkOrig, nameRdrName, getRdrName, -- ** Destruction rdrNameOcc, rdrNameSpace, demoteRdrName, isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, -- * Local mapping of 'RdrName' to 'Name.Name' LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv, inLocalRdrEnvScope, localRdrEnvElts, delLocalRdrEnvList, -- * Global mapping of 'RdrName' to 'GlobalRdrElt's GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames, pprGlobalRdrEnv, globalRdrEnvElts, lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel, lookupGRE_Name_OccName, getGRE_NameQualifier_maybes, transformGREs, pickGREs, pickGREsModExp, -- * GlobalRdrElts gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE, greRdrNames, greSrcSpan, greQualModName, gresToAvailInfo, -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' GlobalRdrElt(..), isLocalGRE, isRecFldGRE, isOverloadedRecFldGRE, greLabel, unQualOK, qualSpecOK, unQualSpecOK, pprNameProvenance, Parent(..), greParent_maybe, ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), importSpecLoc, importSpecModule, isExplicitItem, bestImport, -- * Utils for StarIsType starInfo ) where #include "GhclibHsVersions.h" import GhcPrelude import Module import Name import Avail import NameSet import Maybes import SrcLoc import FastString import FieldLabel import Outputable import Unique import UniqFM import UniqSet import Util import NameEnv import Data.Data import Data.List( sortBy ) {- ************************************************************************ * * \subsection{The main data type} * * ************************************************************************ -} -- | Reader Name -- -- Do not use the data constructors of RdrName directly: prefer the family -- of functions that creates them, such as 'mkRdrUnqual' -- -- - Note: A Located RdrName will only have API Annotations if it is a -- compound one, -- e.g. -- -- > `bar` -- > ( ~ ) -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnOpen' @'('@ or @'['@ or @'[:'@, -- 'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,, -- 'ApiAnnotation.AnnBackquote' @'`'@, -- 'ApiAnnotation.AnnVal' -- 'ApiAnnotation.AnnTilde', -- For details on above see note [Api annotations] in ApiAnnotation data RdrName = Unqual OccName -- ^ Unqualified name -- -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. -- Create such a 'RdrName' with 'mkRdrUnqual' | Qual ModuleName OccName -- ^ Qualified name -- -- A qualified name written by the user in -- /source/ code. The module isn't necessarily -- the module where the thing is defined; -- just the one from which it is imported. -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. -- Create such a 'RdrName' with 'mkRdrQual' | Orig Module OccName -- ^ Original name -- -- An original name; the module is the /defining/ module. -- This is used when GHC generates code that will be fed -- into the renamer (e.g. from deriving clauses), but where -- we want to say \"Use Prelude.map dammit\". One of these -- can be created with 'mkOrig' | Exact Name -- ^ Exact name -- -- We know exactly the 'Name'. This is used: -- -- (1) When the parser parses built-in syntax like @[]@ -- and @(,)@, but wants a 'RdrName' from it -- -- (2) By Template Haskell, when TH has generated a unique name -- -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' deriving Data {- ************************************************************************ * * \subsection{Simple functions} * * ************************************************************************ -} instance HasOccName RdrName where occName = rdrNameOcc rdrNameOcc :: RdrName -> OccName rdrNameOcc (Qual _ occ) = occ rdrNameOcc (Unqual occ) = occ rdrNameOcc (Orig _ occ) = occ rdrNameOcc (Exact name) = nameOccName name rdrNameSpace :: RdrName -> NameSpace rdrNameSpace = occNameSpace . rdrNameOcc -- demoteRdrName lowers the NameSpace of RdrName. -- see Note [Demotion] in OccName demoteRdrName :: RdrName -> Maybe RdrName demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) demoteRdrName (Orig _ _) = panic "demoteRdrName" demoteRdrName (Exact _) = panic "demoteRdrName" -- These two are the basic constructors mkRdrUnqual :: OccName -> RdrName mkRdrUnqual occ = Unqual occ mkRdrQual :: ModuleName -> OccName -> RdrName mkRdrQual mod occ = Qual mod occ mkOrig :: Module -> OccName -> RdrName mkOrig mod occ = Orig mod occ --------------- -- These two are used when parsing source files -- They do encode the module and occurrence names mkUnqual :: NameSpace -> FastString -> RdrName mkUnqual sp n = Unqual (mkOccNameFS sp n) mkVarUnqual :: FastString -> RdrName mkVarUnqual n = Unqual (mkVarOccFS n) -- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and -- the 'OccName' are taken from the first and second elements of the tuple respectively mkQual :: NameSpace -> (FastString, FastString) -> RdrName mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) getRdrName :: NamedThing thing => thing -> RdrName getRdrName name = nameRdrName (getName name) nameRdrName :: Name -> RdrName nameRdrName name = Exact name -- Keep the Name even for Internal names, so that the -- unique is still there for debug printing, particularly -- of Types (which are converted to IfaceTypes before printing) nukeExact :: Name -> RdrName nukeExact n | isExternalName n = Orig (nameModule n) (nameOccName n) | otherwise = Unqual (nameOccName n) isRdrDataCon :: RdrName -> Bool isRdrTyVar :: RdrName -> Bool isRdrTc :: RdrName -> Bool isRdrDataCon rn = isDataOcc (rdrNameOcc rn) isRdrTyVar rn = isTvOcc (rdrNameOcc rn) isRdrTc rn = isTcOcc (rdrNameOcc rn) isSrcRdrName :: RdrName -> Bool isSrcRdrName (Unqual _) = True isSrcRdrName (Qual _ _) = True isSrcRdrName _ = False isUnqual :: RdrName -> Bool isUnqual (Unqual _) = True isUnqual _ = False isQual :: RdrName -> Bool isQual (Qual _ _) = True isQual _ = False isQual_maybe :: RdrName -> Maybe (ModuleName, OccName) isQual_maybe (Qual m n) = Just (m,n) isQual_maybe _ = Nothing isOrig :: RdrName -> Bool isOrig (Orig _ _) = True isOrig _ = False isOrig_maybe :: RdrName -> Maybe (Module, OccName) isOrig_maybe (Orig m n) = Just (m,n) isOrig_maybe _ = Nothing isExact :: RdrName -> Bool isExact (Exact _) = True isExact _ = False isExact_maybe :: RdrName -> Maybe Name isExact_maybe (Exact n) = Just n isExact_maybe _ = Nothing {- ************************************************************************ * * \subsection{Instances} * * ************************************************************************ -} instance Outputable RdrName where ppr (Exact name) = ppr name ppr (Unqual occ) = ppr occ ppr (Qual mod occ) = ppr mod <> dot <> ppr occ ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ) instance OutputableBndr RdrName where pprBndr _ n | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n | otherwise = ppr n pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) pprPrefixOcc rdr | Just name <- isExact_maybe rdr = pprPrefixName name -- pprPrefixName has some special cases, so -- we delegate to them rather than reproduce them | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) instance Eq RdrName where (Exact n1) == (Exact n2) = n1==n2 -- Convert exact to orig (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 (Unqual o1) == (Unqual o2) = o1==o2 _ == _ = False instance Ord RdrName where a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } -- Exact < Unqual < Qual < Orig -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig -- before comparing so that Prelude.map == the exact Prelude.map, but -- that meant that we reported duplicates when renaming bindings -- generated by Template Haskell; e.g -- do { n1 <- newName "foo"; n2 <- newName "foo"; -- } -- I think we can do without this conversion compare (Exact n1) (Exact n2) = n1 `compare` n2 compare (Exact _) _ = LT compare (Unqual _) (Exact _) = GT compare (Unqual o1) (Unqual o2) = o1 `compare` o2 compare (Unqual _) _ = LT compare (Qual _ _) (Exact _) = GT compare (Qual _ _) (Unqual _) = GT compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) compare (Qual _ _) (Orig _ _) = LT compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) compare (Orig _ _) _ = GT {- ************************************************************************ * * LocalRdrEnv * * ************************************************************************ -} -- | Local Reader Environment -- -- This environment is used to store local bindings -- (@let@, @where@, lambda, @case@). -- It is keyed by OccName, because we never use it for qualified names -- We keep the current mapping, *and* the set of all Names in scope -- Reason: see Note [Splicing Exact names] in RnEnv data LocalRdrEnv = LRE { lre_env :: OccEnv Name , lre_in_scope :: NameSet } instance Outputable LocalRdrEnv where ppr (LRE {lre_env = env, lre_in_scope = ns}) = hang (text "LocalRdrEnv {") 2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env , text "in_scope =" <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr) ] <+> char '}') where ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name -- So we can see if the keys line up correctly emptyLocalRdrEnv :: LocalRdrEnv emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv , lre_in_scope = emptyNameSet } extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv -- The Name should be a non-top-level thing extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name = WARN( isExternalName name, ppr name ) lre { lre_env = extendOccEnv env (nameOccName name) name , lre_in_scope = extendNameSet ns name } extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names = WARN( any isExternalName names, ppr names ) lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names] , lre_in_scope = extendNameSetList ns names } lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr | Unqual occ <- rdr = lookupOccEnv env occ -- See Note [Local bindings with Exact Names] | Exact name <- rdr , name `elemNameSet` ns = Just name | otherwise = Nothing lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) = case rdr_name of Unqual occ -> occ `elemOccEnv` env Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] Qual {} -> False Orig {} -> False localRdrEnvElts :: LocalRdrEnv -> [Name] localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool -- This is the point of the NameSet inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv delLocalRdrEnvList lre@(LRE { lre_env = env }) occs = lre { lre_env = delListFromOccEnv env occs } {- Note [Local bindings with Exact Names] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ With Template Haskell we can make local bindings that have Exact Names. Computing shadowing etc may use elemLocalRdrEnv (at least it certainly does so in RnTpes.bindHsQTyVars), so for an Exact Name we must consult the in-scope-name-set. ************************************************************************ * * GlobalRdrEnv * * ************************************************************************ -} -- | Global Reader Environment type GlobalRdrEnv = OccEnv [GlobalRdrElt] -- ^ Keyed by 'OccName'; when looking up a qualified name -- we look up the 'OccName' part, and then check the 'Provenance' -- to see if the appropriate qualification is valid. This -- saves routinely doubling the size of the env by adding both -- qualified and unqualified names to the domain. -- -- The list in the codomain is required because there may be name clashes -- These only get reported on lookup, not on construction -- -- INVARIANT 1: All the members of the list have distinct -- 'gre_name' fields; that is, no duplicate Names -- -- INVARIANT 2: Imported provenance => Name is an ExternalName -- However LocalDefs can have an InternalName. This -- happens only when type-checking a [d| ... |] Template -- Haskell quotation; see this note in RnNames -- Note [Top-level Names in Template Haskell decl quotes] -- -- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then -- greOccName gre = occ -- -- NB: greOccName gre is usually the same as -- nameOccName (gre_name gre), but not always in the -- case of record seectors; see greOccName -- | Global Reader Element -- -- An element of the 'GlobalRdrEnv' data GlobalRdrElt = GRE { gre_name :: Name , gre_par :: Parent , gre_lcl :: Bool -- ^ True <=> the thing was defined locally , gre_imp :: [ImportSpec] -- ^ In scope through these imports } deriving (Data, Eq) -- INVARIANT: either gre_lcl = True or gre_imp is non-empty -- See Note [GlobalRdrElt provenance] -- | The children of a Name are the things that are abbreviated by the ".." -- notation in export lists. See Note [Parents] data Parent = NoParent | ParentIs { par_is :: Name } | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString } -- ^ See Note [Parents for record fields] deriving (Eq, Data) instance Outputable Parent where ppr NoParent = empty ppr (ParentIs n) = text "parent:" <> ppr n ppr (FldParent n f) = text "fldparent:" <> ppr n <> colon <> ppr f plusParent :: Parent -> Parent -> Parent -- See Note [Combining parents] plusParent p1@(ParentIs _) p2 = hasParent p1 p2 plusParent p1@(FldParent _ _) p2 = hasParent p1 p2 plusParent p1 p2@(ParentIs _) = hasParent p2 p1 plusParent p1 p2@(FldParent _ _) = hasParent p2 p1 plusParent _ _ = NoParent hasParent :: Parent -> Parent -> Parent #if defined(DEBUG) hasParent p NoParent = p hasParent p p' | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p') -- Parents should agree #endif hasParent p _ = p {- Note [GlobalRdrElt provenance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance", i.e. how the Name came to be in scope. It can be in scope two ways: - gre_lcl = True: it is bound in this module - gre_imp: a list of all the imports that brought it into scope It's an INVARIANT that you have one or the other; that is, either gre_lcl is True, or gre_imp is non-empty. It is just possible to have *both* if there is a module loop: a Name is defined locally in A, and also brought into scope by importing a module that SOURCE-imported A. Exapmle (#7672): A.hs-boot module A where data T B.hs module B(Decl.T) where import {-# SOURCE #-} qualified A as Decl A.hs module A where import qualified B data T = Z | S B.T In A.hs, 'T' is locally bound, *and* imported as B.T. Note [Parents] ~~~~~~~~~~~~~~~~~ Parent Children ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ data T Data constructors Record-field ids data family T Data constructors and record-field ids of all visible data instances of T class C Class operations Associated type constructors ~~~~~~~~~~~~~~~~~~~~~~~~~ Constructor Meaning ~~~~~~~~~~~~~~~~~~~~~~~~ NoParent Can not be bundled with a type constructor. ParentIs n Can be bundled with the type constructor corresponding to n. FldParent See Note [Parents for record fields] Note [Parents for record fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For record fields, in addition to the Name of the type constructor (stored in par_is), we use FldParent to store the field label. This extra information is used for identifying overloaded record fields during renaming. In a definition arising from a normal module (without -XDuplicateRecordFields), par_lbl will be Nothing, meaning that the field's label is the same as the OccName of the selector's Name. The GlobalRdrEnv will contain an entry like this: "x" |-> GRE x (FldParent T Nothing) LocalDef When -XDuplicateRecordFields is enabled for the module that contains T, the selector's Name will be mangled (see comments in FieldLabel). Thus we store the actual field label in par_lbl, and the GlobalRdrEnv entry looks like this: "x" |-> GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef Note that the OccName used when adding a GRE to the environment (greOccName) now depends on the parent field: for FldParent it is the field label, if present, rather than the selector name. ~~ Record pattern synonym selectors are treated differently. Their parent information is `NoParent` in the module in which they are defined. This is because a pattern synonym `P` has no parent constructor either. However, if `f` is bundled with a type constructor `T` then whenever `f` is imported the parent will use the `Parent` constructor so the parent of `f` is now `T`. Note [Combining parents] ~~~~~~~~~~~~~~~~~~~~~~~~ With an associated type we might have module M where class C a where data T a op :: T a -> a instance C Int where data T Int = TInt instance C Bool where data T Bool = TBool Then: C is the parent of T T is the parent of TInt and TBool So: in an export list C(..) is short for C( op, T ) T(..) is short for T( TInt, TBool ) Module M exports everything, so its exports will be AvailTC C [C,T,op] AvailTC T [T,TInt,TBool] On import we convert to GlobalRdrElt and then combine those. For T that will mean we have one GRE with Parent C one GRE with NoParent That's why plusParent picks the "best" case. -} -- | make a 'GlobalRdrEnv' where all the elements point to the same -- Provenance (useful for "hiding" imports, or imports with no details). gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] -- prov = Nothing => locally bound -- Just spec => imported as described by spec gresFromAvails prov avails = concatMap (gresFromAvail (const prov)) avails localGREsFromAvail :: AvailInfo -> [GlobalRdrElt] -- Turn an Avail into a list of LocalDef GlobalRdrElts localGREsFromAvail = gresFromAvail (const Nothing) gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt] gresFromAvail prov_fn avail = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail) where mk_gre n = case prov_fn n of -- Nothing => bound locally -- Just is => imported from 'is' Nothing -> GRE { gre_name = n, gre_par = mkParent n avail , gre_lcl = True, gre_imp = [] } Just is -> GRE { gre_name = n, gre_par = mkParent n avail , gre_lcl = False, gre_imp = [is] } mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded , flSelector = n }) = case prov_fn n of -- Nothing => bound locally -- Just is => imported from 'is' Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl , gre_lcl = True, gre_imp = [] } Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl , gre_lcl = False, gre_imp = [is] } where mb_lbl | is_overloaded = Just lbl | otherwise = Nothing greQualModName :: GlobalRdrElt -> ModuleName -- Get a suitable module qualifier for the GRE -- (used in mkPrintUnqualified) -- Prerecondition: the gre_name is always External greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) | lcl, Just mod <- nameModule_maybe name = moduleName mod | (is:_) <- iss = is_as (is_decl is) | otherwise = pprPanic "greQualModName" (ppr gre) greRdrNames :: GlobalRdrElt -> [RdrName] greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss) where occ = greOccName gre unqual = Unqual occ do_spec decl_spec | is_qual decl_spec = [qual] | otherwise = [unqual,qual] where qual = Qual (is_as decl_spec) occ -- the SrcSpan that pprNameProvenance prints out depends on whether -- the Name is defined locally or not: for a local definition the -- definition site is used, otherwise the location of the import -- declaration. We want to sort the export locations in -- exportClashErr by this SrcSpan, we need to extract it: greSrcSpan :: GlobalRdrElt -> SrcSpan greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } ) | lcl = nameSrcSpan name | (is:_) <- iss = is_dloc (is_decl is) | otherwise = pprPanic "greSrcSpan" (ppr gre) mkParent :: Name -> AvailInfo -> Parent mkParent _ (Avail _) = NoParent mkParent n (AvailTC m _ _) | n == m = NoParent | otherwise = ParentIs m greParent_maybe :: GlobalRdrElt -> Maybe Name greParent_maybe gre = case gre_par gre of NoParent -> Nothing ParentIs n -> Just n FldParent n _ -> Just n -- | Takes a list of distinct GREs and folds them -- into AvailInfos. This is more efficient than mapping each individual -- GRE to an AvailInfo and the folding using `plusAvail` but needs the -- uniqueness assumption. gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo] gresToAvailInfo gres = nameEnvElts avail_env where avail_env :: NameEnv AvailInfo -- Keyed by the parent (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres add :: (NameEnv AvailInfo, NameSet) -> GlobalRdrElt -> (NameEnv AvailInfo, NameSet) add (env, done) gre | name `elemNameSet` done = (env, done) -- Don't insert twice into the AvailInfo | otherwise = ( extendNameEnv_Acc comb availFromGRE env key gre , done `extendNameSet` name ) where name = gre_name gre key = case greParent_maybe gre of Just parent -> parent Nothing -> gre_name gre -- We want to insert the child `k` into a list of children but -- need to maintain the invariant that the parent is first. -- -- We also use the invariant that `k` is not already in `ns`. insertChildIntoChildren :: Name -> [Name] -> Name -> [Name] insertChildIntoChildren _ [] k = [k] insertChildIntoChildren p (n:ns) k | p == k = k:n:ns | otherwise = n:k:ns comb :: GlobalRdrElt -> AvailInfo -> AvailInfo comb _ (Avail n) = Avail n -- Duplicated name, should not happen comb gre (AvailTC m ns fls) = case gre_par gre of NoParent -> AvailTC m (name:ns) fls -- Not sure this ever happens ParentIs {} -> AvailTC m (insertChildIntoChildren m ns name) fls FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel name mb_lbl : fls) availFromGRE :: GlobalRdrElt -> AvailInfo availFromGRE (GRE { gre_name = me, gre_par = parent }) = case parent of ParentIs p -> AvailTC p [me] [] NoParent | isTyConName me -> AvailTC me [me] [] | otherwise -> avail me FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl] mkFieldLabel :: Name -> Maybe FastString -> FieldLabel mkFieldLabel me mb_lbl = case mb_lbl of Nothing -> FieldLabel { flLabel = occNameFS (nameOccName me) , flIsOverloaded = False , flSelector = me } Just lbl -> FieldLabel { flLabel = lbl , flIsOverloaded = True , flSelector = me } emptyGlobalRdrEnv :: GlobalRdrEnv emptyGlobalRdrEnv = emptyOccEnv globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] globalRdrEnvElts env = foldOccEnv (++) [] env instance Outputable GlobalRdrElt where ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre)) 2 (pprNameProvenance gre) pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc pprGlobalRdrEnv locals_only env = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)")) <+> lbrace , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ] <+> rbrace) ] where remove_locals gres | locals_only = filter isLocalGRE gres | otherwise = gres pp [] = empty pp gres = hang (ppr occ <+> parens (text "unique" <+> ppr (getUnique occ)) <> colon) 2 (vcat (map ppr gres)) where occ = nameOccName (gre_name (head gres)) lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of Nothing -> [] Just gres -> gres greOccName :: GlobalRdrElt -> OccName greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl greOccName gre = nameOccName (gre_name gre) lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] lookupGRE_RdrName rdr_name env = case lookupOccEnv env (rdrNameOcc rdr_name) of Nothing -> [] Just gres -> pickGREs rdr_name gres lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt -- ^ Look for precisely this 'Name' in the environment. This tests -- whether it is in scope, ignoring anything else that might be in -- scope with the same 'OccName'. lookupGRE_Name env name = lookupGRE_Name_OccName env name (nameOccName name) lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt -- ^ Look for a particular record field selector in the environment, where the -- selector name and field label may be different: the GlobalRdrEnv is keyed on -- the label. See Note [Parents for record fields] for why this happens. lookupGRE_FieldLabel env fl = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl)) lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt -- ^ Look for precisely this 'Name' in the environment, but with an 'OccName' -- that might differ from that of the 'Name'. See 'lookupGRE_FieldLabel' and -- Note [Parents for record fields]. lookupGRE_Name_OccName env name occ = case [ gre | gre <- lookupGlobalRdrEnv env occ , gre_name gre == name ] of [] -> Nothing [gre] -> Just gre gres -> pprPanic "lookupGRE_Name_OccName" (ppr name $$ ppr occ $$ ppr gres) -- See INVARIANT 1 on GlobalRdrEnv getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] -- Returns all the qualifiers by which 'x' is in scope -- Nothing means "the unqualified version is in scope" -- [] means the thing is not in scope at all getGRE_NameQualifier_maybes env name = case lookupGRE_Name env name of Just gre -> [qualifier_maybe gre] Nothing -> [] where qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss }) | lcl = Nothing | otherwise = Just $ map (is_as . is_decl) iss isLocalGRE :: GlobalRdrElt -> Bool isLocalGRE (GRE {gre_lcl = lcl }) = lcl isRecFldGRE :: GlobalRdrElt -> Bool isRecFldGRE (GRE {gre_par = FldParent{}}) = True isRecFldGRE _ = False isOverloadedRecFldGRE :: GlobalRdrElt -> Bool -- ^ Is this a record field defined with DuplicateRecordFields? -- (See Note [Parents for record fields]) isOverloadedRecFldGRE (GRE {gre_par = FldParent{par_lbl = Just _}}) = True isOverloadedRecFldGRE _ = False -- Returns the field label of this GRE, if it has one greLabel :: GlobalRdrElt -> Maybe FieldLabelString greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl greLabel (GRE{gre_name = n, gre_par = FldParent{}}) = Just (occNameFS (nameOccName n)) greLabel _ = Nothing unQualOK :: GlobalRdrElt -> Bool -- ^ Test if an unqualified version of this thing would be in scope unQualOK (GRE {gre_lcl = lcl, gre_imp = iss }) | lcl = True | otherwise = any unQualSpecOK iss {- Note [GRE filtering] ~~~~~~~~~~~~~~~~~~~~~~~ (pickGREs rdr gres) takes a list of GREs which have the same OccName as 'rdr', say "x". It does two things: (a) filters the GREs to a subset that are in scope * Qualified, as 'M.x' if want_qual is Qual M _ * Unqualified, as 'x' if want_unqual is Unqual _ (b) for that subset, filter the provenance field (gre_lcl and gre_imp) to ones that brought it into scope qualified or unqualified resp. Example: module A ( f ) where import qualified Foo( f ) import Baz( f ) f = undefined Let's suppose that Foo.f and Baz.f are the same entity really, but the local 'f' is different, so there will be two GREs matching "f": gre1: gre_lcl = True, gre_imp = [] gre2: gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ] The use of "f" in the export list is ambiguous because it's in scope from the local def and the import Baz(f); but *not* the import qualified Foo. pickGREs returns two GRE gre1: gre_lcl = True, gre_imp = [] gre2: gre_lcl = False, gre_imp = [ imported from Bar ] Now the "ambiguous occurrence" message can correctly report how the ambiguity arises. -} pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] -- ^ Takes a list of GREs which have the right OccName 'x' -- Pick those GREs that are in scope -- * Qualified, as 'M.x' if want_qual is Qual M _ -- * Unqualified, as 'x' if want_unqual is Unqual _ -- -- Return each such GRE, with its ImportSpecs filtered, to reflect -- how it is in scope qualified or unqualified respectively. -- See Note [GRE filtering] pickGREs (Unqual {}) gres = mapMaybe pickUnqualGRE gres pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres pickGREs _ _ = [] -- I don't think this actually happens pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss }) | not lcl, null iss' = Nothing | otherwise = Just (gre { gre_imp = iss' }) where iss' = filter unQualSpecOK iss pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss }) | not lcl', null iss' = Nothing | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) where iss' = filter (qualSpecOK mod) iss lcl' = lcl && name_is_from mod n name_is_from :: ModuleName -> Name -> Bool name_is_from mod name = case nameModule_maybe name of Just n_mod -> moduleName n_mod == mod Nothing -> False pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)] -- ^ Pick GREs that are in scope *both* qualified *and* unqualified -- Return each GRE that is, as a pair -- (qual_gre, unqual_gre) -- These two GREs are the original GRE with imports filtered to express how -- it is in scope qualified an unqualified respectively -- -- Used only for the 'module M' item in export list; -- see RnNames.exports_from_avail pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt) pickBothGRE mod gre@(GRE { gre_name = n }) | isBuiltInSyntax n = Nothing | Just gre1 <- pickQualGRE mod gre , Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2) | otherwise = Nothing where -- isBuiltInSyntax filter out names for built-in syntax They -- just clutter up the environment (esp tuples), and the -- parser will generate Exact RdrNames for them, so the -- cluttered envt is no use. Really, it's only useful for -- GHC.Base and GHC.Tuple. -- Building GlobalRdrEnvs plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv mkGlobalRdrEnv gres = foldr add emptyGlobalRdrEnv gres where add gre env = extendOccEnv_Acc insertGRE singleton env (greOccName gre) gre insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] insertGRE new_g [] = [new_g] insertGRE new_g (old_g : old_gs) | gre_name new_g == gre_name old_g = new_g `plusGRE` old_g : old_gs | otherwise = old_g : insertGRE new_g old_gs plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt -- Used when the gre_name fields match plusGRE g1 g2 = GRE { gre_name = gre_name g1 , gre_lcl = gre_lcl g1 || gre_lcl g2 , gre_imp = gre_imp g1 ++ gre_imp g2 , gre_par = gre_par g1 `plusParent` gre_par g2 } transformGREs :: (GlobalRdrElt -> GlobalRdrElt) -> [OccName] -> GlobalRdrEnv -> GlobalRdrEnv -- ^ Apply a transformation function to the GREs for these OccNames transformGREs trans_gre occs rdr_env = foldr trans rdr_env occs where trans occ env = case lookupOccEnv env occ of Just gres -> extendOccEnv env occ (map trans_gre gres) Nothing -> env extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv extendGlobalRdrEnv env gre = extendOccEnv_Acc insertGRE singleton env (greOccName gre) gre shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv shadowNames = foldl' shadowName {- Note [GlobalRdrEnv shadowing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before adding new names to the GlobalRdrEnv we nuke some existing entries; this is "shadowing". The actual work is done by RdrEnv.shadowName. Suppose env' = shadowName env M.f Then: * Looking up (Unqual f) in env' should succeed, returning M.f, even if env contains existing unqualified bindings for f. They are shadowed * Looking up (Qual M.f) in env' should succeed, returning M.f * Looking up (Qual X.f) in env', where X /= M, should be the same as looking up (Qual X.f) in env. That is, shadowName does /not/ delete earlier qualified bindings There are two reasons for shadowing: * The GHCi REPL - Ids bought into scope on the command line (eg let x = True) have External Names, like Ghci4.x. We want a new binding for 'x' (say) to override the existing binding for 'x'. Example: ghci> :load M -- Brings `x` and `M.x` into scope ghci> x ghci> "Hello" ghci> M.x ghci> "hello" ghci> let x = True -- Shadows `x` ghci> x -- The locally bound `x` -- NOT an ambiguous reference ghci> True ghci> M.x -- M.x is still in scope! ghci> "Hello" So when we add `x = True` we must not delete the `M.x` from the `GlobalRdrEnv`; rather we just want to make it "qualified only"; hence the `mk_fake-imp_spec` in `shadowName`. See also Note [Interactively-bound Ids in GHCi] in HscTypes - Data types also have External Names, like Ghci4.T; but we still want 'T' to mean the newly-declared 'T', not an old one. * Nested Template Haskell declaration brackets See Note [Top-level Names in Template Haskell decl quotes] in RnNames Consider a TH decl quote: module M where f x = h [d| f = ...f...M.f... |] We must shadow the outer unqualified binding of 'f', else we'll get a complaint when extending the GlobalRdrEnv, saying that there are two bindings for 'f'. There are several tricky points: - This shadowing applies even if the binding for 'f' is in a where-clause, and hence is in the *local* RdrEnv not the *global* RdrEnv. This is done in lcl_env_TH in extendGlobalRdrEnvRn. - The External Name M.f from the enclosing module must certainly still be available. So we don't nuke it entirely; we just make it seem like qualified import. - We only shadow *External* names (which come from the main module), or from earlier GHCi commands. Do not shadow *Internal* names because in the bracket [d| class C a where f :: a f = 4 |] rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the class decl, and *separately* extend the envt with the value binding. At that stage, the class op 'f' will have an Internal name. -} shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv -- Remove certain old GREs that share the same OccName as this new Name. -- See Note [GlobalRdrEnv shadowing] for details shadowName env name = alterOccEnv (fmap alter_fn) env (nameOccName name) where alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt] alter_fn gres = mapMaybe (shadow_with name) gres shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt shadow_with new_name old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss }) = case nameModule_maybe old_name of Nothing -> Just old_gre -- Old name is Internal; do not shadow Just old_mod | Just new_mod <- nameModule_maybe new_name , new_mod == old_mod -- Old name same as new name; shadow completely -> Nothing | null iss' -- Nothing remains -> Nothing | otherwise -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) where iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss lcl_imp | lcl = [mk_fake_imp_spec old_name old_mod] | otherwise = [] mk_fake_imp_spec old_name old_mod -- Urgh! = ImpSpec id_spec ImpAll where old_mod_name = moduleName old_mod id_spec = ImpDeclSpec { is_mod = old_mod_name , is_as = old_mod_name , is_qual = True , is_dloc = nameSrcSpan old_name } shadow_is :: Name -> ImportSpec -> Maybe ImportSpec shadow_is new_name is@(ImpSpec { is_decl = id_spec }) | Just new_mod <- nameModule_maybe new_name , is_as id_spec == moduleName new_mod = Nothing -- Shadow both qualified and unqualified | otherwise -- Shadow unqualified only = Just (is { is_decl = id_spec { is_qual = True } }) {- ************************************************************************ * * ImportSpec * * ************************************************************************ -} -- | Import Specification -- -- The 'ImportSpec' of something says how it came to be imported -- It's quite elaborate so that we can give accurate unused-name warnings. data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, is_item :: ImpItemSpec } deriving( Eq, Ord, Data ) -- | Import Declaration Specification -- -- Describes a particular import declaration and is -- shared among all the 'Provenance's for that decl data ImpDeclSpec = ImpDeclSpec { is_mod :: ModuleName, -- ^ Module imported, e.g. @import Muggle@ -- Note the @Muggle@ may well not be -- the defining module for this thing! -- TODO: either should be Module, or there -- should be a Maybe UnitId here too. is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) is_qual :: Bool, -- ^ Was this import qualified? is_dloc :: SrcSpan -- ^ The location of the entire import declaration } deriving Data -- | Import Item Specification -- -- Describes import info a particular Name data ImpItemSpec = ImpAll -- ^ The import had no import list, -- or had a hiding list | ImpSome { is_explicit :: Bool, is_iloc :: SrcSpan -- Location of the import item } -- ^ The import had an import list. -- The 'is_explicit' field is @True@ iff the thing was named -- /explicitly/ in the import specs rather -- than being imported as part of a "..." group. Consider: -- -- > import C( T(..) ) -- -- Here the constructors of @T@ are not named explicitly; -- only @T@ is named explicitly. deriving Data instance Eq ImpDeclSpec where p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False instance Ord ImpDeclSpec where compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp` (is_dloc is1 `compare` is_dloc is2) instance Eq ImpItemSpec where p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False instance Ord ImpItemSpec where compare is1 is2 = case (is1, is2) of (ImpAll, ImpAll) -> EQ (ImpAll, _) -> GT (_, ImpAll) -> LT (ImpSome _ l1, ImpSome _ l2) -> l1 `compare` l2 bestImport :: [ImportSpec] -> ImportSpec -- See Note [Choosing the best import declaration] bestImport iss = case sortBy best iss of (is:_) -> is [] -> pprPanic "bestImport" (ppr iss) where best :: ImportSpec -> ImportSpec -> Ordering -- Less means better -- Unqualified always wins over qualified; then -- import-all wins over import-some; then -- earlier declaration wins over later best (ImpSpec { is_item = item1, is_decl = d1 }) (ImpSpec { is_item = item2, is_decl = d2 }) = (is_qual d1 `compare` is_qual d2) `thenCmp` (best_item item1 item2) `thenCmp` (is_dloc d1 `compare` is_dloc d2) best_item :: ImpItemSpec -> ImpItemSpec -> Ordering best_item ImpAll ImpAll = EQ best_item ImpAll (ImpSome {}) = LT best_item (ImpSome {}) ImpAll = GT best_item (ImpSome { is_explicit = e1 }) (ImpSome { is_explicit = e2 }) = e1 `compare` e2 -- False < True, so if e1 is explicit and e2 is not, we get GT {- Note [Choosing the best import declaration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When reporting unused import declarations we use the following rules. (see [wiki:commentary/compiler/unused-imports]) Say that an import-item is either * an entire import-all decl (eg import Foo), or * a particular item in an import list (eg import Foo( ..., x, ...)). The general idea is that for each /occurrence/ of an imported name, we will attribute that use to one import-item. Once we have processed all the occurrences, any import items with no uses attributed to them are unused, and are warned about. More precisely: 1. For every RdrName in the program text, find its GlobalRdrElt. 2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one the "chosen import-item", and mark it "used". This is done by 'bestImport' 3. After processing all the RdrNames, bleat about any import-items that are unused. This is done in RnNames.warnUnusedImportDecls. The function 'bestImport' returns the dominant import among the ImportSpecs it is given, implementing Step 2. We say import-item A dominates import-item B if we choose A over B. In general, we try to choose the import that is most likely to render other imports unnecessary. Here is the dominance relationship we choose: a) import Foo dominates import qualified Foo. b) import Foo dominates import Foo(x). c) Otherwise choose the textually first one. Rationale for (a). Consider import qualified M -- Import #1 import M( x ) -- Import #2 foo = M.x + x The unqualified 'x' can only come from import #2. The qualified 'M.x' could come from either, but bestImport picks import #2, because it is more likely to be useful in other imports, as indeed it is in this case (see #5211 for a concrete example). But the rules are not perfect; consider import qualified M -- Import #1 import M( x ) -- Import #2 foo = M.x + M.y The M.x will use import #2, but M.y can only use import #1. -} unQualSpecOK :: ImportSpec -> Bool -- ^ Is in scope unqualified? unQualSpecOK is = not (is_qual (is_decl is)) qualSpecOK :: ModuleName -> ImportSpec -> Bool -- ^ Is in scope qualified with the given module? qualSpecOK mod is = mod == is_as (is_decl is) importSpecLoc :: ImportSpec -> SrcSpan importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl importSpecLoc (ImpSpec _ item) = is_iloc item importSpecModule :: ImportSpec -> ModuleName importSpecModule is = is_mod (is_decl is) isExplicitItem :: ImpItemSpec -> Bool isExplicitItem ImpAll = False isExplicitItem (ImpSome {is_explicit = exp}) = exp pprNameProvenance :: GlobalRdrElt -> SDoc -- ^ Print out one place where the name was define/imported -- (With -dppr-debug, print them all) pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) = ifPprDebug (vcat pp_provs) (head pp_provs) where pp_provs = pp_lcl ++ map pp_is iss pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] else [] pp_is is = sep [ppr is, ppr_defn_site is name] -- If we know the exact definition point (which we may do with GHCi) -- then show that too. But not if it's just "imported from X". ppr_defn_site :: ImportSpec -> Name -> SDoc ppr_defn_site imp_spec name | same_module && not (isGoodSrcSpan loc) = empty -- Nothing interesting to say | otherwise = parens $ hang (text "and originally defined" <+> pp_mod) 2 (pprLoc loc) where loc = nameSrcSpan name defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name same_module = importSpecModule imp_spec == moduleName defining_mod pp_mod | same_module = empty | otherwise = text "in" <+> quotes (ppr defining_mod) instance Outputable ImportSpec where ppr imp_spec = text "imported" <+> qual <+> text "from" <+> quotes (ppr (importSpecModule imp_spec)) <+> pprLoc (importSpecLoc imp_spec) where qual | is_qual (is_decl imp_spec) = text "qualified" | otherwise = empty pprLoc :: SrcSpan -> SDoc pprLoc (RealSrcSpan s) = text "at" <+> ppr s pprLoc (UnhelpfulSpan {}) = empty -- | Display info about the treatment of '*' under NoStarIsType. -- -- With StarIsType, three properties of '*' hold: -- -- (a) it is not an infix operator -- (b) it is always in scope -- (c) it is a synonym for Data.Kind.Type -- -- However, the user might not know that he's working on a module with -- NoStarIsType and write code that still assumes (a), (b), and (c), which -- actually do not hold in that module. -- -- Violation of (a) shows up in the parser. For instance, in the following -- examples, we have '*' not applied to enough arguments: -- -- data A :: * -- data F :: * -> * -- -- Violation of (b) or (c) show up in the renamer and the typechecker -- respectively. For instance: -- -- type K = Either * Bool -- -- This will parse differently depending on whether StarIsType is enabled, -- but it will parse nonetheless. With NoStarIsType it is parsed as a type -- operator, thus we have ((*) Either Bool). Now there are two cases to -- consider: -- -- 1. There is no definition of (*) in scope. In this case the renamer will -- fail to look it up. This is a violation of assumption (b). -- -- 2. There is a definition of the (*) type operator in scope (for example -- coming from GHC.TypeNats). In this case the user will get a kind -- mismatch error. This is a violation of assumption (c). -- -- The user might unknowingly be working on a module with NoStarIsType -- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a -- hint whenever an assumption about '*' is violated. Unfortunately, it is -- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b). -- -- 'starInfo' generates an appropriate hint to the user depending on the -- extensions enabled in the module and the name that triggered the error. -- That is, if we have NoStarIsType and the error is related to '*' or its -- Unicode variant, the resulting SDoc will contain a helpful suggestion. -- Otherwise it is empty. -- starInfo :: Bool -> RdrName -> SDoc starInfo star_is_type rdr_name = -- One might ask: if can use sdocWithDynFlags here, why bother to take -- star_is_type as input? Why not refactor? -- -- The reason is that sdocWithDynFlags would provide DynFlags that are active -- in the module that tries to load the problematic definition, not -- in the module that is being loaded. -- -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint -- must be displayed even if we load this definition from a module (or GHCi) -- with StarIsType enabled! -- if isUnqualStar && not star_is_type then text "With NoStarIsType, " <> quotes (ppr rdr_name) <> text " is treated as a regular type operator. " $$ text "Did you mean to use " <> quotes (text "Type") <> text " from Data.Kind instead?" else empty where -- Does rdr_name look like the user might have meant the '*' kind by it? -- We focus on unqualified stars specifically, because qualified stars are -- treated as type operators even under StarIsType. isUnqualStar | Unqual occName <- rdr_name = let fs = occNameFS occName in fs == fsLit "*" || fs == fsLit "★" | otherwise = False ghc-lib-parser-8.10.2.20200808/compiler/simplStg/RepType.hs0000644000000000000000000004675713713635745021072 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} module RepType ( -- * Code generator views onto Types UnaryType, NvUnaryType, isNvUnaryType, unwrapType, -- * Predicates on types isVoidTy, -- * Type representation for the code generator typePrimRep, typePrimRep1, runtimeRepPrimRep, typePrimRepArgs, PrimRep(..), primRepToType, countFunRepArgs, countConRepArgs, tyConPrimRep, tyConPrimRep1, -- * Unboxed sum representation type ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..), slotPrimRep, primRepSlot ) where #include "GhclibHsVersions.h" import GhcPrelude import BasicTypes (Arity, RepArity) import DataCon import Outputable import PrelNames import Coercion import TyCon import TyCoRep import Type import Util import TysPrim import {-# SOURCE #-} TysWiredIn ( anyTypeOfKind ) import Data.List (sort) import qualified Data.IntSet as IS {- ********************************************************************** * * Representation types * * ********************************************************************** -} type NvUnaryType = Type type UnaryType = Type -- Both are always a value type; i.e. its kind is TYPE rr -- for some rr; moreover the rr is never a variable. -- -- NvUnaryType : never an unboxed tuple or sum, or void -- -- UnaryType : never an unboxed tuple or sum; -- can be Void# or (# #) isNvUnaryType :: Type -> Bool isNvUnaryType ty | [_] <- typePrimRep ty = True | otherwise = False -- INVARIANT: the result list is never empty. typePrimRepArgs :: HasDebugCallStack => Type -> [PrimRep] typePrimRepArgs ty | [] <- reps = [VoidRep] | otherwise = reps where reps = typePrimRep ty -- | Gets rid of the stuff that prevents us from understanding the -- runtime representation of a type. Including: -- 1. Casts -- 2. Newtypes -- 3. Foralls -- 4. Synonyms -- But not type/data families, because we don't have the envs to hand. unwrapType :: Type -> Type unwrapType ty | Just (_, unwrapped) <- topNormaliseTypeX stepper mappend inner_ty = unwrapped | otherwise = inner_ty where inner_ty = go ty go t | Just t' <- coreView t = go t' go (ForAllTy _ t) = go t go (CastTy t _) = go t go t = t -- cf. Coercion.unwrapNewTypeStepper stepper rec_nts tc tys | Just (ty', _) <- instNewTyCon_maybe tc tys = case checkRecTc rec_nts tc of Just rec_nts' -> NS_Step rec_nts' (go ty') () Nothing -> NS_Abort -- infinite newtypes | otherwise = NS_Done countFunRepArgs :: Arity -> Type -> RepArity countFunRepArgs 0 _ = 0 countFunRepArgs n ty | FunTy _ arg res <- unwrapType ty = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res | otherwise = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) countConRepArgs :: DataCon -> RepArity countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc) where go :: Arity -> Type -> RepArity go 0 _ = 0 go n ty | FunTy _ arg res <- unwrapType ty = length (typePrimRep arg) + go (n - 1) res | otherwise = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) -- | True if the type has zero width. isVoidTy :: Type -> Bool isVoidTy = null . typePrimRep {- ********************************************************************** * * Unboxed sums See Note [Translating unboxed sums to unboxed tuples] in UnariseStg.hs * * ********************************************************************** -} type SortedSlotTys = [SlotTy] -- | Given the arguments of a sum type constructor application, -- return the unboxed sum rep type. -- -- E.g. -- -- (# Int# | Maybe Int | (# Int#, Float# #) #) -- -- We call `ubxSumRepType [ [IntRep], [LiftedRep], [IntRep, FloatRep] ]`, -- which returns [WordSlot, PtrSlot, WordSlot, FloatSlot] -- -- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head -- of the list we have the slot for the tag. ubxSumRepType :: [[PrimRep]] -> [SlotTy] ubxSumRepType constrs0 -- These first two cases never classify an actual unboxed sum, which always -- has at least two disjuncts. But it could happen if a user writes, e.g., -- forall (a :: TYPE (SumRep [IntRep])). ... -- which could never be instantiated. We still don't want to panic. | constrs0 `lengthLessThan` 2 = [WordSlot] | otherwise = let combine_alts :: [SortedSlotTys] -- slots of constructors -> SortedSlotTys -- final slots combine_alts constrs = foldl' merge [] constrs merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys merge existing_slots [] = existing_slots merge [] needed_slots = needed_slots merge (es : ess) (s : ss) | Just s' <- s `fitsIn` es = -- found a slot, use it s' : merge ess ss | s < es = -- we need a new slot and this is the right place for it s : merge (es : ess) ss | otherwise = -- keep searching for a slot es : merge ess (s : ss) -- Nesting unboxed tuples and sums is OK, so we need to flatten first. rep :: [PrimRep] -> SortedSlotTys rep ty = sort (map primRepSlot ty) sumRep = WordSlot : combine_alts (map rep constrs0) -- WordSlot: for the tag of the sum in sumRep layoutUbxSum :: SortedSlotTys -- Layout of sum. Does not include tag. -- We assume that they are in increasing order -> [SlotTy] -- Slot types of things we want to map to locations in the -- sum layout -> [Int] -- Where to map 'things' in the sum layout layoutUbxSum sum_slots0 arg_slots0 = go arg_slots0 IS.empty where go :: [SlotTy] -> IS.IntSet -> [Int] go [] _ = [] go (arg : args) used = let slot_idx = findSlot arg 0 sum_slots0 used in slot_idx : go args (IS.insert slot_idx used) findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int findSlot arg slot_idx (slot : slots) useds | not (IS.member slot_idx useds) , Just slot == arg `fitsIn` slot = slot_idx | otherwise = findSlot arg (slot_idx + 1) slots useds findSlot _ _ [] _ = pprPanic "findSlot" (text "Can't find slot" $$ ppr sum_slots0 $$ ppr arg_slots0) -------------------------------------------------------------------------------- -- We have 3 kinds of slots: -- -- - Pointer slot: Only shared between actual pointers to Haskell heap (i.e. -- boxed objects) -- -- - Word slots: Shared between IntRep, WordRep, Int64Rep, Word64Rep, AddrRep. -- -- - Float slots: Shared between floating point types. -- -- - Void slots: Shared between void types. Not used in sums. -- -- TODO(michalt): We should probably introduce `SlotTy`s for 8-/16-/32-bit -- values, so that we can pack things more tightly. data SlotTy = PtrSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot deriving (Eq, Ord) -- Constructor order is important! If slot A could fit into slot B -- then slot A must occur first. E.g. FloatSlot before DoubleSlot -- -- We are assuming that WordSlot is smaller than or equal to Word64Slot -- (would not be true on a 128-bit machine) instance Outputable SlotTy where ppr PtrSlot = text "PtrSlot" ppr Word64Slot = text "Word64Slot" ppr WordSlot = text "WordSlot" ppr DoubleSlot = text "DoubleSlot" ppr FloatSlot = text "FloatSlot" typeSlotTy :: UnaryType -> Maybe SlotTy typeSlotTy ty | isVoidTy ty = Nothing | otherwise = Just (primRepSlot (typePrimRep1 ty)) primRepSlot :: PrimRep -> SlotTy primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") primRepSlot LiftedRep = PtrSlot primRepSlot UnliftedRep = PtrSlot primRepSlot IntRep = WordSlot primRepSlot Int8Rep = WordSlot primRepSlot Int16Rep = WordSlot primRepSlot Int32Rep = WordSlot primRepSlot Int64Rep = Word64Slot primRepSlot WordRep = WordSlot primRepSlot Word8Rep = WordSlot primRepSlot Word16Rep = WordSlot primRepSlot Word32Rep = WordSlot primRepSlot Word64Rep = Word64Slot primRepSlot AddrRep = WordSlot primRepSlot FloatRep = FloatSlot primRepSlot DoubleRep = DoubleSlot primRepSlot VecRep{} = pprPanic "primRepSlot" (text "No slot for VecRep") slotPrimRep :: SlotTy -> PrimRep slotPrimRep PtrSlot = LiftedRep -- choice between lifted & unlifted seems arbitrary slotPrimRep Word64Slot = Word64Rep slotPrimRep WordSlot = WordRep slotPrimRep DoubleSlot = DoubleRep slotPrimRep FloatSlot = FloatRep -- | Returns the bigger type if one fits into the other. (commutative) fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy fitsIn ty1 ty2 | isWordSlot ty1 && isWordSlot ty2 = Just (max ty1 ty2) | isFloatSlot ty1 && isFloatSlot ty2 = Just (max ty1 ty2) | isPtrSlot ty1 && isPtrSlot ty2 = Just PtrSlot | otherwise = Nothing where isPtrSlot PtrSlot = True isPtrSlot _ = False isWordSlot Word64Slot = True isWordSlot WordSlot = True isWordSlot _ = False isFloatSlot DoubleSlot = True isFloatSlot FloatSlot = True isFloatSlot _ = False {- ********************************************************************** * * PrimRep * * ************************************************************************* Note [RuntimeRep and PrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This Note describes the relationship between GHC.Types.RuntimeRep (of levity-polymorphism fame) and TyCon.PrimRep, as these types are closely related. A "primitive entity" is one that can be * stored in one register * manipulated with one machine instruction Examples include: * a 32-bit integer * a 32-bit float * a 64-bit float * a machine address (heap pointer), etc. * a quad-float (on a machine with SIMD register and instructions) * ...etc... The "representation or a primitive entity" specifies what kind of register is needed and how many bits are required. The data type TyCon.PrimRep enumerates all the possiblities. data PrimRep = VoidRep | LiftedRep -- ^ Lifted pointer | UnliftedRep -- ^ Unlifted pointer | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value ...etc... | VecRep Int PrimElemRep -- ^ SIMD fixed-width vector The Haskell source language is a bit more flexible: a single value may need multiple PrimReps. For example utup :: (# Int, Int #) -> Bool utup x = ... Here x :: (# Int, Int #), and that takes two registers, and two instructions to move around. Unboxed sums are similar. Every Haskell expression e has a type ty, whose kind is of form TYPE rep e :: ty :: TYPE rep where rep :: RuntimeRep. Here rep describes the runtime representation for e's value, but RuntimeRep has some extra cases: data RuntimeRep = VecRep VecCount VecElem -- ^ a SIMD vector type | TupleRep [RuntimeRep] -- ^ An unboxed tuple of the given reps | SumRep [RuntimeRep] -- ^ An unboxed sum of the given reps | LiftedRep -- ^ lifted; represented by a pointer | UnliftedRep -- ^ unlifted; represented by a pointer | IntRep -- ^ signed, word-sized value ...etc... It's all in 1-1 correspondence with PrimRep except for TupleRep and SumRep, which describe unboxed products and sums respectively. RuntimeRep is defined in the library ghc-prim:GHC.Types. It is also "wired-in" to GHC: see TysWiredIn.runtimeRepTyCon. The unarisation pass, in StgUnarise, transforms the program, so that that every variable has a type that has a PrimRep. For example, unarisation transforms our utup function above, to take two Int arguments instead of one (# Int, Int #) argument. See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep]. Note [VoidRep] ~~~~~~~~~~~~~~ PrimRep contains a constructor VoidRep, while RuntimeRep does not. Yet representations are often characterised by a list of PrimReps, where a void would be denoted as []. (See also Note [RuntimeRep and PrimRep].) However, after the unariser, all identifiers have exactly one PrimRep, but void arguments still exist. Thus, PrimRep includes VoidRep to describe these binders. Perhaps post-unariser representations (which need VoidRep) should be a different type than pre-unariser representations (which use a list and do not need VoidRep), but we have what we have. RuntimeRep instead uses TupleRep '[] to denote a void argument. When converting a TupleRep '[] into a list of PrimReps, we get an empty list. Note [Getting from RuntimeRep to PrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ General info on RuntimeRep and PrimRep is in Note [RuntimeRep and PrimRep]. How do we get from an Id to the the list or PrimReps used to store it? We get the Id's type ty (using idType), then ty's kind ki (using typeKind), then pattern-match on ki to extract rep (in kindPrimRep), then extract the PrimRep from the RuntimeRep (in runtimeRepPrimRep). We now must convert the RuntimeRep to a list of PrimReps. Let's look at two examples: 1. x :: Int# 2. y :: (# Int, Word# #) With these types, we can extract these kinds: 1. Int# :: TYPE IntRep 2. (# Int, Word# #) :: TYPE (TupleRep [LiftedRep, WordRep]) In the end, we will get these PrimReps: 1. [IntRep] 2. [LiftedRep, WordRep] It would thus seem that we should have a function somewhere of type `RuntimeRep -> [PrimRep]`. This doesn't work though: when we look at the argument of TYPE, we get something of type Type (of course). RuntimeRep exists in the user's program, but not in GHC as such. Instead, we must decompose the Type of kind RuntimeRep into tycons and extract the PrimReps from the TyCons. This is what runtimeRepPrimRep does: it takes a Type and returns a [PrimRep] runtimeRepPrimRep works by using tyConRuntimeRepInfo. That function should be passed the TyCon produced by promoting one of the constructors of RuntimeRep into type-level data. The RuntimeRep promoted datacons are associated with a RuntimeRepInfo (stored directly in the PromotedDataCon constructor of TyCon). This pairing happens in TysWiredIn. A RuntimeRepInfo usually(*) contains a function from [Type] to [PrimRep]: the [Type] are the arguments to the promoted datacon. These arguments are necessary for the TupleRep and SumRep constructors, so that this process can recur, producing a flattened list of PrimReps. Calling this extracted function happens in runtimeRepPrimRep; the functions themselves are defined in tupleRepDataCon and sumRepDataCon, both in TysWiredIn. The (*) above is to support vector representations. RuntimeRep refers to VecCount and VecElem, whose promoted datacons have nuggets of information related to vectors; these form the other alternatives for RuntimeRepInfo. Returning to our examples, the Types we get (after stripping off TYPE) are 1. TyConApp (PromotedDataCon "IntRep") [] 2. TyConApp (PromotedDataCon "TupleRep") [TyConApp (PromotedDataCon ":") [ TyConApp (AlgTyCon "RuntimeRep") [] , TyConApp (PromotedDataCon "LiftedRep") [] , TyConApp (PromotedDataCon ":") [ TyConApp (AlgTyCon "RuntimeRep") [] , TyConApp (PromotedDataCon "WordRep") [] , TyConApp (PromotedDataCon "'[]") [TyConApp (AlgTyCon "RuntimeRep") []]]]] runtimeRepPrimRep calls tyConRuntimeRepInfo on (PromotedDataCon "IntRep"), resp. (PromotedDataCon "TupleRep"), extracting a function that will produce the PrimReps. In example 1, this function is passed an empty list (the empty list of args to IntRep) and returns the PrimRep IntRep. (See the definition of runtimeRepSimpleDataCons in TysWiredIn and its helper function mk_runtime_rep_dc.) Example 2 passes the promoted list as the one argument to the extracted function. The extracted function is defined as prim_rep_fun within tupleRepDataCon in TysWiredIn. It takes one argument, decomposes the promoted list (with extractPromotedList), and then recurs back to runtimeRepPrimRep to process the LiftedRep and WordRep, concatentating the results. -} -- | Discovers the primitive representation of a 'Type'. Returns -- a list of 'PrimRep': it's a list because of the possibility of -- no runtime representation (void) or multiple (unboxed tuple/sum) -- See also Note [Getting from RuntimeRep to PrimRep] typePrimRep :: HasDebugCallStack => Type -> [PrimRep] typePrimRep ty = kindPrimRep (text "typePrimRep" <+> parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) (typeKind ty) -- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output; -- an empty list of PrimReps becomes a VoidRep. -- This assumption holds after unarise, see Note [Post-unarisation invariants]. -- Before unarise it may or may not hold. -- See also Note [RuntimeRep and PrimRep] and Note [VoidRep] typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep typePrimRep1 ty = case typePrimRep ty of [] -> VoidRep [rep] -> rep _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) -- | Find the runtime representation of a 'TyCon'. Defined here to -- avoid module loops. Returns a list of the register shapes necessary. -- See also Note [Getting from RuntimeRep to PrimRep] tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep] tyConPrimRep tc = kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind) res_kind where res_kind = tyConResKind tc -- | Like 'tyConPrimRep', but assumed that there is precisely zero or -- one 'PrimRep' output -- See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep] tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep tyConPrimRep1 tc = case tyConPrimRep tc of [] -> VoidRep [rep] -> rep _ -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc)) -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's -- of values of types of this kind. -- See also Note [Getting from RuntimeRep to PrimRep] kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] kindPrimRep doc ki | Just ki' <- coreView ki = kindPrimRep doc ki' kindPrimRep doc (TyConApp typ [runtime_rep]) = ASSERT( typ `hasKey` tYPETyConKey ) runtimeRepPrimRep doc runtime_rep kindPrimRep doc ki = pprPanic "kindPrimRep" (ppr ki $$ doc) -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep] runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep] runtimeRepPrimRep doc rr_ty | Just rr_ty' <- coreView rr_ty = runtimeRepPrimRep doc rr_ty' | TyConApp rr_dc args <- rr_ty , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc = fun args | otherwise = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty) -- | Convert a PrimRep back to a Type. Used only in the unariser to give types -- to fresh Ids. Really, only the type's representation matters. -- See also Note [RuntimeRep and PrimRep] primRepToType :: PrimRep -> Type primRepToType = anyTypeOfKind . tYPE . primRepToRuntimeRep ghc-lib-parser-8.10.2.20200808/compiler/specialise/Rules.hs0000644000000000000000000014167413713635745021105 0ustar0000000000000000{- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[CoreRules]{Transformation rules} -} {-# LANGUAGE CPP #-} -- | Functions for collecting together and applying rewrite rules to a module. -- The 'CoreRule' datatype itself is declared elsewhere. module Rules ( -- ** Constructing emptyRuleBase, mkRuleBase, extendRuleBaseList, unionRuleBase, pprRuleBase, -- ** Checking rule applications ruleCheckProgram, -- ** Manipulating 'RuleInfo' rules mkRuleInfo, extendRuleInfo, addRuleInfo, addIdSpecialisations, -- * Misc. CoreRule helpers rulesOfBinds, getRules, pprRulesForUser, lookupRule, mkRule, roughTopNames ) where #include "GhclibHsVersions.h" import GhcPrelude import CoreSyn -- All of it import Module ( Module, ModuleSet, elemModuleSet ) import CoreSubst import CoreOpt ( exprIsLambda_maybe ) import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList ) import CoreUtils ( exprType, eqExpr, mkTick, mkTicks, stripTicksTopT, stripTicksTopE, isJoinBind ) import PprCore ( pprRules ) import Type ( Type, TCvSubst, extendTvSubst, extendCvSubst , mkEmptyTCvSubst, substTy ) import TcType ( tcSplitTyConApp_maybe ) import TysWiredIn ( anyTypeOfKind ) import Coercion import CoreTidy ( tidyRules ) import Id import IdInfo ( RuleInfo( RuleInfo ) ) import Var import VarEnv import VarSet import Name ( Name, NamedThing(..), nameIsLocalOrFrom ) import NameSet import NameEnv import UniqFM import Unify ( ruleMatchTyKiX ) import BasicTypes import DynFlags ( DynFlags ) import Outputable import FastString import Maybes import Bag import Util import Data.List import Data.Ord import Control.Monad ( guard ) {- Note [Overall plumbing for rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * After the desugarer: - The ModGuts initially contains mg_rules :: [CoreRule] of locally-declared rules for imported Ids. - Locally-declared rules for locally-declared Ids are attached to the IdInfo for that Id. See Note [Attach rules to local ids] in DsBinds * TidyPgm strips off all the rules from local Ids and adds them to mg_rules, so that the ModGuts has *all* the locally-declared rules. * The HomePackageTable contains a ModDetails for each home package module. Each contains md_rules :: [CoreRule] of rules declared in that module. The HomePackageTable grows as ghc --make does its up-sweep. In batch mode (ghc -c), the HPT is empty; all imported modules are treated by the "external" route, discussed next, regardless of which package they come from. * The ExternalPackageState has a single eps_rule_base :: RuleBase for Ids in other packages. This RuleBase simply grow monotonically, as ghc --make compiles one module after another. During simplification, interface files may get demand-loaded, as the simplifier explores the unfoldings for Ids it has in its hand. (Via an unsafePerformIO; the EPS is really a cache.) That in turn may make the EPS rule-base grow. In contrast, the HPT never grows in this way. * The result of all this is that during Core-to-Core optimisation there are four sources of rules: (a) Rules in the IdInfo of the Id they are a rule for. These are easy: fast to look up, and if you apply a substitution then it'll be applied to the IdInfo as a matter of course. (b) Rules declared in this module for imported Ids, kept in the ModGuts. If you do a substitution, you'd better apply the substitution to these. There are seldom many of these. (c) Rules declared in the HomePackageTable. These never change. (d) Rules in the ExternalPackageTable. These can grow in response to lazy demand-loading of interfaces. * At the moment (c) is carried in a reader-monad way by the CoreMonad. The HomePackageTable doesn't have a single RuleBase because technically we should only be able to "see" rules "below" this module; so we generate a RuleBase for (c) by combing rules from all the modules "below" us. That's why we can't just select the home-package RuleBase from HscEnv. [NB: we are inconsistent here. We should do the same for external packages, but we don't. Same for type-class instances.] * So in the outer simplifier loop, we combine (b-d) into a single RuleBase, reading (b) from the ModGuts, (c) from the CoreMonad, and (d) from its mutable variable [Of coures this means that we won't see new EPS rules that come in during a single simplifier iteration, but that probably does not matter.] ************************************************************************ * * \subsection[specialisation-IdInfo]{Specialisation info about an @Id@} * * ************************************************************************ A @CoreRule@ holds details of one rule for an @Id@, which includes its specialisations. For example, if a rule for @f@ contains the mapping: \begin{verbatim} forall a b d. [Type (List a), Type b, Var d] ===> f' a b \end{verbatim} then when we find an application of f to matching types, we simply replace it by the matching RHS: \begin{verbatim} f (List Int) Bool dict ===> f' Int Bool \end{verbatim} All the stuff about how many dictionaries to discard, and what types to apply the specialised function to, are handled by the fact that the Rule contains a template for the result of the specialisation. There is one more exciting case, which is dealt with in exactly the same way. If the specialised value is unboxed then it is lifted at its definition site and unlifted at its uses. For example: pi :: forall a. Num a => a might have a specialisation [Int#] ===> (case pi' of Lift pi# -> pi#) where pi' :: Lift Int# is the specialised version of pi. -} mkRule :: Module -> Bool -> Bool -> RuleName -> Activation -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being -- compiled. See also 'CoreSyn.CoreRule' mkRule this_mod is_auto is_local name act fn bndrs args rhs = Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs, ru_rough = roughTopNames args, ru_origin = this_mod, ru_orphan = orph, ru_auto = is_auto, ru_local = is_local } where -- Compute orphanhood. See Note [Orphans] in InstEnv -- A rule is an orphan only if none of the variables -- mentioned on its left-hand side are locally defined lhs_names = extendNameSet (exprsOrphNames args) fn -- Since rules get eventually attached to one of the free names -- from the definition when compiling the ABI hash, we should make -- it deterministic. This chooses the one with minimal OccName -- as opposed to uniq value. local_lhs_names = filterNameSet (nameIsLocalOrFrom this_mod) lhs_names orph = chooseOrphanAnchor local_lhs_names -------------- roughTopNames :: [CoreExpr] -> [Maybe Name] -- ^ Find the \"top\" free names of several expressions. -- Such names are either: -- -- 1. The function finally being applied to in an application chain -- (if that name is a GlobalId: see "Var#globalvslocal"), or -- -- 2. The 'TyCon' if the expression is a 'Type' -- -- This is used for the fast-match-check for rules; -- if the top names don't match, the rest can't roughTopNames args = map roughTopName args roughTopName :: CoreExpr -> Maybe Name roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of Just (tc,_) -> Just (getName tc) Nothing -> Nothing roughTopName (Coercion _) = Nothing roughTopName (App f _) = roughTopName f roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName] , isDataConWorkId f || idArity f > 0 = Just (idName f) roughTopName (Tick t e) | tickishFloatable t = roughTopName e roughTopName _ = Nothing ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool -- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ -- definitely can't match @tpl@ by instantiating @tpl@. -- It's only a one-way match; unlike instance matching we -- don't consider unification. -- -- Notice that [_$_] -- @ruleCantMatch [Nothing] [Just n2] = False@ -- Reason: a template variable can be instantiated by a constant -- Also: -- @ruleCantMatch [Just n1] [Nothing] = False@ -- Reason: a local variable @v@ in the actuals might [_$_] ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as ruleCantMatch _ _ = False {- Note [Care with roughTopName] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this module M where { x = a:b } module N where { ...f x... RULE f (p:q) = ... } You'd expect the rule to match, because the matcher can look through the unfolding of 'x'. So we must avoid roughTopName returning 'M.x' for the call (f x), or else it'll say "can't match" and we won't even try!! However, suppose we have RULE g (M.h x) = ... foo = ...(g (M.k v)).... where k is a *function* exported by M. We never really match functions (lambdas) except by name, so in this case it seems like a good idea to treat 'M.k' as a roughTopName of the call. -} pprRulesForUser :: DynFlags -> [CoreRule] -> SDoc -- (a) tidy the rules -- (b) sort them into order based on the rule name -- (c) suppress uniques (unless -dppr-debug is on) -- This combination makes the output stable so we can use in testing -- It's here rather than in PprCore because it calls tidyRules pprRulesForUser dflags rules = withPprStyle (defaultUserStyle dflags) $ pprRules $ sortBy (comparing ruleName) $ tidyRules emptyTidyEnv rules {- ************************************************************************ * * RuleInfo: the rules in an IdInfo * * ************************************************************************ -} -- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable -- for putting into an 'IdInfo' mkRuleInfo :: [CoreRule] -> RuleInfo mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules) extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo extendRuleInfo (RuleInfo rs1 fvs1) rs2 = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1) addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2) = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2) addIdSpecialisations :: Id -> [CoreRule] -> Id addIdSpecialisations id rules | null rules = id | otherwise = setIdSpecialisation id $ extendRuleInfo (idSpecialisation id) rules -- | Gather all the rules for locally bound identifiers from the supplied bindings rulesOfBinds :: [CoreBind] -> [CoreRule] rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds getRules :: RuleEnv -> Id -> [CoreRule] -- See Note [Where rules are found] getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn = idCoreRules fn ++ filter (ruleIsVisible orphs) imp_rules where imp_rules = lookupNameEnv rule_base (idName fn) `orElse` [] ruleIsVisible :: ModuleSet -> CoreRule -> Bool ruleIsVisible _ BuiltinRule{} = True ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin } = notOrphan orph || origin `elemModuleSet` vis_orphs {- Note [Where rules are found] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The rules for an Id come from two places: (a) the ones it is born with, stored inside the Id iself (idCoreRules fn), (b) rules added in other modules, stored in the global RuleBase (imp_rules) It's tempting to think that - LocalIds have only (a) - non-LocalIds have only (b) but that isn't quite right: - PrimOps and ClassOps are born with a bunch of rules inside the Id, even when they are imported - The rules in PrelRules.builtinRules should be active even in the module defining the Id (when it's a LocalId), but the rules are kept in the global RuleBase ************************************************************************ * * RuleBase * * ************************************************************************ -} -- RuleBase itself is defined in CoreSyn, along with CoreRule emptyRuleBase :: RuleBase emptyRuleBase = emptyNameEnv mkRuleBase :: [CoreRule] -> RuleBase mkRuleBase rules = extendRuleBaseList emptyRuleBase rules extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase extendRuleBaseList rule_base new_guys = foldl' extendRuleBase rule_base new_guys unionRuleBase :: RuleBase -> RuleBase -> RuleBase unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2 extendRuleBase :: RuleBase -> CoreRule -> RuleBase extendRuleBase rule_base rule = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule pprRuleBase :: RuleBase -> SDoc pprRuleBase rules = pprUFM rules $ \rss -> vcat [ pprRules (tidyRules emptyTidyEnv rs) | rs <- rss ] {- ************************************************************************ * * Matching * * ************************************************************************ -} -- | The main rule matching function. Attempts to apply all (active) -- supplied rules to this instance of an application in a given -- context, returning the rule applied and the resulting expression if -- successful. lookupRule :: DynFlags -> InScopeEnv -> (Activation -> Bool) -- When rule is active -> Id -> [CoreExpr] -> [CoreRule] -> Maybe (CoreRule, CoreExpr) -- See Note [Extra args in rule matching] -- See comments on matchRule lookupRule dflags in_scope is_active fn args rules = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $ case go [] rules of [] -> Nothing (m:ms) -> Just (findBest (fn,args') m ms) where rough_args = map roughTopName args -- Strip ticks from arguments, see note [Tick annotations in RULE -- matching]. We only collect ticks if a rule actually matches - -- this matters for performance tests. args' = map (stripTicksTopE tickishFloatable) args ticks = concatMap (stripTicksTopT tickishFloatable) args go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] go ms [] = ms go ms (r:rs) | Just e <- matchRule dflags in_scope is_active fn args' rough_args r = go ((r,mkTicks ticks e):ms) rs | otherwise = -- pprTrace "match failed" (ppr r $$ ppr args $$ -- ppr [ (arg_id, unfoldingTemplate unf) -- | Var arg_id <- args -- , let unf = idUnfolding arg_id -- , isCheapUnfolding unf] ) go ms rs findBest :: (Id, [CoreExpr]) -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) -- All these pairs matched the expression -- Return the pair the most specific rule -- The (fn,args) is just for overlap reporting findBest _ (rule,ans) [] = (rule,ans) findBest target (rule1,ans1) ((rule2,ans2):prs) | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs | debugIsOn = let pp_rule rule = ifPprDebug (ppr rule) (doubleQuotes (ftext (ruleName rule))) in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" (vcat [ whenPprDebug $ text "Expression to match:" <+> ppr fn <+> sep (map ppr args) , text "Rule 1:" <+> pp_rule rule1 , text "Rule 2:" <+> pp_rule rule2]) $ findBest target (rule1,ans1) prs | otherwise = findBest target (rule1,ans1) prs where (fn,args) = target isMoreSpecific :: CoreRule -> CoreRule -> Bool -- This tests if one rule is more specific than another -- We take the view that a BuiltinRule is less specific than -- anything else, because we want user-define rules to "win" -- In particular, class ops have a built-in rule, but we -- any user-specific rules to win -- eg (#4397) -- truncate :: (RealFrac a, Integral b) => a -> b -- {-# RULES "truncate/Double->Int" truncate = double2Int #-} -- double2Int :: Double -> Int -- We want the specific RULE to beat the built-in class-op rule isMoreSpecific (BuiltinRule {}) _ = False isMoreSpecific (Rule {}) (BuiltinRule {}) = True isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) (Rule { ru_bndrs = bndrs2, ru_args = args2 , ru_name = rule_name2, ru_rhs = rhs }) = isJust (matchN (in_scope, id_unfolding_fun) rule_name2 bndrs2 args2 args1 rhs) where id_unfolding_fun _ = NoUnfolding -- Don't expand in templates in_scope = mkInScopeSet (mkVarSet bndrs1) -- Actually we should probably include the free vars -- of rule1's args, but I can't be bothered noBlackList :: Activation -> Bool noBlackList _ = False -- Nothing is black listed {- Note [Extra args in rule matching] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we find a matching rule, we return (Just (rule, rhs)), but the rule firing has only consumed as many of the input args as the ruleArity says. It's up to the caller to keep track of any left-over args. E.g. if you call lookupRule ... f [e1, e2, e3] and it returns Just (r, rhs), where r has ruleArity 2 then the real rewrite is f e1 e2 e3 ==> rhs e3 You might think it'd be cleaner for lookupRule to deal with the leftover arguments, by applying 'rhs' to them, but the main call in the Simplifier works better as it is. Reason: the 'args' passed to lookupRule are the result of a lazy substitution -} ------------------------------------ matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool) -> Id -> [CoreExpr] -> [Maybe Name] -> CoreRule -> Maybe CoreExpr -- If (matchRule rule args) returns Just (name,rhs) -- then (f args) matches the rule, and the corresponding -- rewritten RHS is rhs -- -- The returned expression is occurrence-analysed -- -- Example -- -- The rule -- forall f g x. map f (map g x) ==> map (f . g) x -- is stored -- CoreRule "map/map" -- [f,g,x] -- tpl_vars -- [f,map g x] -- tpl_args -- map (f.g) x) -- rhs -- -- Then the call: matchRule the_rule [e1,map e2 e3] -- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) -- -- Any 'surplus' arguments in the input are simply put on the end -- of the output. matchRule dflags rule_env _is_active fn args _rough_args (BuiltinRule { ru_try = match_fn }) -- Built-in rules can't be switched off, it seems = case match_fn dflags rule_env fn args of Nothing -> Nothing Just expr -> Just expr matchRule _ in_scope is_active _ args rough_args (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) | not (is_active act) = Nothing | ruleCantMatch tpl_tops rough_args = Nothing | otherwise = matchN in_scope rule_name tpl_vars tpl_args args rhs --------------------------------------- matchN :: InScopeEnv -> RuleName -> [Var] -> [CoreExpr] -> [CoreExpr] -> CoreExpr -- ^ Target; can have more elements than the template -> Maybe CoreExpr -- For a given match template and context, find bindings to wrap around -- the entire result and what should be substituted for each template variable. -- Fail if there are two few actual arguments from the target to match the template matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs = do { rule_subst <- go init_menv emptyRuleSubst tmpl_es target_es ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) (mkEmptyTCvSubst in_scope) $ tmpl_vars `zip` tmpl_vars1 bind_wrapper = rs_binds rule_subst -- Floated bindings; see Note [Matching lets] ; return (bind_wrapper $ mkLams tmpl_vars rhs `mkApps` matched_es) } where (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars -- See Note [Cloning the template binders] init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1 , rv_lcl = init_rn_env , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) , rv_unf = id_unf } go _ subst [] _ = Just subst go _ _ _ [] = Nothing -- Fail if too few actual args go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e ; go menv subst1 ts es } lookup_tmpl :: RuleSubst -> TCvSubst -> (InVar,OutVar) -> (TCvSubst, CoreExpr) -- Need to return a RuleSubst solely for the benefit of mk_fake_ty lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tcv_subst (tmpl_var, tmpl_var1) | isId tmpl_var1 = case lookupVarEnv id_subst tmpl_var1 of Just e | Coercion co <- e -> (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) | otherwise -> (tcv_subst, e) Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1 , let co = Coercion.substCo tcv_subst refl_co -> -- See Note [Unbound RULE binders] (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) | otherwise -> unbound tmpl_var | otherwise = (Type.extendTvSubst tcv_subst tmpl_var1 ty', Type ty') where ty' = case lookupVarEnv tv_subst tmpl_var1 of Just ty -> ty Nothing -> fake_ty -- See Note [Unbound RULE binders] fake_ty = anyTypeOfKind (Type.substTy tcv_subst (tyVarKind tmpl_var1)) -- This substitution is the sole reason we accumulate -- TCvSubst in lookup_tmpl unbound tmpl_var = pprPanic "Template variable unbound in rewrite rule" $ vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var) , text "Rule" <+> pprRuleName rule_name , text "Rule bndrs:" <+> ppr tmpl_vars , text "LHS args:" <+> ppr tmpl_es , text "Actual args:" <+> ppr target_es ] {- Note [Unbound RULE binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It can be the case that the binder in a rule is not actually bound on the LHS: * Type variables. Type synonyms with phantom args can give rise to unbound template type variables. Consider this (#10689, simplCore/should_compile/T10689): type Foo a b = b f :: Eq a => a -> Bool f x = x==x {-# RULES "foo" forall (x :: Foo a Char). f x = True #-} finkle = f 'c' The rule looks like forall (a::*) (d::Eq Char) (x :: Foo a Char). f (Foo a Char) d x = True Matching the rule won't bind 'a', and legitimately so. We fudge by pretending that 'a' is bound to (Any :: *). * Coercion variables. On the LHS of a RULE for a local binder we might have RULE forall (c :: a~b). f (x |> c) = e Now, if that binding is inlined, so that a=b=Int, we'd get RULE forall (c :: Int~Int). f (x |> c) = e and now when we simplify the LHS (Simplify.simplRule) we optCoercion (look at the CoVarCo case) will turn that 'c' into Refl: RULE forall (c :: Int~Int). f (x |> ) = e and then perhaps drop it altogether. Now 'c' is unbound. It's tricky to be sure this never happens, so instead I say it's OK to have an unbound coercion binder in a RULE provided its type is (c :: t~t). Then, when the RULE fires we can substitute for c. This actually happened (in a RULE for a local function) in #13410, and also in test T10602. Note [Cloning the template binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following match (example 1): Template: forall x. f x Target: f (x+1) This should succeed, because the template variable 'x' has nothing to do with the 'x' in the target. Likewise this one (example 2): Template: forall x. f (\x.x) Target: f (\y.y) We achieve this simply by using rnBndrL to clone the template binders if they are already in scope. ------ Historical note ------- At one point I tried simply adding the template binders to the in-scope set /without/ cloning them, but that failed in a horribly obscure way in #14777. Problem was that during matching we look up target-term variables in the in-scope set (see Note [Lookup in-scope]). If a target-term variable happens to name-clash with a template variable, that lookup will find the template variable, which is /utterly/ bogus. In #14777, this transformed a term variable into a type variable, and then crashed when we wanted its idInfo. ------ End of historical note ------- ************************************************************************ * * The main matcher * * ********************************************************************* -} -- * The domain of the TvSubstEnv and IdSubstEnv are the template -- variables passed into the match. -- -- * The BindWrapper in a RuleSubst are the bindings floated out -- from nested matches; see the Let case of match, below -- data RuleMatchEnv = RV { rv_lcl :: RnEnv2 -- Renamings for *local bindings* -- (lambda/case) , rv_tmpls :: VarSet -- Template variables -- (after applying envL of rv_lcl) , rv_fltR :: Subst -- Renamings for floated let-bindings -- (domain disjoint from envR of rv_lcl) -- See Note [Matching lets] , rv_unf :: IdUnfoldingFun } rvInScopeEnv :: RuleMatchEnv -> InScopeEnv rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv) data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the , rs_id_subst :: IdSubstEnv -- template variables , rs_binds :: BindWrapper -- Floated bindings , rs_bndrs :: VarSet -- Variables bound by floated lets } type BindWrapper = CoreExpr -> CoreExpr -- See Notes [Matching lets] and [Matching cases] -- we represent the floated bindings as a core-to-core function emptyRuleSubst :: RuleSubst emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv , rs_binds = \e -> e, rs_bndrs = emptyVarSet } -- At one stage I tried to match even if there are more -- template args than real args. -- I now think this is probably a bad idea. -- Should the template (map f xs) match (map g)? I think not. -- For a start, in general eta expansion wastes work. -- SLPJ July 99 match :: RuleMatchEnv -> RuleSubst -> CoreExpr -- Template -> CoreExpr -- Target -> Maybe RuleSubst -- We look through certain ticks. See Note [Tick annotations in RULE matching] match renv subst e1 (Tick t e2) | tickishFloatable t = match renv subst' e1 e2 where subst' = subst { rs_binds = rs_binds subst . mkTick t } match renv subst (Tick t e1) e2 -- Ignore ticks in rule template. | tickishFloatable t = match renv subst e1 e2 match _ _ e@Tick{} _ = pprPanic "Tick in rule" (ppr e) -- See the notes with Unify.match, which matches types -- Everything is very similar for terms -- Interesting examples: -- Consider matching -- \x->f against \f->f -- When we meet the lambdas we must remember to rename f to f' in the -- second expression. The RnEnv2 does that. -- -- Consider matching -- forall a. \b->b against \a->3 -- We must rename the \a. Otherwise when we meet the lambdas we -- might substitute [a/b] in the template, and then erroneously -- succeed in matching what looks like the template variable 'a' against 3. -- The Var case follows closely what happens in Unify.match match renv subst (Var v1) e2 = match_var renv subst v1 e2 match renv subst e1 (Var v2) -- Note [Expanding variables] | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] , Just e2' <- expandUnfolding_maybe (rv_unf renv v2') = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2' where v2' = lookupRnInScope rn_env v2 rn_env = rv_lcl renv -- Notice that we look up v2 in the in-scope set -- See Note [Lookup in-scope] -- No need to apply any renaming first (hence no rnOccR) -- because of the not-inRnEnvR match renv subst e1 (Let bind e2) | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $ not (isJoinBind bind) -- can't float join point out of argument position , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets] = match (renv { rv_fltR = flt_subst' }) (subst { rs_binds = rs_binds subst . Let bind' , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs }) e1 e2 where flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst) (flt_subst', bind') = substBind flt_subst bind new_bndrs = bindersOf bind' {- Disabled: see Note [Matching cases] below match renv (tv_subst, id_subst, binds) e1 (Case scrut case_bndr ty [(con, alt_bndrs, rhs)]) | exprOkForSpeculation scrut -- See Note [Matching cases] , okToFloat rn_env bndrs (exprFreeVars scrut) = match (renv { me_env = rn_env' }) (tv_subst, id_subst, binds . case_wrap) e1 rhs where rn_env = me_env renv rn_env' = extendRnInScopeList rn_env bndrs bndrs = case_bndr : alt_bndrs case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')] -} match _ subst (Lit lit1) (Lit lit2) | lit1 == lit2 = Just subst match renv subst (App f1 a1) (App f2 a2) = do { subst' <- match renv subst f1 f2 ; match renv subst' a1 a2 } match renv subst (Lam x1 e1) e2 | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2 = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2 , rv_fltR = delBndr (rv_fltR renv) x2 } subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } in match renv' subst' e1 e2 match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) = do { subst1 <- match_ty renv subst ty1 ty2 ; subst2 <- match renv subst1 e1 e2 ; let renv' = rnMatchBndr2 renv subst x1 x2 ; match_alts renv' subst2 alts1 alts2 -- Alts are both sorted } match renv subst (Type ty1) (Type ty2) = match_ty renv subst ty1 ty2 match renv subst (Coercion co1) (Coercion co2) = match_co renv subst co1 co2 match renv subst (Cast e1 co1) (Cast e2 co2) = do { subst1 <- match_co renv subst co1 co2 ; match renv subst1 e1 e2 } -- Everything else fails match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ Nothing ------------- match_co :: RuleMatchEnv -> RuleSubst -> Coercion -> Coercion -> Maybe RuleSubst match_co renv subst co1 co2 | Just cv <- getCoVar_maybe co1 = match_var renv subst cv (Coercion co2) | Just (ty1, r1) <- isReflCo_maybe co1 = do { (ty2, r2) <- isReflCo_maybe co2 ; guard (r1 == r2) ; match_ty renv subst ty1 ty2 } match_co renv subst co1 co2 | Just (tc1, cos1) <- splitTyConAppCo_maybe co1 = case splitTyConAppCo_maybe co2 of Just (tc2, cos2) | tc1 == tc2 -> match_cos renv subst cos1 cos2 _ -> Nothing match_co renv subst co1 co2 | Just (arg1, res1) <- splitFunCo_maybe co1 = case splitFunCo_maybe co2 of Just (arg2, res2) -> match_cos renv subst [arg1, res1] [arg2, res2] _ -> Nothing match_co _ _ _co1 _co2 -- Currently just deals with CoVarCo, TyConAppCo and Refl #if defined(DEBUG) = pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing #else = Nothing #endif match_cos :: RuleMatchEnv -> RuleSubst -> [Coercion] -> [Coercion] -> Maybe RuleSubst match_cos renv subst (co1:cos1) (co2:cos2) = do { subst' <- match_co renv subst co1 co2 ; match_cos renv subst' cos1 cos2 } match_cos _ subst [] [] = Just subst match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing ------------- rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv rnMatchBndr2 renv subst x1 x2 = renv { rv_lcl = rnBndr2 rn_env x1 x2 , rv_fltR = delBndr (rv_fltR renv) x2 } where rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst) -- Typically this is a no-op, but it may matter if -- there are some floated let-bindings ------------------------------------------ match_alts :: RuleMatchEnv -> RuleSubst -> [CoreAlt] -- Template -> [CoreAlt] -- Target -> Maybe RuleSubst match_alts _ subst [] [] = return subst match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) | c1 == c2 = do { subst1 <- match renv' subst r1 r2 ; match_alts renv subst1 alts1 alts2 } where renv' = foldl' mb renv (vs1 `zip` vs2) mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2 match_alts _ _ _ _ = Nothing ------------------------------------------ okToFloat :: RnEnv2 -> VarSet -> Bool okToFloat rn_env bind_fvs = allVarSet not_captured bind_fvs where not_captured fv = not (inRnEnvR rn_env fv) ------------------------------------------ match_var :: RuleMatchEnv -> RuleSubst -> Var -- Template -> CoreExpr -- Target -> Maybe RuleSubst match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) subst v1 e2 | v1' `elemVarSet` tmpls = match_tmpl_var renv subst v1' e2 | otherwise -- v1' is not a template variable; check for an exact match with e2 = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR Var v2 | v1' == rnOccR rn_env v2 -> Just subst | Var v2' <- lookupIdSubst (text "match_var") flt_env v2 , v1' == v2' -> Just subst _ -> Nothing where v1' = rnOccL rn_env v1 -- If the template is -- forall x. f x (\x -> x) = ... -- Then the x inside the lambda isn't the -- template x, so we must rename first! ------------------------------------------ match_tmpl_var :: RuleMatchEnv -> RuleSubst -> Var -- Template -> CoreExpr -- Target -> Maybe RuleSubst match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) v1' e2 | any (inRnEnvR rn_env) (exprFreeVarsList e2) = Nothing -- Occurs check failure -- e.g. match forall a. (\x-> a x) against (\y. y y) | Just e1' <- lookupVarEnv id_subst v1' = if eqExpr (rnInScopeSet rn_env) e1' e2' then Just subst else Nothing | otherwise = -- Note [Matching variable types] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- However, we must match the *types*; e.g. -- forall (c::Char->Int) (x::Char). -- f (c x) = "RULE FIRED" -- We must only match on args that have the right type -- It's actually quite difficult to come up with an example that shows -- you need type matching, esp since matching is left-to-right, so type -- args get matched first. But it's possible (e.g. simplrun008) and -- this is the Right Thing to do do { subst' <- match_ty renv subst (idType v1') (exprType e2) ; return (subst' { rs_id_subst = id_subst' }) } where -- e2' is the result of applying flt_env to e2 e2' | isEmptyVarSet let_bndrs = e2 | otherwise = substExpr (text "match_tmpl_var") flt_env e2 id_subst' = extendVarEnv (rs_id_subst subst) v1' e2' -- No further renaming to do on e2', -- because no free var of e2' is in the rnEnvR of the envt ------------------------------------------ match_ty :: RuleMatchEnv -> RuleSubst -> Type -- Template -> Type -- Target -> Maybe RuleSubst -- Matching Core types: use the matcher in TcType. -- Notice that we treat newtypes as opaque. For example, suppose -- we have a specialised version of a function at a newtype, say -- newtype T = MkT Int -- We only want to replace (f T) with f', not (f Int). match_ty renv subst ty1 ty2 = do { tv_subst' <- Unify.ruleMatchTyKiX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2 ; return (subst { rs_tv_subst = tv_subst' }) } where tv_subst = rs_tv_subst subst {- Note [Expanding variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is another Very Important rule: if the term being matched is a variable, we expand it so long as its unfolding is "expandable". (Its occurrence information is not necessarily up to date, so we don't use it.) By "expandable" we mean a WHNF or a "constructor-like" application. This is the key reason for "constructor-like" Ids. If we have {-# NOINLINE [1] CONLIKE g #-} {-# RULE f (g x) = h x #-} then in the term let v = g 3 in ....(f v).... we want to make the rule fire, to replace (f v) with (h 3). Note [Do not expand locally-bound variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Do *not* expand locally-bound variables, else there's a worry that the unfolding might mention variables that are themselves renamed. Example case x of y { (p,q) -> ...y... } Don't expand 'y' to (p,q) because p,q might themselves have been renamed. Essentially we only expand unfoldings that are "outside" the entire match. Hence, (a) the guard (not (isLocallyBoundR v2)) (b) when we expand we nuke the renaming envt (nukeRnEnvR). Note [Tick annotations in RULE matching] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to unconditionally look through ticks in both template and expression being matched. This is actually illegal for counting or cost-centre-scoped ticks, because we have no place to put them without changing entry counts and/or costs. So now we just fail the match in these cases. On the other hand, where we are allowed to insert new cost into the tick scope, we can float them upwards to the rule application site. Moreover, we may encounter ticks in the template of a rule. There are a few ways in which these may be introduced (e.g. #18162, #17619). Such ticks are ignored by the matcher. See Note [Simplifying rules] in GHC.Core.Opt.Simplify.Utils for details. cf Note [Notes in call patterns] in GHC.Core.Opt.SpecConstr Note [Matching lets] ~~~~~~~~~~~~~~~~~~~~ Matching a let-expression. Consider RULE forall x. f (g x) = and target expression f (let { w=R } in g E)) Then we'd like the rule to match, to generate let { w=R } in (\x. ) E In effect, we want to float the let-binding outward, to enable the match to happen. This is the WHOLE REASON for accumulating bindings in the RuleSubst We can only do this if the free variables of R are not bound by the part of the target expression outside the let binding; e.g. f (\v. let w = v+1 in g E) Here we obviously cannot float the let-binding for w. Hence the use of okToFloat. There are a couple of tricky points. (a) What if floating the binding captures a variable? f (let v = x+1 in v) v --> NOT! let v = x+1 in f (x+1) v (b) What if two non-nested let bindings bind the same variable? f (let v = e1 in b1) (let v = e2 in b2) --> NOT! let v = e1 in let v = e2 in (f b2 b2) See testsuite test "RuleFloatLet". Our cunning plan is this: * Along with the growing substitution for template variables we maintain a growing set of floated let-bindings (rs_binds) plus the set of variables thus bound. * The RnEnv2 in the MatchEnv binds only the local binders in the term (lambdas, case) * When we encounter a let in the term to be matched, we check that does not mention any locally bound (lambda, case) variables. If so we fail * We use CoreSubst.substBind to freshen the binding, using an in-scope set that is the original in-scope variables plus the rs_bndrs (currently floated let-bindings). So in (a) above we'll freshen the 'v' binding; in (b) above we'll freshen the *second* 'v' binding. * We apply that freshening substitution, in a lexically-scoped way to the term, although lazily; this is the rv_fltR field. Note [Matching cases] ~~~~~~~~~~~~~~~~~~~~~ {- NOTE: This idea is currently disabled. It really only works if the primops involved are OkForSpeculation, and, since they have side effects readIntOfAddr and touch are not. Maybe we'll get back to this later . -} Consider f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> case touch# fp s# of { _ -> I# n# } } ) This happened in a tight loop generated by stream fusion that Roman encountered. We'd like to treat this just like the let case, because the primops concerned are ok-for-speculation. That is, we'd like to behave as if it had been case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> case touch# fp s# of { _ -> f (I# n# } } ) Note [Lookup in-scope] ~~~~~~~~~~~~~~~~~~~~~~ Consider this example foo :: Int -> Maybe Int -> Int foo 0 (Just n) = n foo m (Just n) = foo (m-n) (Just n) SpecConstr sees this fragment: case w_smT of wild_Xf [Just A] { Data.Maybe.Nothing -> lvl_smf; Data.Maybe.Just n_acT [Just S(L)] -> case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf }}; and correctly generates the rule RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# sc_snn :: GHC.Prim.Int#} $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) = $s$wfoo_sno y_amr sc_snn ;] BUT we must ensure that this rule matches in the original function! Note that the call to $wfoo is $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf During matching we expand wild_Xf to (Just n_acT). But then we must also expand n_acT to (I# y_amr). And we can only do that if we look up n_acT in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding at all. That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' is so important. ************************************************************************ * * Rule-check the program * * ************************************************************************ We want to know what sites have rules that could have fired but didn't. This pass runs over the tree (without changing it) and reports such. -} -- | Report partial matches for rules beginning with the specified -- string for the purposes of error reporting ruleCheckProgram :: CompilerPhase -- ^ Rule activation test -> String -- ^ Rule pattern -> (Id -> [CoreRule]) -- ^ Rules for an Id -> CoreProgram -- ^ Bindings to check in -> SDoc -- ^ Resulting check message ruleCheckProgram phase rule_pat rules binds | isEmptyBag results = text "Rule check results: no rule application sites" | otherwise = vcat [text "Rule check results:", line, vcat [ p $$ line | p <- bagToList results ] ] where env = RuleCheckEnv { rc_is_active = isActive phase , rc_id_unf = idUnfolding -- Not quite right -- Should use activeUnfolding , rc_pattern = rule_pat , rc_rules = rules } results = unionManyBags (map (ruleCheckBind env) binds) line = text (replicate 20 '-') data RuleCheckEnv = RuleCheckEnv { rc_is_active :: Activation -> Bool, rc_id_unf :: IdUnfoldingFun, rc_pattern :: String, rc_rules :: Id -> [CoreRule] } ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc -- The Bag returned has one SDoc for each call site found ruleCheckBind env (NonRec _ r) = ruleCheck env r ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs] ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc ruleCheck _ (Var _) = emptyBag ruleCheck _ (Lit _) = emptyBag ruleCheck _ (Type _) = emptyBag ruleCheck _ (Coercion _) = emptyBag ruleCheck env (App f a) = ruleCheckApp env (App f a) [] ruleCheck env (Tick _ e) = ruleCheck env e ruleCheck env (Cast e _) = ruleCheck env e ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e ruleCheck env (Lam _ e) = ruleCheck env e ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` unionManyBags [ruleCheck env r | (_,_,r) <- as] ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) ruleCheckApp env (Var f) as = ruleCheckFun env f as ruleCheckApp env other _ = ruleCheck env other ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc -- Produce a report for all rules matching the predicate -- saying why it doesn't match the specified application ruleCheckFun env fn args | null name_match_rules = emptyBag | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) where name_match_rules = filter match (rc_rules env fn) match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc ruleAppCheck_help env fn args rules = -- The rules match the pattern, so we want to print something vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), vcat (map check_rule rules)] where n_args = length args i_args = args `zip` [1::Int ..] rough_args = map roughTopName args check_rule rule = sdocWithDynFlags $ \dflags -> rule_herald rule <> colon <+> rule_info dflags rule rule_herald (BuiltinRule { ru_name = name }) = text "Builtin rule" <+> doubleQuotes (ftext name) rule_herald (Rule { ru_name = name }) = text "Rule" <+> doubleQuotes (ftext name) rule_info dflags rule | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env) noBlackList fn args rough_args rule = text "matches (which is very peculiar!)" rule_info _ (BuiltinRule {}) = text "does not match" rule_info _ (Rule { ru_act = act, ru_bndrs = rule_bndrs, ru_args = rule_args}) | not (rc_is_active env act) = text "active only in later phase" | n_args < n_rule_args = text "too few arguments" | n_mismatches == n_rule_args = text "no arguments match" | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" where n_rule_args = length rule_args n_mismatches = length mismatches mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, not (isJust (match_fn rule_arg arg))] lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg where in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg) renv = RV { rv_lcl = mkRnEnv2 in_scope , rv_tmpls = mkVarSet rule_bndrs , rv_fltR = mkEmptySubst in_scope , rv_unf = rc_id_unf env } ghc-lib-parser-8.10.2.20200808/compiler/main/Settings.hs0000644000000000000000000001563713713635745020415 0ustar0000000000000000module Settings ( Settings (..) , sProgramName , sProjectVersion , sGhcUsagePath , sGhciUsagePath , sToolDir , sTopDir , sTmpDir , sSystemPackageConfig , sLdSupportsCompactUnwind , sLdSupportsBuildId , sLdSupportsFilelist , sLdIsGnuLd , sGccSupportsNoPie , sPgm_L , sPgm_P , sPgm_F , sPgm_c , sPgm_a , sPgm_l , sPgm_lm , sPgm_dll , sPgm_T , sPgm_windres , sPgm_libtool , sPgm_ar , sPgm_ranlib , sPgm_lo , sPgm_lc , sPgm_lcc , sPgm_i , sOpt_L , sOpt_P , sOpt_P_fingerprint , sOpt_F , sOpt_c , sOpt_cxx , sOpt_a , sOpt_l , sOpt_lm , sOpt_windres , sOpt_lo , sOpt_lc , sOpt_lcc , sOpt_i , sExtraGccViaCFlags , sTargetPlatformString , sIntegerLibrary , sIntegerLibraryType , sGhcWithInterpreter , sGhcWithNativeCodeGen , sGhcWithSMP , sGhcRTSWays , sTablesNextToCode , sLeadingUnderscore , sLibFFI , sGhcThreaded , sGhcDebugged , sGhcRtsWithLibdw ) where import GhcPrelude import CliOption import Fingerprint import FileSettings import GhcNameVersion import GHC.Platform import PlatformConstants import ToolSettings data Settings = Settings { sGhcNameVersion :: {-# UNPACk #-} !GhcNameVersion , sFileSettings :: {-# UNPACK #-} !FileSettings , sTargetPlatform :: Platform -- Filled in by SysTools , sToolSettings :: {-# UNPACK #-} !ToolSettings , sPlatformMisc :: {-# UNPACK #-} !PlatformMisc , sPlatformConstants :: PlatformConstants -- You shouldn't need to look things up in rawSettings directly. -- They should have their own fields instead. , sRawSettings :: [(String, String)] } ----------------------------------------------------------------------------- -- Accessessors from 'Settings' sProgramName :: Settings -> String sProgramName = ghcNameVersion_programName . sGhcNameVersion sProjectVersion :: Settings -> String sProjectVersion = ghcNameVersion_projectVersion . sGhcNameVersion sGhcUsagePath :: Settings -> FilePath sGhcUsagePath = fileSettings_ghcUsagePath . sFileSettings sGhciUsagePath :: Settings -> FilePath sGhciUsagePath = fileSettings_ghciUsagePath . sFileSettings sToolDir :: Settings -> Maybe FilePath sToolDir = fileSettings_toolDir . sFileSettings sTopDir :: Settings -> FilePath sTopDir = fileSettings_topDir . sFileSettings sTmpDir :: Settings -> String sTmpDir = fileSettings_tmpDir . sFileSettings sSystemPackageConfig :: Settings -> FilePath sSystemPackageConfig = fileSettings_systemPackageConfig . sFileSettings sLdSupportsCompactUnwind :: Settings -> Bool sLdSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind . sToolSettings sLdSupportsBuildId :: Settings -> Bool sLdSupportsBuildId = toolSettings_ldSupportsBuildId . sToolSettings sLdSupportsFilelist :: Settings -> Bool sLdSupportsFilelist = toolSettings_ldSupportsFilelist . sToolSettings sLdIsGnuLd :: Settings -> Bool sLdIsGnuLd = toolSettings_ldIsGnuLd . sToolSettings sGccSupportsNoPie :: Settings -> Bool sGccSupportsNoPie = toolSettings_ccSupportsNoPie . sToolSettings sPgm_L :: Settings -> String sPgm_L = toolSettings_pgm_L . sToolSettings sPgm_P :: Settings -> (String, [Option]) sPgm_P = toolSettings_pgm_P . sToolSettings sPgm_F :: Settings -> String sPgm_F = toolSettings_pgm_F . sToolSettings sPgm_c :: Settings -> String sPgm_c = toolSettings_pgm_c . sToolSettings sPgm_a :: Settings -> (String, [Option]) sPgm_a = toolSettings_pgm_a . sToolSettings sPgm_l :: Settings -> (String, [Option]) sPgm_l = toolSettings_pgm_l . sToolSettings sPgm_lm :: Settings -> (String, [Option]) sPgm_lm = toolSettings_pgm_lm . sToolSettings sPgm_dll :: Settings -> (String, [Option]) sPgm_dll = toolSettings_pgm_dll . sToolSettings sPgm_T :: Settings -> String sPgm_T = toolSettings_pgm_T . sToolSettings sPgm_windres :: Settings -> String sPgm_windres = toolSettings_pgm_windres . sToolSettings sPgm_libtool :: Settings -> String sPgm_libtool = toolSettings_pgm_libtool . sToolSettings sPgm_ar :: Settings -> String sPgm_ar = toolSettings_pgm_ar . sToolSettings sPgm_ranlib :: Settings -> String sPgm_ranlib = toolSettings_pgm_ranlib . sToolSettings sPgm_lo :: Settings -> (String, [Option]) sPgm_lo = toolSettings_pgm_lo . sToolSettings sPgm_lc :: Settings -> (String, [Option]) sPgm_lc = toolSettings_pgm_lc . sToolSettings sPgm_lcc :: Settings -> (String, [Option]) sPgm_lcc = toolSettings_pgm_lcc . sToolSettings sPgm_i :: Settings -> String sPgm_i = toolSettings_pgm_i . sToolSettings sOpt_L :: Settings -> [String] sOpt_L = toolSettings_opt_L . sToolSettings sOpt_P :: Settings -> [String] sOpt_P = toolSettings_opt_P . sToolSettings sOpt_P_fingerprint :: Settings -> Fingerprint sOpt_P_fingerprint = toolSettings_opt_P_fingerprint . sToolSettings sOpt_F :: Settings -> [String] sOpt_F = toolSettings_opt_F . sToolSettings sOpt_c :: Settings -> [String] sOpt_c = toolSettings_opt_c . sToolSettings sOpt_cxx :: Settings -> [String] sOpt_cxx = toolSettings_opt_cxx . sToolSettings sOpt_a :: Settings -> [String] sOpt_a = toolSettings_opt_a . sToolSettings sOpt_l :: Settings -> [String] sOpt_l = toolSettings_opt_l . sToolSettings sOpt_lm :: Settings -> [String] sOpt_lm = toolSettings_opt_lm . sToolSettings sOpt_windres :: Settings -> [String] sOpt_windres = toolSettings_opt_windres . sToolSettings sOpt_lo :: Settings -> [String] sOpt_lo = toolSettings_opt_lo . sToolSettings sOpt_lc :: Settings -> [String] sOpt_lc = toolSettings_opt_lc . sToolSettings sOpt_lcc :: Settings -> [String] sOpt_lcc = toolSettings_opt_lcc . sToolSettings sOpt_i :: Settings -> [String] sOpt_i = toolSettings_opt_i . sToolSettings sExtraGccViaCFlags :: Settings -> [String] sExtraGccViaCFlags = toolSettings_extraGccViaCFlags . sToolSettings sTargetPlatformString :: Settings -> String sTargetPlatformString = platformMisc_targetPlatformString . sPlatformMisc sIntegerLibrary :: Settings -> String sIntegerLibrary = platformMisc_integerLibrary . sPlatformMisc sIntegerLibraryType :: Settings -> IntegerLibrary sIntegerLibraryType = platformMisc_integerLibraryType . sPlatformMisc sGhcWithInterpreter :: Settings -> Bool sGhcWithInterpreter = platformMisc_ghcWithInterpreter . sPlatformMisc sGhcWithNativeCodeGen :: Settings -> Bool sGhcWithNativeCodeGen = platformMisc_ghcWithNativeCodeGen . sPlatformMisc sGhcWithSMP :: Settings -> Bool sGhcWithSMP = platformMisc_ghcWithSMP . sPlatformMisc sGhcRTSWays :: Settings -> String sGhcRTSWays = platformMisc_ghcRTSWays . sPlatformMisc sTablesNextToCode :: Settings -> Bool sTablesNextToCode = platformMisc_tablesNextToCode . sPlatformMisc sLeadingUnderscore :: Settings -> Bool sLeadingUnderscore = platformMisc_leadingUnderscore . sPlatformMisc sLibFFI :: Settings -> Bool sLibFFI = platformMisc_libFFI . sPlatformMisc sGhcThreaded :: Settings -> Bool sGhcThreaded = platformMisc_ghcThreaded . sPlatformMisc sGhcDebugged :: Settings -> Bool sGhcDebugged = platformMisc_ghcDebugged . sPlatformMisc sGhcRtsWithLibdw :: Settings -> Bool sGhcRtsWithLibdw = platformMisc_ghcRtsWithLibdw . sPlatformMisc ghc-lib-parser-8.10.2.20200808/libraries/ghci/SizedSeq.hs0000644000000000000000000000223013713635662020453 0ustar0000000000000000{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-} module SizedSeq ( SizedSeq(..) , emptySS , addToSS , addListToSS , ssElts , sizeSS ) where import Prelude -- See note [Why do we import Prelude here?] import Control.DeepSeq import Data.Binary import Data.List import GHC.Generics data SizedSeq a = SizedSeq {-# UNPACK #-} !Word [a] deriving (Generic, Show) instance Functor SizedSeq where fmap f (SizedSeq sz l) = SizedSeq sz (fmap f l) instance Foldable SizedSeq where foldr f c ss = foldr f c (ssElts ss) instance Traversable SizedSeq where traverse f (SizedSeq sz l) = SizedSeq sz . reverse <$> traverse f (reverse l) instance Binary a => Binary (SizedSeq a) instance NFData a => NFData (SizedSeq a) where rnf (SizedSeq _ xs) = rnf xs emptySS :: SizedSeq a emptySS = SizedSeq 0 [] addToSS :: SizedSeq a -> a -> SizedSeq a addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs) addListToSS :: SizedSeq a -> [a] -> SizedSeq a addListToSS (SizedSeq n r_xs) xs = SizedSeq (n + genericLength xs) (reverse xs ++ r_xs) ssElts :: SizedSeq a -> [a] ssElts (SizedSeq _ r_xs) = reverse r_xs sizeSS :: SizedSeq a -> Word sizeSS (SizedSeq n _) = n ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/SrcLoc.hs0000644000000000000000000006326413713635744021162 0ustar0000000000000000-- (c) The University of Glasgow, 1992-2006 {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternSynonyms #-} -- | This module contains types that relate to the positions of things -- in source files, and allow tagging of those things with locations module SrcLoc ( -- * SrcLoc RealSrcLoc, -- Abstract SrcLoc(..), -- ** Constructing SrcLoc mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, noSrcLoc, -- "I'm sorry, I haven't a clue" generatedSrcLoc, -- Code generated within the compiler interactiveSrcLoc, -- Code from an interactive session advanceSrcLoc, -- ** Unsafely deconstructing SrcLoc -- These are dubious exports, because they crash on some inputs srcLocFile, -- return the file name part srcLocLine, -- return the line part srcLocCol, -- return the column part -- * SrcSpan RealSrcSpan, -- Abstract SrcSpan(..), -- ** Constructing SrcSpan mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, noSrcSpan, wiredInSrcSpan, -- Something wired into the compiler interactiveSrcSpan, srcLocSpan, realSrcLocSpan, combineSrcSpans, srcSpanFirstCharacter, -- ** Deconstructing SrcSpan srcSpanStart, srcSpanEnd, realSrcSpanStart, realSrcSpanEnd, srcSpanFileName_maybe, pprUserRealSpan, -- ** Unsafely deconstructing SrcSpan -- These are dubious exports, because they crash on some inputs srcSpanFile, srcSpanStartLine, srcSpanEndLine, srcSpanStartCol, srcSpanEndCol, -- ** Predicates on SrcSpan isGoodSrcSpan, isOneLineSpan, containsSpan, -- * Located Located, RealLocated, GenLocated(..), -- ** Constructing Located noLoc, mkGeneralLocated, -- ** Deconstructing Located getLoc, unLoc, unRealSrcSpan, getRealSrcSpan, -- ** Modifying Located mapLoc, -- ** Combining and comparing Located values eqLocated, cmpLocated, combineLocs, addCLoc, leftmost_smallest, leftmost_largest, rightmost, spans, isSubspanOf, sortLocated, -- ** HasSrcSpan HasSrcSpan(..), SrcSpanLess, dL, cL, pattern LL, onHasSrcSpan, liftL ) where import GhcPrelude import Util import Json import Outputable import FastString import Control.DeepSeq import Data.Bits import Data.Data import Data.List (sortBy, intercalate) import Data.Ord {- ************************************************************************ * * \subsection[SrcLoc-SrcLocations]{Source-location information} * * ************************************************************************ We keep information about the {\em definition} point for each entity; this is the obvious stuff: -} -- | Real Source Location -- -- Represents a single point within a file data RealSrcLoc = SrcLoc FastString -- A precise location (file name) {-# UNPACK #-} !Int -- line number, begins at 1 {-# UNPACK #-} !Int -- column number, begins at 1 deriving (Eq, Ord) -- | Source Location data SrcLoc = RealSrcLoc {-# UNPACK #-}!RealSrcLoc | UnhelpfulLoc FastString -- Just a general indication deriving (Eq, Ord, Show) {- ************************************************************************ * * \subsection[SrcLoc-access-fns]{Access functions} * * ************************************************************************ -} mkSrcLoc :: FastString -> Int -> Int -> SrcLoc mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc mkRealSrcLoc x line col = SrcLoc x line col -- | Built-in "bad" 'SrcLoc' values for particular locations noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc noSrcLoc = UnhelpfulLoc (fsLit "") generatedSrcLoc = UnhelpfulLoc (fsLit "") interactiveSrcLoc = UnhelpfulLoc (fsLit "") -- | Creates a "bad" 'SrcLoc' that has no detailed information about its location mkGeneralSrcLoc :: FastString -> SrcLoc mkGeneralSrcLoc = UnhelpfulLoc -- | Gives the filename of the 'RealSrcLoc' srcLocFile :: RealSrcLoc -> FastString srcLocFile (SrcLoc fname _ _) = fname -- | Raises an error when used on a "bad" 'SrcLoc' srcLocLine :: RealSrcLoc -> Int srcLocLine (SrcLoc _ l _) = l -- | Raises an error when used on a "bad" 'SrcLoc' srcLocCol :: RealSrcLoc -> Int srcLocCol (SrcLoc _ _ c) = c -- | Move the 'SrcLoc' down by one line if the character is a newline, -- to the next 8-char tabstop if it is a tab, and across by one -- character in any other case advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (((((c - 1) `shiftR` 3) + 1) `shiftL` 3) + 1) advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) {- ************************************************************************ * * \subsection[SrcLoc-instances]{Instance declarations for various names} * * ************************************************************************ -} sortLocated :: HasSrcSpan a => [a] -> [a] sortLocated things = sortBy (comparing getLoc) things instance Outputable RealSrcLoc where ppr (SrcLoc src_path src_line src_col) = hcat [ pprFastFilePath src_path <> colon , int src_line <> colon , int src_col ] -- I don't know why there is this style-based difference -- if userStyle sty || debugStyle sty then -- hcat [ pprFastFilePath src_path, char ':', -- int src_line, -- char ':', int src_col -- ] -- else -- hcat [text "{-# LINE ", int src_line, space, -- char '\"', pprFastFilePath src_path, text " #-}"] instance Outputable SrcLoc where ppr (RealSrcLoc l) = ppr l ppr (UnhelpfulLoc s) = ftext s instance Data RealSrcSpan where -- don't traverse? toConstr _ = abstractConstr "RealSrcSpan" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "RealSrcSpan" instance Data SrcSpan where -- don't traverse? toConstr _ = abstractConstr "SrcSpan" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "SrcSpan" {- ************************************************************************ * * \subsection[SrcSpan]{Source Spans} * * ************************************************************************ -} {- | A 'RealSrcSpan' delimits a portion of a text file. It could be represented by a pair of (line,column) coordinates, but in fact we optimise slightly by using more compact representations for single-line and zero-length spans, both of which are quite common. The end position is defined to be the column /after/ the end of the span. That is, a span of (1,1)-(1,2) is one character long, and a span of (1,1)-(1,1) is zero characters long. -} -- | Real Source Span data RealSrcSpan = RealSrcSpan' { srcSpanFile :: !FastString, srcSpanSLine :: {-# UNPACK #-} !Int, srcSpanSCol :: {-# UNPACK #-} !Int, srcSpanELine :: {-# UNPACK #-} !Int, srcSpanECol :: {-# UNPACK #-} !Int } deriving Eq -- | Source Span -- -- A 'SrcSpan' identifies either a specific portion of a text file -- or a human-readable description of a location. data SrcSpan = RealSrcSpan !RealSrcSpan | UnhelpfulSpan !FastString -- Just a general indication -- also used to indicate an empty span deriving (Eq, Ord, Show) -- Show is used by Lexer.x, because we -- derive Show for Token instance ToJson SrcSpan where json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")] json (RealSrcSpan rss) = json rss instance ToJson RealSrcSpan where json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)) , ("startLine", JSInt srcSpanSLine) , ("startCol", JSInt srcSpanSCol) , ("endLine", JSInt srcSpanELine) , ("endCol", JSInt srcSpanECol) ] instance NFData SrcSpan where rnf x = x `seq` () -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan noSrcSpan = UnhelpfulSpan (fsLit "") wiredInSrcSpan = UnhelpfulSpan (fsLit "") interactiveSrcSpan = UnhelpfulSpan (fsLit "") -- | Create a "bad" 'SrcSpan' that has not location information mkGeneralSrcSpan :: FastString -> SrcSpan mkGeneralSrcSpan = UnhelpfulSpan -- | Create a 'SrcSpan' corresponding to a single point srcLocSpan :: SrcLoc -> SrcSpan srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l) realSrcLocSpan :: RealSrcLoc -> RealSrcSpan realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col -- | Create a 'SrcSpan' between two points in a file mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2 where line1 = srcLocLine loc1 line2 = srcLocLine loc2 col1 = srcLocCol loc1 col2 = srcLocCol loc2 file = srcLocFile loc1 -- | 'True' if the span is known to straddle only one line. isOneLineRealSpan :: RealSrcSpan -> Bool isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _) = line1 == line2 -- | 'True' if the span is a single point isPointRealSpan :: RealSrcSpan -> Bool isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2) = line1 == line2 && col1 == col2 -- | Create a 'SrcSpan' between two points in a file mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2) = RealSrcSpan (mkRealSrcSpan loc1 loc2) -- | Combines two 'SrcSpan' into one that spans at least all the characters -- within both spans. Returns UnhelpfulSpan if the files differ. combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful combineSrcSpans l (UnhelpfulSpan _) = l combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2) | srcSpanFile span1 == srcSpanFile span2 = RealSrcSpan (combineRealSrcSpans span1 span2) | otherwise = UnhelpfulSpan (fsLit "") -- | Combines two 'SrcSpan' into one that spans at least all the characters -- within both spans. Assumes the "file" part is the same in both inputs combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan combineRealSrcSpans span1 span2 = RealSrcSpan' file line_start col_start line_end col_end where (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) (srcSpanStartLine span2, srcSpanStartCol span2) (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) (srcSpanEndLine span2, srcSpanEndCol span2) file = srcSpanFile span1 -- | Convert a SrcSpan into one that represents only its first character srcSpanFirstCharacter :: SrcSpan -> SrcSpan srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2 where loc1@(SrcLoc f l c) = realSrcSpanStart span loc2 = SrcLoc f l (c+1) {- ************************************************************************ * * \subsection[SrcSpan-predicates]{Predicates} * * ************************************************************************ -} -- | Test if a 'SrcSpan' is "good", i.e. has precise location information isGoodSrcSpan :: SrcSpan -> Bool isGoodSrcSpan (RealSrcSpan _) = True isGoodSrcSpan (UnhelpfulSpan _) = False isOneLineSpan :: SrcSpan -> Bool -- ^ True if the span is known to straddle only one line. -- For "bad" 'SrcSpan', it returns False isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s isOneLineSpan (UnhelpfulSpan _) = False -- | Tests whether the first span "contains" the other span, meaning -- that it covers at least as much source code. True where spans are equal. containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool containsSpan s1 s2 = (srcSpanStartLine s1, srcSpanStartCol s1) <= (srcSpanStartLine s2, srcSpanStartCol s2) && (srcSpanEndLine s1, srcSpanEndCol s1) >= (srcSpanEndLine s2, srcSpanEndCol s2) && (srcSpanFile s1 == srcSpanFile s2) -- We check file equality last because it is (presumably?) least -- likely to fail. {- %************************************************************************ %* * \subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions} * * ************************************************************************ -} srcSpanStartLine :: RealSrcSpan -> Int srcSpanEndLine :: RealSrcSpan -> Int srcSpanStartCol :: RealSrcSpan -> Int srcSpanEndCol :: RealSrcSpan -> Int srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c {- ************************************************************************ * * \subsection[SrcSpan-access-fns]{Access functions} * * ************************************************************************ -} -- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanStart :: SrcSpan -> SrcLoc srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s) -- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanEnd :: SrcSpan -> SrcLoc srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s) realSrcSpanStart :: RealSrcSpan -> RealSrcLoc realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s) (srcSpanStartLine s) (srcSpanStartCol s) realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) (srcSpanEndLine s) (srcSpanEndCol s) -- | Obtains the filename for a 'SrcSpan' if it is "good" srcSpanFileName_maybe :: SrcSpan -> Maybe FastString srcSpanFileName_maybe (RealSrcSpan s) = Just (srcSpanFile s) srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing {- ************************************************************************ * * \subsection[SrcSpan-instances]{Instances} * * ************************************************************************ -} -- We want to order RealSrcSpans first by the start point, then by the -- end point. instance Ord RealSrcSpan where a `compare` b = (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp` (realSrcSpanEnd a `compare` realSrcSpanEnd b) instance Show RealSrcLoc where show (SrcLoc filename row col) = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col -- Show is used by Lexer.x, because we derive Show for Token instance Show RealSrcSpan where show span@(RealSrcSpan' file sl sc el ec) | isPointRealSpan span = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc]) | isOneLineRealSpan span = "SrcSpanOneLine " ++ show file ++ " " ++ intercalate " " (map show [sl,sc,ec]) | otherwise = "SrcSpanMultiLine " ++ show file ++ " " ++ intercalate " " (map show [sl,sc,el,ec]) instance Outputable RealSrcSpan where ppr span = pprUserRealSpan True span -- I don't know why there is this style-based difference -- = getPprStyle $ \ sty -> -- if userStyle sty || debugStyle sty then -- text (showUserRealSpan True span) -- else -- hcat [text "{-# LINE ", int (srcSpanStartLine span), space, -- char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] instance Outputable SrcSpan where ppr span = pprUserSpan True span -- I don't know why there is this style-based difference -- = getPprStyle $ \ sty -> -- if userStyle sty || debugStyle sty then -- pprUserSpan True span -- else -- case span of -- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan" -- RealSrcSpan s -> ppr s pprUserSpan :: Bool -> SrcSpan -> SDoc pprUserSpan _ (UnhelpfulSpan s) = ftext s pprUserSpan show_path (RealSrcSpan s) = pprUserRealSpan show_path s pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _) | isPointRealSpan span = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) , int line <> colon , int col ] pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol) | isOneLineRealSpan span = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) , int line <> colon , int scol , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ] -- For single-character or point spans, we just -- output the starting column number pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol) = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) , parens (int sline <> comma <> int scol) , char '-' , parens (int eline <> comma <> int ecol') ] where ecol' = if ecol == 0 then ecol else ecol - 1 {- ************************************************************************ * * \subsection[Located]{Attaching SrcSpans to things} * * ************************************************************************ -} -- | We attach SrcSpans to lots of things, so let's have a datatype for it. data GenLocated l e = L l e deriving (Eq, Ord, Data, Functor, Foldable, Traversable) type Located = GenLocated SrcSpan type RealLocated = GenLocated RealSrcSpan mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b mapLoc = fmap unLoc :: HasSrcSpan a => a -> SrcSpanLess a unLoc (dL->L _ e) = e getLoc :: HasSrcSpan a => a -> SrcSpan getLoc (dL->L l _) = l noLoc :: HasSrcSpan a => SrcSpanLess a -> a noLoc e = cL noSrcSpan e mkGeneralLocated :: HasSrcSpan e => String -> SrcSpanLess e -> e mkGeneralLocated s e = cL (mkGeneralSrcSpan (fsLit s)) e combineLocs :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) -- | Combine locations from two 'Located' things and add them to a third thing addCLoc :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => a -> b -> SrcSpanLess c -> c addCLoc a b c = cL (combineSrcSpans (getLoc a) (getLoc b)) c -- not clear whether to add a general Eq instance, but this is useful sometimes: -- | Tests whether the two located things are equal eqLocated :: (HasSrcSpan a , Eq (SrcSpanLess a)) => a -> a -> Bool eqLocated a b = unLoc a == unLoc b -- not clear whether to add a general Ord instance, but this is useful sometimes: -- | Tests the ordering of the two located things cmpLocated :: (HasSrcSpan a , Ord (SrcSpanLess a)) => a -> a -> Ordering cmpLocated a b = unLoc a `compare` unLoc b instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where ppr (L l e) = -- TODO: We can't do this since Located was refactored into -- GenLocated: -- Print spans without the file name etc -- ifPprDebug (braces (pprUserSpan False l)) whenPprDebug (braces (ppr l)) $$ ppr e {- ************************************************************************ * * \subsection{Ordering SrcSpans for InteractiveUI} * * ************************************************************************ -} -- | Alternative strategies for ordering 'SrcSpan's leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering rightmost = flip compare leftmost_smallest = compare leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b) `thenCmp` (srcSpanEnd b `compare` srcSpanEnd a) -- | Determines whether a span encloses a given line and column index spans :: SrcSpan -> (Int, Int) -> Bool spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span where loc = mkRealSrcLoc (srcSpanFile span) l c -- | Determines whether a span is enclosed by another one isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other -> SrcSpan -- ^ The span it may be enclosed by -> Bool isSubspanOf src parent | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False | otherwise = srcSpanStart parent <= srcSpanStart src && srcSpanEnd parent >= srcSpanEnd src {- ************************************************************************ * * \subsection{HasSrcSpan Typeclass to Set/Get Source Location Spans} * * ************************************************************************ -} {- Note [HasSrcSpan Typeclass] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To be able to uniformly set/get source location spans (of `SrcSpan`) in syntactic entities (`HsSyn`), we use the typeclass `HasSrcSpan`. More details can be found at the following wiki page ImplementingTreesThatGrow/HandlingSourceLocations For most syntactic entities, the source location spans are stored in a syntactic entity by a wapper constuctor (introduced by TTG's new constructor extension), e.g., by `NewPat (WrapperPat sp pat)` for a source location span `sp` and a pattern `pat`. -} -- | Determines the type of undecorated syntactic entities -- For most syntactic entities `E`, where source location spans are -- introduced by a wrapper construtor of the same syntactic entity, -- we have `SrcSpanLess E = E`. -- However, some syntactic entities have a different type compared to -- a syntactic entity `e :: E` may have the type `Located E` when -- decorated by wrapping it with `L sp e` for a source span `sp`. type family SrcSpanLess a -- | A typeclass to set/get SrcSpans class HasSrcSpan a where -- | Composes a `SrcSpan` decoration with an undecorated syntactic -- entity to form its decorated variant composeSrcSpan :: Located (SrcSpanLess a) -> a -- | Decomposes a decorated syntactic entity into its `SrcSpan` -- decoration and its undecorated variant decomposeSrcSpan :: a -> Located (SrcSpanLess a) {- laws: composeSrcSpan . decomposeSrcSpan = id decomposeSrcSpan . composeSrcSpan = id in other words, `HasSrcSpan` defines an iso relation between a `SrcSpan`-decorated syntactic entity and its undecorated variant (together with the `SrcSpan`). -} type instance SrcSpanLess (GenLocated l e) = e instance HasSrcSpan (Located a) where composeSrcSpan = id decomposeSrcSpan = id -- | An abbreviated form of decomposeSrcSpan, -- mainly to be used in ViewPatterns dL :: HasSrcSpan a => a -> Located (SrcSpanLess a) dL = decomposeSrcSpan -- | An abbreviated form of composeSrcSpan, -- mainly to replace the hardcoded `L` cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL sp e = composeSrcSpan (L sp e) -- | A Pattern Synonym to Set/Get SrcSpans pattern LL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a pattern LL sp e <- (dL->L sp e) where LL sp e = cL sp e -- | Lifts a function of undecorated entities to one of decorated ones onHasSrcSpan :: (HasSrcSpan a , HasSrcSpan b) => (SrcSpanLess a -> SrcSpanLess b) -> a -> b onHasSrcSpan f (dL->L l e) = cL l (f e) liftL :: (HasSrcSpan a, HasSrcSpan b, Monad m) => (SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b liftL f (dL->L loc a) = do a' <- f a return $ cL loc a' getRealSrcSpan :: RealLocated a -> RealSrcSpan getRealSrcSpan (L l _) = l unRealSrcSpan :: RealLocated a -> a unRealSrcSpan (L _ e) = e ghc-lib-parser-8.10.2.20200808/compiler/utils/StringBuffer.hs0000644000000000000000000003022313713635745021415 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The University of Glasgow, 1997-2006 Buffers for scanning string input stored in external arrays. -} {-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -O2 #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected module StringBuffer ( StringBuffer(..), -- non-abstract for vs\/HaskellService -- * Creation\/destruction hGetStringBuffer, hGetStringBufferBlock, hPutStringBuffer, appendStringBuffers, stringToStringBuffer, -- * Inspection nextChar, currentChar, prevChar, atEnd, -- * Moving and comparison stepOn, offsetBytes, byteDiff, atLine, -- * Conversion lexemeToString, lexemeToFastString, decodePrevNChars, -- * Parsing integers parseUnsignedInteger, ) where #include "GhclibHsVersions.h" import GhcPrelude import Encoding import FastString import FastFunctions import PlainPanic import Util import Data.Maybe import Control.Exception import System.IO import System.IO.Unsafe ( unsafePerformIO ) import GHC.IO.Encoding.UTF8 ( mkUTF8 ) import GHC.IO.Encoding.Failure ( CodingFailureMode(IgnoreCodingFailure) ) import GHC.Exts import Foreign -- ----------------------------------------------------------------------------- -- The StringBuffer type -- |A StringBuffer is an internal pointer to a sized chunk of bytes. -- The bytes are intended to be *immutable*. There are pure -- operations to read the contents of a StringBuffer. -- -- A StringBuffer may have a finalizer, depending on how it was -- obtained. -- data StringBuffer = StringBuffer { buf :: {-# UNPACK #-} !(ForeignPtr Word8), len :: {-# UNPACK #-} !Int, -- length cur :: {-# UNPACK #-} !Int -- current pos } -- The buffer is assumed to be UTF-8 encoded, and furthermore -- we add three @\'\\0\'@ bytes to the end as sentinels so that the -- decoder doesn't have to check for overflow at every single byte -- of a multibyte sequence. instance Show StringBuffer where showsPrec _ s = showString "" -- ----------------------------------------------------------------------------- -- Creation / Destruction -- | Read a file into a 'StringBuffer'. The resulting buffer is automatically -- managed by the garbage collector. hGetStringBuffer :: FilePath -> IO StringBuffer hGetStringBuffer fname = do h <- openBinaryFile fname ReadMode size_i <- hFileSize h offset_i <- skipBOM h size_i 0 -- offset is 0 initially let size = fromIntegral $ size_i - offset_i buf <- mallocForeignPtrArray (size+3) withForeignPtr buf $ \ptr -> do r <- if size == 0 then return 0 else hGetBuf h ptr size hClose h if (r /= size) then ioError (userError "short read of file") else newUTF8StringBuffer buf ptr size hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer hGetStringBufferBlock handle wanted = do size_i <- hFileSize handle offset_i <- hTell handle >>= skipBOM handle size_i let size = min wanted (fromIntegral $ size_i-offset_i) buf <- mallocForeignPtrArray (size+3) withForeignPtr buf $ \ptr -> do r <- if size == 0 then return 0 else hGetBuf handle ptr size if r /= size then ioError (userError $ "short read of file: "++show(r,size,size_i,handle)) else newUTF8StringBuffer buf ptr size hPutStringBuffer :: Handle -> StringBuffer -> IO () hPutStringBuffer hdl (StringBuffer buf len cur) = do withForeignPtr (plusForeignPtr buf cur) $ \ptr -> hPutBuf hdl ptr len -- | Skip the byte-order mark if there is one (see #1744 and #6016), -- and return the new position of the handle in bytes. -- -- This is better than treating #FEFF as whitespace, -- because that would mess up layout. We don't have a concept -- of zero-width whitespace in Haskell: all whitespace codepoints -- have a width of one column. skipBOM :: Handle -> Integer -> Integer -> IO Integer skipBOM h size offset = -- Only skip BOM at the beginning of a file. if size > 0 && offset == 0 then do -- Validate assumption that handle is in binary mode. ASSERTM( hGetEncoding h >>= return . isNothing ) -- Temporarily select utf8 encoding with error ignoring, -- to make `hLookAhead` and `hGetChar` return full Unicode characters. bracket_ (hSetEncoding h safeEncoding) (hSetBinaryMode h True) $ do c <- hLookAhead h if c == '\xfeff' then hGetChar h >> hTell h else return offset else return offset where safeEncoding = mkUTF8 IgnoreCodingFailure newUTF8StringBuffer :: ForeignPtr Word8 -> Ptr Word8 -> Int -> IO StringBuffer newUTF8StringBuffer buf ptr size = do pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] -- sentinels for UTF-8 decoding return $ StringBuffer buf size 0 appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer appendStringBuffers sb1 sb2 = do newBuf <- mallocForeignPtrArray (size+3) withForeignPtr newBuf $ \ptr -> withForeignPtr (buf sb1) $ \sb1Ptr -> withForeignPtr (buf sb2) $ \sb2Ptr -> do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len pokeArray (ptr `advancePtr` size) [0,0,0] return (StringBuffer newBuf size 0) where sb1_len = calcLen sb1 sb2_len = calcLen sb2 calcLen sb = len sb - cur sb size = sb1_len + sb2_len -- | Encode a 'String' into a 'StringBuffer' as UTF-8. The resulting buffer -- is automatically managed by the garbage collector. stringToStringBuffer :: String -> StringBuffer stringToStringBuffer str = unsafePerformIO $ do let size = utf8EncodedLength str buf <- mallocForeignPtrArray (size+3) withForeignPtr buf $ \ptr -> do utf8EncodeString ptr str pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] -- sentinels for UTF-8 decoding return (StringBuffer buf size 0) -- ----------------------------------------------------------------------------- -- Grab a character -- | Return the first UTF-8 character of a nonempty 'StringBuffer' and as well -- the remaining portion (analogous to 'Data.List.uncons'). __Warning:__ The -- behavior is undefined if the 'StringBuffer' is empty. The result shares -- the same buffer as the original. Similar to 'utf8DecodeChar', if the -- character cannot be decoded as UTF-8, @\'\\0\'@ is returned. {-# INLINE nextChar #-} nextChar :: StringBuffer -> (Char,StringBuffer) nextChar (StringBuffer buf len (I# cur#)) = -- Getting our fingers dirty a little here, but this is performance-critical inlinePerformIO $ do withForeignPtr buf $ \(Ptr a#) -> do case utf8DecodeChar# (a# `plusAddr#` cur#) of (# c#, nBytes# #) -> let cur' = I# (cur# +# nBytes#) in return (C# c#, StringBuffer buf len cur') -- | Return the first UTF-8 character of a nonempty 'StringBuffer' (analogous -- to 'Data.List.head'). __Warning:__ The behavior is undefined if the -- 'StringBuffer' is empty. Similar to 'utf8DecodeChar', if the character -- cannot be decoded as UTF-8, @\'\\0\'@ is returned. currentChar :: StringBuffer -> Char currentChar = fst . nextChar prevChar :: StringBuffer -> Char -> Char prevChar (StringBuffer _ _ 0) deflt = deflt prevChar (StringBuffer buf _ cur) _ = inlinePerformIO $ do withForeignPtr buf $ \p -> do p' <- utf8PrevChar (p `plusPtr` cur) return (fst (utf8DecodeChar p')) -- ----------------------------------------------------------------------------- -- Moving -- | Return a 'StringBuffer' with the first UTF-8 character removed (analogous -- to 'Data.List.tail'). __Warning:__ The behavior is undefined if the -- 'StringBuffer' is empty. The result shares the same buffer as the -- original. stepOn :: StringBuffer -> StringBuffer stepOn s = snd (nextChar s) -- | Return a 'StringBuffer' with the first @n@ bytes removed. __Warning:__ -- If there aren't enough characters, the returned 'StringBuffer' will be -- invalid and any use of it may lead to undefined behavior. The result -- shares the same buffer as the original. offsetBytes :: Int -- ^ @n@, the number of bytes -> StringBuffer -> StringBuffer offsetBytes i s = s { cur = cur s + i } -- | Compute the difference in offset between two 'StringBuffer's that share -- the same buffer. __Warning:__ The behavior is undefined if the -- 'StringBuffer's use separate buffers. byteDiff :: StringBuffer -> StringBuffer -> Int byteDiff s1 s2 = cur s2 - cur s1 -- | Check whether a 'StringBuffer' is empty (analogous to 'Data.List.null'). atEnd :: StringBuffer -> Bool atEnd (StringBuffer _ l c) = l == c -- | Computes a 'StringBuffer' which points to the first character of the -- wanted line. Lines begin at 1. atLine :: Int -> StringBuffer -> Maybe StringBuffer atLine line sb@(StringBuffer buf len _) = inlinePerformIO $ withForeignPtr buf $ \p -> do p' <- skipToLine line len p if p' == nullPtr then return Nothing else let delta = p' `minusPtr` p in return $ Just (sb { cur = delta , len = len - delta }) skipToLine :: Int -> Int -> Ptr Word8 -> IO (Ptr Word8) skipToLine !line !len !op0 = go 1 op0 where !opend = op0 `plusPtr` len go !i_line !op | op >= opend = pure nullPtr | i_line == line = pure op | otherwise = do w <- peek op :: IO Word8 case w of 10 -> go (i_line + 1) (plusPtr op 1) 13 -> do -- this is safe because a 'StringBuffer' is -- guaranteed to have 3 bytes sentinel values. w' <- peek (plusPtr op 1) :: IO Word8 case w' of 10 -> go (i_line + 1) (plusPtr op 2) _ -> go (i_line + 1) (plusPtr op 1) _ -> go i_line (plusPtr op 1) -- ----------------------------------------------------------------------------- -- Conversion -- | Decode the first @n@ bytes of a 'StringBuffer' as UTF-8 into a 'String'. -- Similar to 'utf8DecodeChar', if the character cannot be decoded as UTF-8, -- they will be replaced with @\'\\0\'@. lexemeToString :: StringBuffer -> Int -- ^ @n@, the number of bytes -> String lexemeToString _ 0 = "" lexemeToString (StringBuffer buf _ cur) bytes = utf8DecodeStringLazy buf cur bytes lexemeToFastString :: StringBuffer -> Int -- ^ @n@, the number of bytes -> FastString lexemeToFastString _ 0 = nilFS lexemeToFastString (StringBuffer buf _ cur) len = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! mkFastStringBytes (ptr `plusPtr` cur) len -- | Return the previous @n@ characters (or fewer if we are less than @n@ -- characters into the buffer. decodePrevNChars :: Int -> StringBuffer -> String decodePrevNChars n (StringBuffer buf _ cur) = inlinePerformIO $ withForeignPtr buf $ \p0 -> go p0 n "" (p0 `plusPtr` (cur - 1)) where go :: Ptr Word8 -> Int -> String -> Ptr Word8 -> IO String go buf0 n acc p | n == 0 || buf0 >= p = return acc go buf0 n acc p = do p' <- utf8PrevChar p let (c,_) = utf8DecodeChar p' go buf0 (n - 1) (c:acc) p' -- ----------------------------------------------------------------------------- -- Parsing integer strings in various bases parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let go i x | i == len = x | otherwise = case fst (utf8DecodeChar (ptr `plusPtr` (cur + i))) of '_' -> go (i + 1) x -- skip "_" (#14473) char -> go (i + 1) (x * radix + toInteger (char_to_int char)) in go 0 0 ghc-lib-parser-8.10.2.20200808/compiler/main/SysTools/BaseDir.hs0000644000000000000000000001036613713635745021717 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2001-2017 -- -- Finding the compiler's base directory. -- ----------------------------------------------------------------------------- -} module SysTools.BaseDir ( expandTopDir, expandToolDir , findTopDir, findToolDir , tryFindTopDir ) where #include "GhclibHsVersions.h" import GhcPrelude -- See note [Base Dir] for why some of this logic is shared with ghc-pkg. import GHC.BaseDir import Panic import System.Environment (lookupEnv) import System.FilePath -- Windows #if defined(mingw32_HOST_OS) import System.Directory (doesDirectoryExist) #endif #if defined(mingw32_HOST_OS) # if defined(i386_HOST_ARCH) # define WINDOWS_CCONV stdcall # elif defined(x86_64_HOST_ARCH) # define WINDOWS_CCONV ccall # else # error Unknown mingw32 arch # endif #endif {- Note [topdir: How GHC finds its files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC needs various support files (library packages, RTS etc), plus various auxiliary programs (cp, gcc, etc). It starts by finding topdir, the root of GHC's support files On Unix: - ghc always has a shell wrapper that passes a -B option On Windows: - ghc never has a shell wrapper. - we can find the location of the ghc binary, which is $topdir//.exe where may be "ghc", "ghc-stage2", or similar - we strip off the "/.exe" to leave $topdir. from topdir we can find package.conf, ghc-asm, etc. Note [tooldir: How GHC finds mingw on Windows] GHC has some custom logic on Windows for finding the mingw toolchain and perl. Depending on whether GHC is built with the make build system or Hadrian, and on whether we're running a bindist, we might find the mingw toolchain and perl either under $topdir/../{mingw, perl}/ or $topdir/../../{mingw, perl}/. -} -- | Expand occurrences of the @$tooldir@ interpolation in a string -- on Windows, leave the string untouched otherwise. expandToolDir :: Maybe FilePath -> String -> String #if defined(mingw32_HOST_OS) expandToolDir (Just tool_dir) s = expandPathVar "tooldir" tool_dir s expandToolDir Nothing _ = panic "Could not determine $tooldir" #else expandToolDir _ s = s #endif -- | Returns a Unix-format path pointing to TopDir. findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). -> IO String -- TopDir (in Unix format '/' separated) findTopDir m_minusb = do maybe_exec_dir <- tryFindTopDir m_minusb case maybe_exec_dir of -- "Just" on Windows, "Nothing" on unix Nothing -> throwGhcExceptionIO $ InstallationError "missing -B option" Just dir -> return dir tryFindTopDir :: Maybe String -- ^ Maybe TopDir path (without the '-B' prefix). -> IO (Maybe String) -- ^ TopDir (in Unix format '/' separated) tryFindTopDir (Just minusb) = return $ Just $ normalise minusb tryFindTopDir Nothing = do -- The _GHC_TOP_DIR environment variable can be used to specify -- the top dir when the -B argument is not specified. It is not -- intended for use by users, it was added specifically for the -- purpose of running GHC within GHCi. maybe_env_top_dir <- lookupEnv "_GHC_TOP_DIR" case maybe_env_top_dir of Just env_top_dir -> return $ Just env_top_dir -- Try directory of executable Nothing -> getBaseDir -- See Note [tooldir: How GHC finds mingw and perl on Windows] -- Returns @Nothing@ when not on Windows. -- When called on Windows, it either throws an error when the -- tooldir can't be located, or returns @Just tooldirpath@. findToolDir :: FilePath -- ^ topdir -> IO (Maybe FilePath) #if defined(mingw32_HOST_OS) findToolDir top_dir = go 0 (top_dir "..") where maxDepth = 3 go :: Int -> FilePath -> IO (Maybe FilePath) go k path | k == maxDepth = throwGhcExceptionIO $ InstallationError "could not detect mingw toolchain" | otherwise = do oneLevel <- doesDirectoryExist (path "mingw") if oneLevel then return (Just path) else go (k+1) (path "..") #else findToolDir _ = return Nothing #endif ghc-lib-parser-8.10.2.20200808/compiler/main/SysTools/Terminal.hs0000644000000000000000000000607613713635745022164 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module SysTools.Terminal (stderrSupportsAnsiColors) where import GhcPrelude #if defined(MIN_VERSION_terminfo) import Control.Exception (catch) import Data.Maybe (fromMaybe) import System.Console.Terminfo (SetupTermError, Terminal, getCapability, setupTermFromEnv, termColors) import System.Posix (queryTerminal, stdError) #elif defined(mingw32_HOST_OS) import Control.Exception (catch, try) import Data.Bits ((.|.), (.&.)) import Foreign (Ptr, peek, with) import qualified Graphics.Win32 as Win32 import qualified System.Win32 as Win32 #endif #if defined(mingw32_HOST_OS) && !defined(WINAPI) # if defined(i386_HOST_ARCH) # define WINAPI stdcall # elif defined(x86_64_HOST_ARCH) # define WINAPI ccall # else # error unknown architecture # endif #endif -- | Check if ANSI escape sequences can be used to control color in stderr. stderrSupportsAnsiColors :: IO Bool stderrSupportsAnsiColors = do #if defined(MIN_VERSION_terminfo) queryTerminal stdError `andM` do (termSupportsColors <$> setupTermFromEnv) `catch` \ (_ :: SetupTermError) -> pure False where andM :: Monad m => m Bool -> m Bool -> m Bool andM mx my = do x <- mx if x then my else pure x termSupportsColors :: Terminal -> Bool termSupportsColors term = fromMaybe 0 (getCapability term termColors) > 0 #elif defined(mingw32_HOST_OS) h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE `catch` \ (_ :: IOError) -> pure Win32.nullHANDLE if h == Win32.nullHANDLE then pure False else do eMode <- try (getConsoleMode h) case eMode of Left (_ :: IOError) -> Win32.isMinTTYHandle h -- Check if the we're in a MinTTY terminal -- (e.g., Cygwin or MSYS2) Right mode | modeHasVTP mode -> pure True | otherwise -> enableVTP h mode where enableVTP :: Win32.HANDLE -> Win32.DWORD -> IO Bool enableVTP h mode = do setConsoleMode h (modeAddVTP mode) modeHasVTP <$> getConsoleMode h `catch` \ (_ :: IOError) -> pure False modeHasVTP :: Win32.DWORD -> Bool modeHasVTP mode = mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0 modeAddVTP :: Win32.DWORD -> Win32.DWORD modeAddVTP mode = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING eNABLE_VIRTUAL_TERMINAL_PROCESSING :: Win32.DWORD eNABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004 getConsoleMode :: Win32.HANDLE -> IO Win32.DWORD getConsoleMode h = with 64 $ \ mode -> do Win32.failIfFalse_ "GetConsoleMode" (c_GetConsoleMode h mode) peek mode setConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO () setConsoleMode h mode = do Win32.failIfFalse_ "SetConsoleMode" (c_SetConsoleMode h mode) foreign import WINAPI unsafe "windows.h GetConsoleMode" c_GetConsoleMode :: Win32.HANDLE -> Ptr Win32.DWORD -> IO Win32.BOOL foreign import WINAPI unsafe "windows.h SetConsoleMode" c_SetConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL #else pure False #endif ghc-lib-parser-8.10.2.20200808/compiler/typecheck/TcEvidence.hs0000644000000000000000000011110413713635745021643 0ustar0000000000000000-- (c) The University of Glasgow 2006 {-# LANGUAGE CPP, DeriveDataTypeable #-} module TcEvidence ( -- HsWrapper HsWrapper(..), (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpLams, mkWpLet, mkWpCastN, mkWpCastR, collectHsWrapBinders, mkWpFun, idHsWrapper, isIdHsWrapper, isErasableHsWrapper, pprHsWrapper, -- Evidence bindings TcEvBinds(..), EvBindsVar(..), EvBindMap(..), emptyEvBindMap, extendEvBinds, lookupEvBind, evBindMapBinds, foldEvBindMap, filterEvBindMap, isEmptyEvBindMap, EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, evBindVar, isCoEvBindsVar, -- EvTerm (already a CoreExpr) EvTerm(..), EvExpr, evId, evCoercion, evCast, evDFunApp, evDataConApp, evSelector, mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars, evTermCoercion, evTermCoercion_maybe, EvCallStack(..), EvTypeable(..), -- TcCoercion TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole, TcMCoercion, Role(..), LeftOrRight(..), pickLR, mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo, mkTcTyConAppCo, mkTcAppCo, mkTcFunCo, mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos, mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSubCo, tcDowngradeRole, mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflLeftCo, mkTcPhantomCo, mkTcCoherenceLeftCo, mkTcCoherenceRightCo, mkTcKindCo, tcCoercionKind, coVarsOfTcCo, mkTcCoVarCo, isTcReflCo, isTcReflexiveCo, isTcGReflMCo, tcCoToMCo, tcCoercionRole, unwrapIP, wrapIP ) where #include "GhclibHsVersions.h" import GhcPrelude import Var import CoAxiom import Coercion import PprCore () -- Instance OutputableBndr TyVar import TcType import Type import TyCon import DataCon( DataCon, dataConWrapId ) import Class( Class ) import PrelNames import DynFlags ( gopt, GeneralFlag(Opt_PrintTypecheckerElaboration) ) import VarEnv import VarSet import Predicate import Name import Pair import CoreSyn import Class ( classSCSelId ) import CoreFVs ( exprSomeFreeVars ) import Util import Bag import qualified Data.Data as Data import Outputable import SrcLoc import Data.IORef( IORef ) import UniqSet {- Note [TcCoercions] ~~~~~~~~~~~~~~~~~~ | TcCoercions are a hack used by the typechecker. Normally, Coercions have free variables of type (a ~# b): we call these CoVars. However, the type checker passes around equality evidence (boxed up) at type (a ~ b). An TcCoercion is simply a Coercion whose free variables have may be either boxed or unboxed. After we are done with typechecking the desugarer finds the boxed free variables, unboxes them, and creates a resulting real Coercion with kosher free variables. -} type TcCoercion = Coercion type TcCoercionN = CoercionN -- A Nominal coercion ~N type TcCoercionR = CoercionR -- A Representational coercion ~R type TcCoercionP = CoercionP -- a phantom coercion type TcMCoercion = MCoercion mkTcReflCo :: Role -> TcType -> TcCoercion mkTcSymCo :: TcCoercion -> TcCoercion mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion mkTcNomReflCo :: TcType -> TcCoercionN mkTcRepReflCo :: TcType -> TcCoercionR mkTcTyConAppCo :: Role -> TyCon -> [TcCoercion] -> TcCoercion mkTcAppCo :: TcCoercion -> TcCoercionN -> TcCoercion mkTcFunCo :: Role -> TcCoercion -> TcCoercion -> TcCoercion mkTcAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [TcType] -> [TcCoercion] -> TcCoercion mkTcUnbranchedAxInstCo :: CoAxiom Unbranched -> [TcType] -> [TcCoercion] -> TcCoercionR mkTcForAllCo :: TyVar -> TcCoercionN -> TcCoercion -> TcCoercion mkTcForAllCos :: [(TyVar, TcCoercionN)] -> TcCoercion -> TcCoercion mkTcNthCo :: Role -> Int -> TcCoercion -> TcCoercion mkTcLRCo :: LeftOrRight -> TcCoercion -> TcCoercion mkTcSubCo :: TcCoercionN -> TcCoercionR tcDowngradeRole :: Role -> Role -> TcCoercion -> TcCoercion mkTcAxiomRuleCo :: CoAxiomRule -> [TcCoercion] -> TcCoercionR mkTcGReflRightCo :: Role -> TcType -> TcCoercionN -> TcCoercion mkTcGReflLeftCo :: Role -> TcType -> TcCoercionN -> TcCoercion mkTcCoherenceLeftCo :: Role -> TcType -> TcCoercionN -> TcCoercion -> TcCoercion mkTcCoherenceRightCo :: Role -> TcType -> TcCoercionN -> TcCoercion -> TcCoercion mkTcPhantomCo :: TcCoercionN -> TcType -> TcType -> TcCoercionP mkTcKindCo :: TcCoercion -> TcCoercionN mkTcCoVarCo :: CoVar -> TcCoercion tcCoercionKind :: TcCoercion -> Pair TcType tcCoercionRole :: TcCoercion -> Role coVarsOfTcCo :: TcCoercion -> TcTyCoVarSet isTcReflCo :: TcCoercion -> Bool isTcGReflMCo :: TcMCoercion -> Bool -- | This version does a slow check, calculating the related types and seeing -- if they are equal. isTcReflexiveCo :: TcCoercion -> Bool mkTcReflCo = mkReflCo mkTcSymCo = mkSymCo mkTcTransCo = mkTransCo mkTcNomReflCo = mkNomReflCo mkTcRepReflCo = mkRepReflCo mkTcTyConAppCo = mkTyConAppCo mkTcAppCo = mkAppCo mkTcFunCo = mkFunCo mkTcAxInstCo = mkAxInstCo mkTcUnbranchedAxInstCo = mkUnbranchedAxInstCo Representational mkTcForAllCo = mkForAllCo mkTcForAllCos = mkForAllCos mkTcNthCo = mkNthCo mkTcLRCo = mkLRCo mkTcSubCo = mkSubCo tcDowngradeRole = downgradeRole mkTcAxiomRuleCo = mkAxiomRuleCo mkTcGReflRightCo = mkGReflRightCo mkTcGReflLeftCo = mkGReflLeftCo mkTcCoherenceLeftCo = mkCoherenceLeftCo mkTcCoherenceRightCo = mkCoherenceRightCo mkTcPhantomCo = mkPhantomCo mkTcKindCo = mkKindCo mkTcCoVarCo = mkCoVarCo tcCoercionKind = coercionKind tcCoercionRole = coercionRole coVarsOfTcCo = coVarsOfCo isTcReflCo = isReflCo isTcGReflMCo = isGReflMCo isTcReflexiveCo = isReflexiveCo tcCoToMCo :: TcCoercion -> TcMCoercion tcCoToMCo = coToMCo -- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing. -- Note that the input coercion should always be nominal. maybeTcSubCo :: EqRel -> TcCoercion -> TcCoercion maybeTcSubCo NomEq = id maybeTcSubCo ReprEq = mkTcSubCo {- %************************************************************************ %* * HsWrapper * * ************************************************************************ -} data HsWrapper = WpHole -- The identity coercion | WpCompose HsWrapper HsWrapper -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]] -- -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) -- But ([] a) `WpCompose` ([] b) = ([] b a) | WpFun HsWrapper HsWrapper TcType SDoc -- (WpFun wrap1 wrap2 t1)[e] = \(x:t1). wrap2[ e wrap1[x] ] -- So note that if wrap1 :: exp_arg <= act_arg -- wrap2 :: act_res <= exp_res -- then WpFun wrap1 wrap2 : (act_arg -> arg_res) <= (exp_arg -> exp_res) -- This isn't the same as for mkFunCo, but it has to be this way -- because we can't use 'sym' to flip around these HsWrappers -- The TcType is the "from" type of the first wrapper -- The SDoc explains the circumstances under which we have created this -- WpFun, in case we run afoul of levity polymorphism restrictions in -- the desugarer. See Note [Levity polymorphism checking] in DsMonad | WpCast TcCoercionR -- A cast: [] `cast` co -- Guaranteed not the identity coercion -- At role Representational -- Evidence abstraction and application -- (both dictionaries and coercions) | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint -- Kind and Type abstraction and application | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var) | WpTyApp KindOrType -- [] t the 't' is a type (not coercion) | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, -- so that the identity coercion is always exactly WpHole -- Cannot derive Data instance because SDoc is not Data (it stores a function). -- So we do it manually: instance Data.Data HsWrapper where gfoldl _ z WpHole = z WpHole gfoldl k z (WpCompose a1 a2) = z WpCompose `k` a1 `k` a2 gfoldl k z (WpFun a1 a2 a3 _) = z wpFunEmpty `k` a1 `k` a2 `k` a3 gfoldl k z (WpCast a1) = z WpCast `k` a1 gfoldl k z (WpEvLam a1) = z WpEvLam `k` a1 gfoldl k z (WpEvApp a1) = z WpEvApp `k` a1 gfoldl k z (WpTyLam a1) = z WpTyLam `k` a1 gfoldl k z (WpTyApp a1) = z WpTyApp `k` a1 gfoldl k z (WpLet a1) = z WpLet `k` a1 gunfold k z c = case Data.constrIndex c of 1 -> z WpHole 2 -> k (k (z WpCompose)) 3 -> k (k (k (z wpFunEmpty))) 4 -> k (z WpCast) 5 -> k (z WpEvLam) 6 -> k (z WpEvApp) 7 -> k (z WpTyLam) 8 -> k (z WpTyApp) _ -> k (z WpLet) toConstr WpHole = wpHole_constr toConstr (WpCompose _ _) = wpCompose_constr toConstr (WpFun _ _ _ _) = wpFun_constr toConstr (WpCast _) = wpCast_constr toConstr (WpEvLam _) = wpEvLam_constr toConstr (WpEvApp _) = wpEvApp_constr toConstr (WpTyLam _) = wpTyLam_constr toConstr (WpTyApp _) = wpTyApp_constr toConstr (WpLet _) = wpLet_constr dataTypeOf _ = hsWrapper_dataType hsWrapper_dataType :: Data.DataType hsWrapper_dataType = Data.mkDataType "HsWrapper" [ wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr , wpEvLam_constr, wpEvApp_constr, wpTyLam_constr, wpTyApp_constr , wpLet_constr] wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr, wpEvLam_constr, wpEvApp_constr, wpTyLam_constr, wpTyApp_constr, wpLet_constr :: Data.Constr wpHole_constr = mkHsWrapperConstr "WpHole" wpCompose_constr = mkHsWrapperConstr "WpCompose" wpFun_constr = mkHsWrapperConstr "WpFun" wpCast_constr = mkHsWrapperConstr "WpCast" wpEvLam_constr = mkHsWrapperConstr "WpEvLam" wpEvApp_constr = mkHsWrapperConstr "WpEvApp" wpTyLam_constr = mkHsWrapperConstr "WpTyLam" wpTyApp_constr = mkHsWrapperConstr "WpTyApp" wpLet_constr = mkHsWrapperConstr "WpLet" mkHsWrapperConstr :: String -> Data.Constr mkHsWrapperConstr name = Data.mkConstr hsWrapper_dataType name [] Data.Prefix wpFunEmpty :: HsWrapper -> HsWrapper -> TcType -> HsWrapper wpFunEmpty c1 c2 t1 = WpFun c1 c2 t1 empty (<.>) :: HsWrapper -> HsWrapper -> HsWrapper WpHole <.> c = c c <.> WpHole = c c1 <.> c2 = c1 `WpCompose` c2 mkWpFun :: HsWrapper -> HsWrapper -> TcType -- the "from" type of the first wrapper -> TcType -- either type of the second wrapper (used only when the -- second wrapper is the identity) -> SDoc -- what caused you to want a WpFun? Something like "When converting ..." -> HsWrapper mkWpFun WpHole WpHole _ _ _ = WpHole mkWpFun WpHole (WpCast co2) t1 _ _ = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2) mkWpFun (WpCast co1) WpHole _ t2 _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2)) mkWpFun (WpCast co1) (WpCast co2) _ _ _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2) mkWpFun co1 co2 t1 _ d = WpFun co1 co2 t1 d mkWpCastR :: TcCoercionR -> HsWrapper mkWpCastR co | isTcReflCo co = WpHole | otherwise = ASSERT2(tcCoercionRole co == Representational, ppr co) WpCast co mkWpCastN :: TcCoercionN -> HsWrapper mkWpCastN co | isTcReflCo co = WpHole | otherwise = ASSERT2(tcCoercionRole co == Nominal, ppr co) WpCast (mkTcSubCo co) -- The mkTcSubCo converts Nominal to Representational mkWpTyApps :: [Type] -> HsWrapper mkWpTyApps tys = mk_co_app_fn WpTyApp tys mkWpEvApps :: [EvTerm] -> HsWrapper mkWpEvApps args = mk_co_app_fn WpEvApp args mkWpEvVarApps :: [EvVar] -> HsWrapper mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map (EvExpr . evId) vs) mkWpTyLams :: [TyVar] -> HsWrapper mkWpTyLams ids = mk_co_lam_fn WpTyLam ids mkWpLams :: [Var] -> HsWrapper mkWpLams ids = mk_co_lam_fn WpEvLam ids mkWpLet :: TcEvBinds -> HsWrapper -- This no-op is a quite a common case mkWpLet (EvBinds b) | isEmptyBag b = WpHole mkWpLet ev_binds = WpLet ev_binds mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper -- For applications, the *first* argument must -- come *last* in the composition sequence mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as idHsWrapper :: HsWrapper idHsWrapper = WpHole isIdHsWrapper :: HsWrapper -> Bool isIdHsWrapper WpHole = True isIdHsWrapper _ = False -- | Is the wrapper erasable, i.e., will not affect runtime semantics? isErasableHsWrapper :: HsWrapper -> Bool isErasableHsWrapper = go where go WpHole = True go (WpCompose wrap1 wrap2) = go wrap1 && go wrap2 -- not so sure about WpFun. But it eta-expands, so... go WpFun{} = False go WpCast{} = True go WpEvLam{} = False -- case in point go WpEvApp{} = False go WpTyLam{} = True go WpTyApp{} = True go WpLet{} = False collectHsWrapBinders :: HsWrapper -> ([Var], HsWrapper) -- Collect the outer lambda binders of a HsWrapper, -- stopping as soon as you get to a non-lambda binder collectHsWrapBinders wrap = go wrap [] where -- go w ws = collectHsWrapBinders (w <.> w1 <.> ... <.> wn) go :: HsWrapper -> [HsWrapper] -> ([Var], HsWrapper) go (WpEvLam v) wraps = add_lam v (gos wraps) go (WpTyLam v) wraps = add_lam v (gos wraps) go (WpCompose w1 w2) wraps = go w1 (w2:wraps) go wrap wraps = ([], foldl' (<.>) wrap wraps) gos [] = ([], WpHole) gos (w:ws) = go w ws add_lam v (vs,w) = (v:vs, w) {- ************************************************************************ * * Evidence bindings * * ************************************************************************ -} data TcEvBinds = TcEvBinds -- Mutable evidence bindings EvBindsVar -- Mutable because they are updated "later" -- when an implication constraint is solved | EvBinds -- Immutable after zonking (Bag EvBind) data EvBindsVar = EvBindsVar { ebv_uniq :: Unique, -- The Unique is for debug printing only ebv_binds :: IORef EvBindMap, -- The main payload: the value-level evidence bindings -- (dictionaries etc) -- Some Given, some Wanted ebv_tcvs :: IORef CoVarSet -- The free Given coercion vars needed by Wanted coercions that -- are solved by filling in their HoleDest in-place. Since they -- don't appear in ebv_binds, we keep track of their free -- variables so that we can report unused given constraints -- See Note [Tracking redundant constraints] in TcSimplify } | CoEvBindsVar { -- See Note [Coercion evidence only] -- See above for comments on ebv_uniq, ebv_tcvs ebv_uniq :: Unique, ebv_tcvs :: IORef CoVarSet } instance Data.Data TcEvBinds where -- Placeholder; we can't travers into TcEvBinds toConstr _ = abstractConstr "TcEvBinds" gunfold _ _ = error "gunfold" dataTypeOf _ = Data.mkNoRepType "TcEvBinds" {- Note [Coercion evidence only] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Class constraints etc give rise to /term/ bindings for evidence, and we have nowhere to put term bindings in /types/. So in some places we use CoEvBindsVar (see newCoTcEvBinds) to signal that no term-level evidence bindings are allowed. Notebly (): - Places in types where we are solving kind constraints (all of which are equalities); see solveEqualities, solveLocalEqualities - When unifying forall-types -} isCoEvBindsVar :: EvBindsVar -> Bool isCoEvBindsVar (CoEvBindsVar {}) = True isCoEvBindsVar (EvBindsVar {}) = False ----------------- newtype EvBindMap = EvBindMap { ev_bind_varenv :: DVarEnv EvBind } -- Map from evidence variables to evidence terms -- We use @DVarEnv@ here to get deterministic ordering when we -- turn it into a Bag. -- If we don't do that, when we generate let bindings for -- dictionaries in dsTcEvBinds they will be generated in random -- order. -- -- For example: -- -- let $dEq = GHC.Classes.$fEqInt in -- let $$dNum = GHC.Num.$fNumInt in ... -- -- vs -- -- let $dNum = GHC.Num.$fNumInt in -- let $dEq = GHC.Classes.$fEqInt in ... -- -- See Note [Deterministic UniqFM] in UniqDFM for explanation why -- @UniqFM@ can lead to nondeterministic order. emptyEvBindMap :: EvBindMap emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyDVarEnv } extendEvBinds :: EvBindMap -> EvBind -> EvBindMap extendEvBinds bs ev_bind = EvBindMap { ev_bind_varenv = extendDVarEnv (ev_bind_varenv bs) (eb_lhs ev_bind) ev_bind } isEmptyEvBindMap :: EvBindMap -> Bool isEmptyEvBindMap (EvBindMap m) = isEmptyDVarEnv m lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind lookupEvBind bs = lookupDVarEnv (ev_bind_varenv bs) evBindMapBinds :: EvBindMap -> Bag EvBind evBindMapBinds = foldEvBindMap consBag emptyBag foldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a foldEvBindMap k z bs = foldDVarEnv k z (ev_bind_varenv bs) filterEvBindMap :: (EvBind -> Bool) -> EvBindMap -> EvBindMap filterEvBindMap k (EvBindMap { ev_bind_varenv = env }) = EvBindMap { ev_bind_varenv = filterDVarEnv k env } instance Outputable EvBindMap where ppr (EvBindMap m) = ppr m ----------------- -- All evidence is bound by EvBinds; no side effects data EvBind = EvBind { eb_lhs :: EvVar , eb_rhs :: EvTerm , eb_is_given :: Bool -- True <=> given -- See Note [Tracking redundant constraints] in TcSimplify } evBindVar :: EvBind -> EvVar evBindVar = eb_lhs mkWantedEvBind :: EvVar -> EvTerm -> EvBind mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm } -- EvTypeable are never given, so we can work with EvExpr here instead of EvTerm mkGivenEvBind :: EvVar -> EvTerm -> EvBind mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm } -- An EvTerm is, conceptually, a CoreExpr that implements the constraint. -- Unfortunately, we cannot just do -- type EvTerm = CoreExpr -- Because of staging problems issues around EvTypeable data EvTerm = EvExpr EvExpr | EvTypeable Type EvTypeable -- Dictionary for (Typeable ty) | EvFun -- /\as \ds. let binds in v { et_tvs :: [TyVar] , et_given :: [EvVar] , et_binds :: TcEvBinds -- This field is why we need an EvFun -- constructor, and can't just use EvExpr , et_body :: EvVar } deriving Data.Data type EvExpr = CoreExpr -- An EvTerm is (usually) constructed by any of the constructors here -- and those more complicates ones who were moved to module TcEvTerm -- | Any sort of evidence Id, including coercions evId :: EvId -> EvExpr evId = Var -- coercion bindings -- See Note [Coercion evidence terms] evCoercion :: TcCoercion -> EvTerm evCoercion co = EvExpr (Coercion co) -- | d |> co evCast :: EvExpr -> TcCoercion -> EvTerm evCast et tc | isReflCo tc = EvExpr et | otherwise = EvExpr (Cast et tc) -- Dictionary instance application evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm evDFunApp df tys ets = EvExpr $ Var df `mkTyApps` tys `mkApps` ets evDataConApp :: DataCon -> [Type] -> [EvExpr] -> EvTerm evDataConApp dc tys ets = evDFunApp (dataConWrapId dc) tys ets -- Selector id plus the types at which it -- should be instantiated, used for HasField -- dictionaries; see Note [HasField instances] -- in TcInterface evSelector :: Id -> [Type] -> [EvExpr] -> EvExpr evSelector sel_id tys tms = Var sel_id `mkTyApps` tys `mkApps` tms -- Dictionary for (Typeable ty) evTypeable :: Type -> EvTypeable -> EvTerm evTypeable = EvTypeable -- | Instructions on how to make a 'Typeable' dictionary. -- See Note [Typeable evidence terms] data EvTypeable = EvTypeableTyCon TyCon [EvTerm] -- ^ Dictionary for @Typeable T@ where @T@ is a type constructor with all of -- its kind variables saturated. The @[EvTerm]@ is @Typeable@ evidence for -- the applied kinds.. | EvTypeableTyApp EvTerm EvTerm -- ^ Dictionary for @Typeable (s t)@, -- given a dictionaries for @s@ and @t@. | EvTypeableTrFun EvTerm EvTerm -- ^ Dictionary for @Typeable (s -> t)@, -- given a dictionaries for @s@ and @t@. | EvTypeableTyLit EvTerm -- ^ Dictionary for a type literal, -- e.g. @Typeable "foo"@ or @Typeable 3@ -- The 'EvTerm' is evidence of, e.g., @KnownNat 3@ -- (see #10348) deriving Data.Data -- | Evidence for @CallStack@ implicit parameters. data EvCallStack -- See Note [Overview of implicit CallStacks] = EvCsEmpty | EvCsPushCall Name RealSrcSpan EvExpr -- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at -- @loc@, in a calling context @stk@. deriving Data.Data {- Note [Typeable evidence terms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The EvTypeable data type looks isomorphic to Type, but the EvTerms inside can be EvIds. Eg f :: forall a. Typeable a => a -> TypeRep f x = typeRep (undefined :: Proxy [a]) Here for the (Typeable [a]) dictionary passed to typeRep we make evidence dl :: Typeable [a] = EvTypeable [a] (EvTypeableTyApp (EvTypeableTyCon []) (EvId d)) where d :: Typable a is the lambda-bound dictionary passed into f. Note [Coercion evidence terms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A "coercion evidence term" takes one of these forms co_tm ::= EvId v where v :: t1 ~# t2 | EvCoercion co | EvCast co_tm co We do quite often need to get a TcCoercion from an EvTerm; see 'evTermCoercion'. INVARIANT: The evidence for any constraint with type (t1 ~# t2) is a coercion evidence term. Consider for example [G] d :: F Int a If we have ax7 a :: F Int a ~ (a ~ Bool) then we do NOT generate the constraint [G] (d |> ax7 a) :: a ~ Bool because that does not satisfy the invariant (d is not a coercion variable). Instead we make a binding g1 :: a~Bool = g |> ax7 a and the constraint [G] g1 :: a~Bool See #7238 and Note [Bind new Givens immediately] in Constraint Note [EvBinds/EvTerm] ~~~~~~~~~~~~~~~~~~~~~ How evidence is created and updated. Bindings for dictionaries, and coercions and implicit parameters are carried around in TcEvBinds which during constraint generation and simplification is always of the form (TcEvBinds ref). After constraint simplification is finished it will be transformed to t an (EvBinds ev_bag). Evidence for coercions *SHOULD* be filled in using the TcEvBinds However, all EvVars that correspond to *wanted* coercion terms in an EvBind must be mutable variables so that they can be readily inlined (by zonking) after constraint simplification is finished. Conclusion: a new wanted coercion variable should be made mutable. [Notice though that evidence variables that bind coercion terms from super classes will be "given" and hence rigid] Note [Overview of implicit CallStacks] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (See https://gitlab.haskell.org/ghc/ghc/wikis/explicit-call-stack/implicit-locations) The goal of CallStack evidence terms is to reify locations in the program source as runtime values, without any support from the RTS. We accomplish this by assigning a special meaning to constraints of type GHC.Stack.Types.HasCallStack, an alias type HasCallStack = (?callStack :: CallStack) Implicit parameters of type GHC.Stack.Types.CallStack (the name is not important) are solved in three steps: 1. Occurrences of CallStack IPs are solved directly from the given IP, just like a regular IP. For example, the occurrence of `?stk` in error :: (?stk :: CallStack) => String -> a error s = raise (ErrorCall (s ++ prettyCallStack ?stk)) will be solved for the `?stk` in `error`s context as before. 2. In a function call, instead of simply passing the given IP, we first append the current call-site to it. For example, consider a call to the callstack-aware `error` above. undefined :: (?stk :: CallStack) => a undefined = error "undefined!" Here we want to take the given `?stk` and append the current call-site, before passing it to `error`. In essence, we want to rewrite `error "undefined!"` to let ?stk = pushCallStack ?stk in error "undefined!" We achieve this effect by emitting a NEW wanted [W] d :: IP "stk" CallStack from which we build the evidence term EvCsPushCall "error" (EvId d) that we use to solve the call to `error`. The new wanted `d` will then be solved per rule (1), ie as a regular IP. (see TcInteract.interactDict) 3. We default any insoluble CallStacks to the empty CallStack. Suppose `undefined` did not request a CallStack, ie undefinedNoStk :: a undefinedNoStk = error "undefined!" Under the usual IP rules, the new wanted from rule (2) would be insoluble as there's no given IP from which to solve it, so we would get an "unbound implicit parameter" error. We don't ever want to emit an insoluble CallStack IP, so we add a defaulting pass to default any remaining wanted CallStacks to the empty CallStack with the evidence term EvCsEmpty (see TcSimplify.simpl_top and TcSimplify.defaultCallStacks) This provides a lightweight mechanism for building up call-stacks explicitly, but is notably limited by the fact that the stack will stop at the first function whose type does not include a CallStack IP. For example, using the above definition of `undefined`: head :: [a] -> a head [] = undefined head (x:_) = x g = head [] the resulting CallStack will include the call to `undefined` in `head` and the call to `error` in `undefined`, but *not* the call to `head` in `g`, because `head` did not explicitly request a CallStack. Important Details: - GHC should NEVER report an insoluble CallStack constraint. - GHC should NEVER infer a CallStack constraint unless one was requested with a partial type signature (See TcType.pickQuantifiablePreds). - A CallStack (defined in GHC.Stack.Types) is a [(String, SrcLoc)], where the String is the name of the binder that is used at the SrcLoc. SrcLoc is also defined in GHC.Stack.Types and contains the package/module/file name, as well as the full source-span. Both CallStack and SrcLoc are kept abstract so only GHC can construct new values. - We will automatically solve any wanted CallStack regardless of the name of the IP, i.e. f = show (?stk :: CallStack) g = show (?loc :: CallStack) are both valid. However, we will only push new SrcLocs onto existing CallStacks when the IP names match, e.g. in head :: (?loc :: CallStack) => [a] -> a head [] = error (show (?stk :: CallStack)) the printed CallStack will NOT include head's call-site. This reflects the standard scoping rules of implicit-parameters. - An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`. The desugarer will need to unwrap the IP newtype before pushing a new call-site onto a given stack (See DsBinds.dsEvCallStack) - When we emit a new wanted CallStack from rule (2) we set its origin to `IPOccOrigin ip_name` instead of the original `OccurrenceOf func` (see TcInteract.interactDict). This is a bit shady, but is how we ensure that the new wanted is solved like a regular IP. -} mkEvCast :: EvExpr -> TcCoercion -> EvTerm mkEvCast ev lco | ASSERT2( tcCoercionRole lco == Representational , (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco])) isTcReflCo lco = EvExpr ev | otherwise = evCast ev lco mkEvScSelectors -- Assume class (..., D ty, ...) => C a b :: Class -> [TcType] -- C ty1 ty2 -> [(TcPredType, -- D ty[ty1/a,ty2/b] EvExpr) -- :: C ty1 ty2 -> D ty[ty1/a,ty2/b] ] mkEvScSelectors cls tys = zipWith mk_pr (immSuperClasses cls tys) [0..] where mk_pr pred i = (pred, Var sc_sel_id `mkTyApps` tys) where sc_sel_id = classSCSelId cls i -- Zero-indexed emptyTcEvBinds :: TcEvBinds emptyTcEvBinds = EvBinds emptyBag isEmptyTcEvBinds :: TcEvBinds -> Bool isEmptyTcEvBinds (EvBinds b) = isEmptyBag b isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" evTermCoercion_maybe :: EvTerm -> Maybe TcCoercion -- Applied only to EvTerms of type (s~t) -- See Note [Coercion evidence terms] evTermCoercion_maybe ev_term | EvExpr e <- ev_term = go e | otherwise = Nothing where go :: EvExpr -> Maybe TcCoercion go (Var v) = return (mkCoVarCo v) go (Coercion co) = return co go (Cast tm co) = do { co' <- go tm ; return (mkCoCast co' co) } go _ = Nothing evTermCoercion :: EvTerm -> TcCoercion evTermCoercion tm = case evTermCoercion_maybe tm of Just co -> co Nothing -> pprPanic "evTermCoercion" (ppr tm) {- ********************************************************************* * * Free variables * * ********************************************************************* -} findNeededEvVars :: EvBindMap -> VarSet -> VarSet -- Find all the Given evidence needed by seeds, -- looking transitively through binds findNeededEvVars ev_binds seeds = transCloVarSet also_needs seeds where also_needs :: VarSet -> VarSet also_needs needs = nonDetFoldUniqSet add emptyVarSet needs -- It's OK to use nonDetFoldUFM here because we immediately -- forget about the ordering by creating a set add :: Var -> VarSet -> VarSet add v needs | Just ev_bind <- lookupEvBind ev_binds v , EvBind { eb_is_given = is_given, eb_rhs = rhs } <- ev_bind , is_given = evVarsOfTerm rhs `unionVarSet` needs | otherwise = needs evVarsOfTerm :: EvTerm -> VarSet evVarsOfTerm (EvExpr e) = exprSomeFreeVars isEvVar e evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev evVarsOfTerm (EvFun {}) = emptyVarSet -- See Note [Free vars of EvFun] evVarsOfTerms :: [EvTerm] -> VarSet evVarsOfTerms = mapUnionVarSet evVarsOfTerm evVarsOfTypeable :: EvTypeable -> VarSet evVarsOfTypeable ev = case ev of EvTypeableTyCon _ e -> mapUnionVarSet evVarsOfTerm e EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2] EvTypeableTrFun e1 e2 -> evVarsOfTerms [e1,e2] EvTypeableTyLit e -> evVarsOfTerm e {- Note [Free vars of EvFun] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Finding the free vars of an EvFun is made tricky by the fact the bindings et_binds may be a mutable variable. Fortunately, we can just squeeze by. Here's how. * evVarsOfTerm is used only by TcSimplify.neededEvVars. * Each EvBindsVar in an et_binds field of an EvFun is /also/ in the ic_binds field of an Implication * So we can track usage via the processing for that implication, (see Note [Tracking redundant constraints] in TcSimplify). We can ignore usage from the EvFun altogether. ************************************************************************ * * Pretty printing * * ************************************************************************ -} instance Outputable HsWrapper where ppr co_fn = pprHsWrapper co_fn (no_parens (text "<>")) pprHsWrapper :: HsWrapper -> (Bool -> SDoc) -> SDoc -- With -fprint-typechecker-elaboration, print the wrapper -- otherwise just print what's inside -- The pp_thing_inside function takes Bool to say whether -- it's in a position that needs parens for a non-atomic thing pprHsWrapper wrap pp_thing_inside = sdocWithDynFlags $ \ dflags -> if gopt Opt_PrintTypecheckerElaboration dflags then help pp_thing_inside wrap False else pp_thing_inside False where help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc -- True <=> appears in function application position -- False <=> appears as body of let or lambda help it WpHole = it help it (WpCompose f1 f2) = help (help it f2) f1 help it (WpFun f1 f2 t1 _) = add_parens $ text "\\(x" <> dcolon <> ppr t1 <> text ")." <+> help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" <+> pprParendCo co)] help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <+> pprParendType ty] help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pprLamBndr id <> dot, it False] help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pprLamBndr tv <> dot, it False] help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] pprLamBndr :: Id -> SDoc pprLamBndr v = pprBndr LambdaBind v add_parens, no_parens :: SDoc -> Bool -> SDoc add_parens d True = parens d add_parens d False = d no_parens d _ = d instance Outputable TcEvBinds where ppr (TcEvBinds v) = ppr v ppr (EvBinds bs) = text "EvBinds" <> braces (vcat (map ppr (bagToList bs))) instance Outputable EvBindsVar where ppr (EvBindsVar { ebv_uniq = u }) = text "EvBindsVar" <> angleBrackets (ppr u) ppr (CoEvBindsVar { ebv_uniq = u }) = text "CoEvBindsVar" <> angleBrackets (ppr u) instance Uniquable EvBindsVar where getUnique = ebv_uniq instance Outputable EvBind where ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_is_given = is_given }) = sep [ pp_gw <+> ppr v , nest 2 $ equals <+> ppr e ] where pp_gw = brackets (if is_given then char 'G' else char 'W') -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing instance Outputable EvTerm where ppr (EvExpr e) = ppr e ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty ppr (EvFun { et_tvs = tvs, et_given = gs, et_binds = bs, et_body = w }) = hang (text "\\" <+> sep (map pprLamBndr (tvs ++ gs)) <+> arrow) 2 (ppr bs $$ ppr w) -- Not very pretty instance Outputable EvCallStack where ppr EvCsEmpty = text "[]" ppr (EvCsPushCall name loc tm) = ppr (name,loc) <+> text ":" <+> ppr tm instance Outputable EvTypeable where ppr (EvTypeableTyCon ts _) = text "TyCon" <+> ppr ts ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) ppr (EvTypeableTrFun t1 t2) = parens (ppr t1 <+> arrow <+> ppr t2) ppr (EvTypeableTyLit t1) = text "TyLit" <> ppr t1 ---------------------------------------------------------------------- -- Helper functions for dealing with IP newtype-dictionaries ---------------------------------------------------------------------- -- | Create a 'Coercion' that unwraps an implicit-parameter or -- overloaded-label dictionary to expose the underlying value. We -- expect the 'Type' to have the form `IP sym ty` or `IsLabel sym ty`, -- and return a 'Coercion' `co :: IP sym ty ~ ty` or -- `co :: IsLabel sym ty ~ Proxy# sym -> ty`. See also -- Note [Type-checking overloaded labels] in TcExpr. unwrapIP :: Type -> CoercionR unwrapIP ty = case unwrapNewTyCon_maybe tc of Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys [] Nothing -> pprPanic "unwrapIP" $ text "The dictionary for" <+> quotes (ppr tc) <+> text "is not a newtype!" where (tc, tys) = splitTyConApp ty -- | Create a 'Coercion' that wraps a value in an implicit-parameter -- dictionary. See 'unwrapIP'. wrapIP :: Type -> CoercionR wrapIP ty = mkSymCo (unwrapIP ty) ghc-lib-parser-8.10.2.20200808/compiler/typecheck/TcHoleFitTypes.hs0000644000000000000000000001246713713635745022514 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} module TcHoleFitTypes ( TypedHole (..), HoleFit (..), HoleFitCandidate (..), CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..), hfIsLcl, pprHoleFitCand ) where import GhcPrelude import TcRnTypes import Constraint import TcType import RdrName import GHC.Hs.Doc import Id import Outputable import Name import Data.Function ( on ) data TypedHole = TyH { tyHRelevantCts :: Cts -- ^ Any relevant Cts to the hole , tyHImplics :: [Implication] -- ^ The nested implications of the hole with the -- innermost implication first. , tyHCt :: Maybe Ct -- ^ The hole constraint itself, if available. } instance Outputable TypedHole where ppr (TyH rels implics ct) = hang (text "TypedHole") 2 (ppr rels $+$ ppr implics $+$ ppr ct) -- | HoleFitCandidates are passed to hole fit plugins and then -- checked whether they fit a given typed-hole. data HoleFitCandidate = IdHFCand Id -- An id, like locals. | NameHFCand Name -- A name, like built-in syntax. | GreHFCand GlobalRdrElt -- A global, like imported ids. deriving (Eq) instance Outputable HoleFitCandidate where ppr = pprHoleFitCand pprHoleFitCand :: HoleFitCandidate -> SDoc pprHoleFitCand (IdHFCand cid) = text "Id HFC: " <> ppr cid pprHoleFitCand (NameHFCand cname) = text "Name HFC: " <> ppr cname pprHoleFitCand (GreHFCand cgre) = text "Gre HFC: " <> ppr cgre instance NamedThing HoleFitCandidate where getName hfc = case hfc of IdHFCand cid -> idName cid NameHFCand cname -> cname GreHFCand cgre -> gre_name cgre getOccName hfc = case hfc of IdHFCand cid -> occName cid NameHFCand cname -> occName cname GreHFCand cgre -> occName (gre_name cgre) instance HasOccName HoleFitCandidate where occName = getOccName instance Ord HoleFitCandidate where compare = compare `on` getName -- | HoleFit is the type we use for valid hole fits. It contains the -- element that was checked, the Id of that element as found by `tcLookup`, -- and the refinement level of the fit, which is the number of extra argument -- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`). data HoleFit = HoleFit { hfId :: Id -- ^ The elements id in the TcM , hfCand :: HoleFitCandidate -- ^ The candidate that was checked. , hfType :: TcType -- ^ The type of the id, possibly zonked. , hfRefLvl :: Int -- ^ The number of holes in this fit. , hfWrap :: [TcType] -- ^ The wrapper for the match. , hfMatches :: [TcType] -- ^ What the refinement variables got matched with, if anything , hfDoc :: Maybe HsDocString -- ^ Documentation of this HoleFit, if available. } | RawHoleFit SDoc -- ^ A fit that is just displayed as is. Here so thatHoleFitPlugins -- can inject any fit they want. -- We define an Eq and Ord instance to be able to build a graph. instance Eq HoleFit where (==) = (==) `on` hfId instance Outputable HoleFit where ppr (RawHoleFit sd) = sd ppr (HoleFit _ cand ty _ _ mtchs _) = hang (name <+> holes) 2 (text "where" <+> name <+> dcolon <+> (ppr ty)) where name = ppr $ getName cand holes = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) mtchs -- We compare HoleFits by their name instead of their Id, since we don't -- want our tests to be affected by the non-determinism of `nonDetCmpVar`, -- which is used to compare Ids. When comparing, we want HoleFits with a lower -- refinement level to come first. instance Ord HoleFit where compare (RawHoleFit _) (RawHoleFit _) = EQ compare (RawHoleFit _) _ = LT compare _ (RawHoleFit _) = GT compare a@(HoleFit {}) b@(HoleFit {}) = cmp a b where cmp = if hfRefLvl a == hfRefLvl b then compare `on` (getName . hfCand) else compare `on` hfRefLvl hfIsLcl :: HoleFit -> Bool hfIsLcl hf@(HoleFit {}) = case hfCand hf of IdHFCand _ -> True NameHFCand _ -> False GreHFCand gre -> gre_lcl gre hfIsLcl _ = False -- | A plugin for modifying the candidate hole fits *before* they're checked. type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate] -- | A plugin for modifying hole fits *after* they've been found. type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit] -- | A HoleFitPlugin is a pair of candidate and fit plugins. data HoleFitPlugin = HoleFitPlugin { candPlugin :: CandPlugin , fitPlugin :: FitPlugin } -- | HoleFitPluginR adds a TcRef to hole fit plugins so that plugins can -- track internal state. Note the existential quantification, ensuring that -- the state cannot be modified from outside the plugin. data HoleFitPluginR = forall s. HoleFitPluginR { hfPluginInit :: TcM (TcRef s) -- ^ Initializes the TcRef to be passed to the plugin , hfPluginRun :: TcRef s -> HoleFitPlugin -- ^ The function defining the plugin itself , hfPluginStop :: TcRef s -> TcM () -- ^ Cleanup of state, guaranteed to be called even on error } ghc-lib-parser-8.10.2.20200808/compiler/typecheck/TcOrigin.hs0000644000000000000000000007510713713635745021364 0ustar0000000000000000{- Describes the provenance of types as they flow through the type-checker. The datatypes here are mainly used for error message generation. -} {-# LANGUAGE CPP #-} module TcOrigin ( -- UserTypeCtxt UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe, -- SkolemInfo SkolemInfo(..), pprSigSkolInfo, pprSkolInfo, -- CtOrigin CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, isVisibleOrigin, toInvisibleOrigin, pprCtOrigin, isGivenOrigin ) where #include "GhclibHsVersions.h" import GhcPrelude import TcType import GHC.Hs import Id import DataCon import ConLike import TyCon import InstEnv import PatSyn import Module import Name import RdrName import qualified GHC.LanguageExtensions as LangExt import DynFlags import SrcLoc import FastString import Outputable import BasicTypes {- ********************************************************************* * * UserTypeCtxt * * ********************************************************************* -} ------------------------------------- -- | UserTypeCtxt describes the origin of the polymorphic type -- in the places where we need an expression to have that type data UserTypeCtxt = FunSigCtxt -- Function type signature, when checking the type -- Also used for types in SPECIALISE pragmas Name -- Name of the function Bool -- True <=> report redundant constraints -- This is usually True, but False for -- * Record selectors (not important here) -- * Class and instance methods. Here -- the code may legitimately be more -- polymorphic than the signature -- generated from the class -- declaration | InfSigCtxt Name -- Inferred type for function | ExprSigCtxt -- Expression type signature | KindSigCtxt -- Kind signature | StandaloneKindSigCtxt -- Standalone kind signature Name -- Name of the type/class | TypeAppCtxt -- Visible type application | ConArgCtxt Name -- Data constructor argument | TySynCtxt Name -- RHS of a type synonym decl | PatSynCtxt Name -- Type sig for a pattern synonym | PatSigCtxt -- Type sig in pattern -- eg f (x::t) = ... -- or (x::t, y) = e | RuleSigCtxt Name -- LHS of a RULE forall -- RULE "foo" forall (x :: a -> a). f (Just x) = ... | ResSigCtxt -- Result type sig -- f x :: t = .... | ForSigCtxt Name -- Foreign import or export signature | DefaultDeclCtxt -- Types in a default declaration | InstDeclCtxt Bool -- An instance declaration -- True: stand-alone deriving -- False: vanilla instance declaration | SpecInstCtxt -- SPECIALISE instance pragma | ThBrackCtxt -- Template Haskell type brackets [t| ... |] | GenSigCtxt -- Higher-rank or impredicative situations -- e.g. (f e) where f has a higher-rank type -- We might want to elaborate this | GhciCtxt Bool -- GHCi command :kind -- The Bool indicates if we are checking the outermost -- type application. -- See Note [Unsaturated type synonyms in GHCi] in -- TcValidity. | ClassSCCtxt Name -- Superclasses of a class | SigmaCtxt -- Theta part of a normal for-all type -- f :: => a -> a | DataTyCtxt Name -- The "stupid theta" part of a data decl -- data => T a = MkT a | DerivClauseCtxt -- A 'deriving' clause | TyVarBndrKindCtxt Name -- The kind of a type variable being bound | DataKindCtxt Name -- The kind of a data/newtype (instance) | TySynKindCtxt Name -- The kind of the RHS of a type synonym | TyFamResKindCtxt Name -- The result kind of a type family {- -- Notes re TySynCtxt -- We allow type synonyms that aren't types; e.g. type List = [] -- -- If the RHS mentions tyvars that aren't in scope, we'll -- quantify over them: -- e.g. type T = a->a -- will become type T = forall a. a->a -- -- With gla-exts that's right, but for H98 we should complain. -} pprUserTypeCtxt :: UserTypeCtxt -> SDoc pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) pprUserTypeCtxt (RuleSigCtxt n) = text "a RULE for" <+> quotes (ppr n) pprUserTypeCtxt ExprSigCtxt = text "an expression type signature" pprUserTypeCtxt KindSigCtxt = text "a kind signature" pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n) pprUserTypeCtxt TypeAppCtxt = text "a type argument" pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c) pprUserTypeCtxt (TySynCtxt c) = text "the RHS of the type synonym" <+> quotes (ppr c) pprUserTypeCtxt ThBrackCtxt = text "a Template Haskell quotation [t|...|]" pprUserTypeCtxt PatSigCtxt = text "a pattern type signature" pprUserTypeCtxt ResSigCtxt = text "a result type signature" pprUserTypeCtxt (ForSigCtxt n) = text "the foreign declaration for" <+> quotes (ppr n) pprUserTypeCtxt DefaultDeclCtxt = text "a type in a `default' declaration" pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration" pprUserTypeCtxt (InstDeclCtxt True) = text "a stand-alone deriving instance declaration" pprUserTypeCtxt SpecInstCtxt = text "a SPECIALISE instance pragma" pprUserTypeCtxt GenSigCtxt = text "a type expected by the context" pprUserTypeCtxt (GhciCtxt {}) = text "a type in a GHCi command" pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c) pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type" pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc) pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n) pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause" pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n) pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n) isSigMaybe :: UserTypeCtxt -> Maybe Name isSigMaybe (FunSigCtxt n _) = Just n isSigMaybe (ConArgCtxt n) = Just n isSigMaybe (ForSigCtxt n) = Just n isSigMaybe (PatSynCtxt n) = Just n isSigMaybe _ = Nothing {- ************************************************************************ * * SkolemInfo * * ************************************************************************ -} -- SkolemInfo gives the origin of *given* constraints -- a) type variables are skolemised -- b) an implication constraint is generated data SkolemInfo = SigSkol -- A skolem that is created by instantiating -- a programmer-supplied type signature -- Location of the binding site is on the TyVar -- See Note [SigSkol SkolemInfo] UserTypeCtxt -- What sort of signature TcType -- Original type signature (before skolemisation) [(Name,TcTyVar)] -- Maps the original name of the skolemised tyvar -- to its instantiated version | SigTypeSkol UserTypeCtxt -- like SigSkol, but when we're kind-checking the *type* -- hence, we have less info | ForAllSkol SDoc -- Bound by a user-written "forall". | DerivSkol Type -- Bound by a 'deriving' clause; -- the type is the instance we are trying to derive | InstSkol -- Bound at an instance decl | InstSC TypeSize -- A "given" constraint obtained by superclass selection. -- If (C ty1 .. tyn) is the largest class from -- which we made a superclass selection in the chain, -- then TypeSize = sizeTypes [ty1, .., tyn] -- See Note [Solving superclass constraints] in TcInstDcls | FamInstSkol -- Bound at a family instance decl | PatSkol -- An existential type variable bound by a pattern for ConLike -- a data constructor with an existential type. (HsMatchContext Name) -- e.g. data T = forall a. Eq a => MkT a -- f (MkT x) = ... -- The pattern MkT x will allocate an existential type -- variable for 'a'. | ArrowSkol -- An arrow form (see TcArrows) | IPSkol [HsIPName] -- Binding site of an implicit parameter | RuleSkol RuleName -- The LHS of a RULE | InferSkol [(Name,TcType)] -- We have inferred a type for these (mutually-recursivive) -- polymorphic Ids, and are now checking that their RHS -- constraints are satisfied. | BracketSkol -- Template Haskell bracket | UnifyForAllSkol -- We are unifying two for-all types TcType -- The instantiated type *inside* the forall | TyConSkol TyConFlavour Name -- bound in a type declaration of the given flavour | DataConSkol Name -- bound as an existential in a Haskell98 datacon decl or -- as any variable in a GADT datacon decl | ReifySkol -- Bound during Template Haskell reification | QuantCtxtSkol -- Quantified context, e.g. -- f :: forall c. (forall a. c a => c [a]) => blah | UnkSkol -- Unhelpful info (until I improve it) instance Outputable SkolemInfo where ppr = pprSkolInfo pprSkolInfo :: SkolemInfo -> SDoc -- Complete the sentence "is a rigid type variable bound by..." pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx pprSkolInfo (ForAllSkol doc) = quotes doc pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for" <+> pprWithCommas ppr ips pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) pprSkolInfo InstSkol = text "the instance declaration" pprSkolInfo (InstSC n) = text "the instance declaration" <> whenPprDebug (parens (ppr n)) pprSkolInfo FamInstSkol = text "a family instance declaration" pprSkolInfo BracketSkol = text "a Template Haskell bracket" pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name pprSkolInfo ArrowSkol = text "an arrow form" pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl , text "in" <+> pprMatchContext mc ] pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of") 2 (vcat [ ppr name <+> dcolon <+> ppr ty | (name,ty) <- ids ]) pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty pprSkolInfo (TyConSkol flav name) = text "the" <+> ppr flav <+> text "declaration for" <+> quotes (ppr name) pprSkolInfo (DataConSkol name)= text "the data constructor" <+> quotes (ppr name) pprSkolInfo ReifySkol = text "the type being reified" pprSkolInfo (QuantCtxtSkol {}) = text "a quantified context" -- UnkSkol -- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol" pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc -- The type is already tidied pprSigSkolInfo ctxt ty = case ctxt of FunSigCtxt f _ -> vcat [ text "the type signature for:" , nest 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) ] PatSynCtxt {} -> pprUserTypeCtxt ctxt -- See Note [Skolem info for pattern synonyms] _ -> vcat [ pprUserTypeCtxt ctxt <> colon , nest 2 (ppr ty) ] pprPatSkolInfo :: ConLike -> SDoc pprPatSkolInfo (RealDataCon dc) = sep [ text "a pattern with constructor:" , nest 2 $ ppr dc <+> dcolon <+> pprType (dataConUserType dc) <> comma ] -- pprType prints forall's regardless of -fprint-explicit-foralls -- which is what we want here, since we might be saying -- type variable 't' is bound by ... pprPatSkolInfo (PatSynCon ps) = sep [ text "a pattern with pattern synonym:" , nest 2 $ ppr ps <+> dcolon <+> pprPatSynType ps <> comma ] {- Note [Skolem info for pattern synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For pattern synonym SkolemInfo we have SigSkol (PatSynCtxt p) ty _ but the type 'ty' is not very helpful. The full pattern-synonym type has the provided and required pieces, which it is inconvenient to record and display here. So we simply don't display the type at all, contenting outselves with just the name of the pattern synonym, which is fine. We could do more, but it doesn't seem worth it. Note [SigSkol SkolemInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we (deeply) skolemise a type f :: forall a. a -> forall b. b -> a Then we'll instantiate [a :-> a', b :-> b'], and with the instantiated a' -> b' -> a. But when, in an error message, we report that "b is a rigid type variable bound by the type signature for f", we want to show the foralls in the right place. So we proceed as follows: * In SigSkol we record - the original signature forall a. a -> forall b. b -> a - the instantiation mapping [a :-> a', b :-> b'] * Then when tidying in TcMType.tidySkolemInfo, we first tidy a' to whatever it tidies to, say a''; and then we walk over the type replacing the binder a by the tidied version a'', to give forall a''. a'' -> forall b''. b'' -> a'' We need to do this under function arrows, to match what deeplySkolemise does. * Typically a'' will have a nice pretty name like "a", but the point is that the foral-bound variables of the signature we report line up with the instantiated skolems lying around in other types. ************************************************************************ * * CtOrigin * * ************************************************************************ -} data CtOrigin = GivenOrigin SkolemInfo -- All the others are for *wanted* constraints | OccurrenceOf Name -- Occurrence of an overloaded identifier | OccurrenceOfRecSel RdrName -- Occurrence of a record selector | AppOrigin -- An application of some kind | SpecPragOrigin UserTypeCtxt -- Specialisation pragma for -- function or instance | TypeEqOrigin { uo_actual :: TcType , uo_expected :: TcType , uo_thing :: Maybe SDoc -- ^ The thing that has type "actual" , uo_visible :: Bool -- ^ Is at least one of the three elements above visible? -- (Errors from the polymorphic subsumption check are considered -- visible.) Only used for prioritizing error messages. } | KindEqOrigin -- See Note [Equalities with incompatible kinds] in TcCanonical. TcType (Maybe TcType) -- A kind equality arising from unifying these two types CtOrigin -- originally arising from this (Maybe TypeOrKind) -- the level of the eq this arises from | IPOccOrigin HsIPName -- Occurrence of an implicit parameter | OverLabelOrigin FastString -- Occurrence of an overloaded label | LiteralOrigin (HsOverLit GhcRn) -- Occurrence of a literal | NegateOrigin -- Occurrence of syntactic negation | ArithSeqOrigin (ArithSeqInfo GhcRn) -- [x..], [x..y] etc | AssocFamPatOrigin -- When matching the patterns of an associated -- family instance with that of its parent class | SectionOrigin | TupleOrigin -- (..,..) | ExprSigOrigin -- e :: ty | PatSigOrigin -- p :: ty | PatOrigin -- Instantiating a polytyped pattern at a constructor | ProvCtxtOrigin -- The "provided" context of a pattern synonym signature (PatSynBind GhcRn GhcRn) -- Information about the pattern synonym, in -- particular the name and the right-hand side | RecordUpdOrigin | ViewPatOrigin | ScOrigin TypeSize -- Typechecking superclasses of an instance declaration -- If the instance head is C ty1 .. tyn -- then TypeSize = sizeTypes [ty1, .., tyn] -- See Note [Solving superclass constraints] in TcInstDcls | DerivClauseOrigin -- Typechecking a deriving clause (as opposed to -- standalone deriving). | DerivOriginDC DataCon Int Bool -- Checking constraints arising from this data con and field index. The -- Bool argument in DerivOriginDC and DerivOriginCoerce is True if -- standalong deriving (with a wildcard constraint) is being used. This -- is used to inform error messages on how to recommended fixes (e.g., if -- the argument is True, then don't recommend "use standalone deriving", -- but rather "fill in the wildcard constraint yourself"). -- See Note [Inferring the instance context] in TcDerivInfer | DerivOriginCoerce Id Type Type Bool -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from -- `ty1` to `ty2`. | StandAloneDerivOrigin -- Typechecking stand-alone deriving. Useful for -- constraints coming from a wildcard constraint, -- e.g., deriving instance _ => Eq (Foo a) -- See Note [Inferring the instance context] -- in TcDerivInfer | DefaultOrigin -- Typechecking a default decl | DoOrigin -- Arising from a do expression | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in -- a do expression | MCompOrigin -- Arising from a monad comprehension | MCompPatOrigin (LPat GhcRn) -- Arising from a failable pattern in a -- monad comprehension | IfOrigin -- Arising from an if statement | ProcOrigin -- Arising from a proc expression | AnnOrigin -- An annotation | FunDepOrigin1 -- A functional dependency from combining PredType CtOrigin RealSrcSpan -- This constraint arising from ... PredType CtOrigin RealSrcSpan -- and this constraint arising from ... | FunDepOrigin2 -- A functional dependency from combining PredType CtOrigin -- This constraint arising from ... PredType SrcSpan -- and this top-level instance -- We only need a CtOrigin on the first, because the location -- is pinned on the entire error message | HoleOrigin | UnboundOccurrenceOf OccName | ListOrigin -- An overloaded list | StaticOrigin -- A static form | FailablePattern (LPat GhcTcId) -- A failable pattern in do-notation for the -- MonadFail Proposal (MFP). Obsolete when -- actual desugaring to MonadFail.fail is -- live. | Shouldn'tHappenOrigin String -- the user should never see this one, -- unless ImpredicativeTypes is on, where all -- bets are off | InstProvidedOrigin Module ClsInst -- Skolem variable arose when we were testing if an instance -- is solvable or not. -- An origin is visible if the place where the constraint arises is manifest -- in user code. Currently, all origins are visible except for invisible -- TypeEqOrigins. This is used when choosing which error of -- several to report isVisibleOrigin :: CtOrigin -> Bool isVisibleOrigin (TypeEqOrigin { uo_visible = vis }) = vis isVisibleOrigin (KindEqOrigin _ _ sub_orig _) = isVisibleOrigin sub_orig isVisibleOrigin _ = True -- Converts a visible origin to an invisible one, if possible. Currently, -- this works only for TypeEqOrigin toInvisibleOrigin :: CtOrigin -> CtOrigin toInvisibleOrigin orig@(TypeEqOrigin {}) = orig { uo_visible = False } toInvisibleOrigin orig = orig isGivenOrigin :: CtOrigin -> Bool isGivenOrigin (GivenOrigin {}) = True isGivenOrigin (FunDepOrigin1 _ o1 _ _ o2 _) = isGivenOrigin o1 && isGivenOrigin o2 isGivenOrigin (FunDepOrigin2 _ o1 _ _) = isGivenOrigin o1 isGivenOrigin _ = False instance Outputable CtOrigin where ppr = pprCtOrigin ctoHerald :: SDoc ctoHerald = text "arising from" -- | Extract a suitable CtOrigin from a HsExpr lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin lexprCtOrigin (L _ e) = exprCtOrigin e exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name exprCtOrigin (HsUnboundVar _ uv) = UnboundOccurrenceOf (unboundVarOcc uv) exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) exprCtOrigin (HsOverLabel _ _ l) = OverLabelOrigin l exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" exprCtOrigin (HsLam _ matches) = matchesCtOrigin matches exprCtOrigin (HsLamCase _ ms) = matchesCtOrigin ms exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1 exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op exprCtOrigin (NegApp _ e _) = lexprCtOrigin e exprCtOrigin (HsPar _ e) = lexprCtOrigin e exprCtOrigin (SectionL _ _ _) = SectionOrigin exprCtOrigin (SectionR _ _ _) = SectionOrigin exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches exprCtOrigin (HsIf _ (Just syn) _ _ _) = exprCtOrigin (syn_expr syn) exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e exprCtOrigin (HsDo {}) = DoOrigin exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list" exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update" exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" exprCtOrigin (HsSCC _ _ _ e) = lexprCtOrigin e exprCtOrigin (HsCoreAnn _ _ _ e) = lexprCtOrigin e exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket" exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut" exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut" exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice" exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e exprCtOrigin (HsTickPragma _ _ _ _ e) = lexprCtOrigin e exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap" exprCtOrigin (XExpr nec) = noExtCon nec -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin matchesCtOrigin (MG { mg_alts = alts }) | L _ [L _ match] <- alts , Match { m_grhss = grhss } <- match = grhssCtOrigin grhss | otherwise = Shouldn'tHappenOrigin "multi-way match" matchesCtOrigin (XMatchGroup nec) = noExtCon nec -- | Extract a suitable CtOrigin from guarded RHSs grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss grhssCtOrigin (XGRHSs nec) = noExtCon nec -- | Extract a suitable CtOrigin from a list of guarded RHSs lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e lGRHSCtOrigin [L _ (XGRHS nec)] = noExtCon nec lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS" pprCtOrigin :: CtOrigin -> SDoc -- "arising from ..." -- Not an instance of Outputable because of the "arising from" prefix pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk pprCtOrigin (SpecPragOrigin ctxt) = case ctxt of FunSigCtxt n _ -> text "for" <+> quotes (ppr n) SpecInstCtxt -> text "a SPECIALISE INSTANCE pragma" _ -> text "a SPECIALISE pragma" -- Never happens I think pprCtOrigin (FunDepOrigin1 pred1 orig1 loc1 pred2 orig2 loc2) = hang (ctoHerald <+> text "a functional dependency between constraints:") 2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtOrigin orig1 <+> text "at" <+> ppr loc1) , hang (quotes (ppr pred2)) 2 (pprCtOrigin orig2 <+> text "at" <+> ppr loc2) ]) pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2) = hang (ctoHerald <+> text "a functional dependency between:") 2 (vcat [ hang (text "constraint" <+> quotes (ppr pred1)) 2 (pprCtOrigin orig1 ) , hang (text "instance" <+> quotes (ppr pred2)) 2 (text "at" <+> ppr loc2) ]) pprCtOrigin (KindEqOrigin t1 (Just t2) _ _) = hang (ctoHerald <+> text "a kind equality arising from") 2 (sep [ppr t1, char '~', ppr t2]) pprCtOrigin AssocFamPatOrigin = text "when matching a family LHS with its class instance head" pprCtOrigin (KindEqOrigin t1 Nothing _ _) = hang (ctoHerald <+> text "a kind equality when matching") 2 (ppr t1) pprCtOrigin (UnboundOccurrenceOf name) = ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name) pprCtOrigin (DerivOriginDC dc n _) = hang (ctoHerald <+> text "the" <+> speakNth n <+> text "field of" <+> quotes (ppr dc)) 2 (parens (text "type" <+> quotes (ppr ty))) where ty = dataConOrigArgTys dc !! (n-1) pprCtOrigin (DerivOriginCoerce meth ty1 ty2 _) = hang (ctoHerald <+> text "the coercion of the method" <+> quotes (ppr meth)) 2 (sep [ text "from type" <+> quotes (ppr ty1) , nest 2 $ text "to type" <+> quotes (ppr ty2) ]) pprCtOrigin (DoPatOrigin pat) = ctoHerald <+> text "a do statement" $$ text "with the failable pattern" <+> quotes (ppr pat) pprCtOrigin (MCompPatOrigin pat) = ctoHerald <+> hsep [ text "the failable pattern" , quotes (ppr pat) , text "in a statement in a monad comprehension" ] pprCtOrigin (FailablePattern pat) = ctoHerald <+> text "the failable pattern" <+> quotes (ppr pat) $$ text "(this will become an error in a future GHC release)" pprCtOrigin (Shouldn'tHappenOrigin note) = sdocWithDynFlags $ \dflags -> if xopt LangExt.ImpredicativeTypes dflags then text "a situation created by impredicative types" else vcat [ text "<< This should not appear in error messages. If you see this" , text "in an error message, please report a bug mentioning" <+> quotes (text note) <+> text "at" , text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>" ] pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) }) = hang (ctoHerald <+> text "the \"provided\" constraints claimed by") 2 (text "the signature of" <+> quotes (ppr name)) pprCtOrigin (InstProvidedOrigin mod cls_inst) = vcat [ text "arising when attempting to show that" , ppr cls_inst , text "is provided by" <+> quotes (ppr mod)] pprCtOrigin simple_origin = ctoHerald <+> pprCtO simple_origin -- | Short one-liners pprCtO :: CtOrigin -> SDoc pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] pprCtO AppOrigin = text "an application" pprCtO (IPOccOrigin name) = hsep [text "a use of implicit parameter", quotes (ppr name)] pprCtO (OverLabelOrigin l) = hsep [text "the overloaded label" ,quotes (char '#' <> ppr l)] pprCtO RecordUpdOrigin = text "a record update" pprCtO ExprSigOrigin = text "an expression type signature" pprCtO PatSigOrigin = text "a pattern type signature" pprCtO PatOrigin = text "a pattern" pprCtO ViewPatOrigin = text "a view pattern" pprCtO IfOrigin = text "an if expression" pprCtO (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)] pprCtO (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)] pprCtO SectionOrigin = text "an operator section" pprCtO AssocFamPatOrigin = text "the LHS of a famly instance" pprCtO TupleOrigin = text "a tuple" pprCtO NegateOrigin = text "a use of syntactic negation" pprCtO (ScOrigin n) = text "the superclasses of an instance declaration" <> whenPprDebug (parens (ppr n)) pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration" pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" pprCtO DefaultOrigin = text "a 'default' declaration" pprCtO DoOrigin = text "a do statement" pprCtO MCompOrigin = text "a statement in a monad comprehension" pprCtO ProcOrigin = text "a proc expression" pprCtO (TypeEqOrigin t1 t2 _ _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2] pprCtO AnnOrigin = text "an annotation" pprCtO HoleOrigin = text "a use of" <+> quotes (text "_") pprCtO ListOrigin = text "an overloaded list" pprCtO StaticOrigin = text "a static form" pprCtO _ = panic "pprCtOrigin" ghc-lib-parser-8.10.2.20200808/compiler/typecheck/TcRnTypes.hs0000644000000000000000000021162013713635745021531 0ustar0000000000000000{- (c) The University of Glasgow 2006-2012 (c) The GRASP Project, Glasgow University, 1992-2002 Various types used during typechecking, please see TcRnMonad as well for operations on these types. You probably want to import it, instead of this module. All the monads exported here are built on top of the same IOEnv monad. The monad functions like a Reader monad in the way it passes the environment around. This is done to allow the environment to be manipulated in a stack like fashion when entering expressions... etc. For state that is global and should be returned at the end (e.g not part of the stack mechanism), you should use a TcRef (= IORef) to store them. -} {-# LANGUAGE CPP, DeriveFunctor, ExistentialQuantification, GeneralizedNewtypeDeriving, ViewPatterns #-} module TcRnTypes( TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module TcRef, -- The environment types Env(..), TcGblEnv(..), TcLclEnv(..), setLclEnvTcLevel, getLclEnvTcLevel, setLclEnvLoc, getLclEnvLoc, IfGblEnv(..), IfLclEnv(..), tcVisibleOrphanMods, -- Frontend types (shouldn't really be here) FrontendResult(..), -- Renamer types ErrCtxt, RecFieldEnv, pushErrCtxt, pushErrCtxtSameOrigin, ImportAvails(..), emptyImportAvails, plusImportAvails, WhereFrom(..), mkModDeps, modDepsElts, -- Typechecker types TcTypeEnv, TcBinderStack, TcBinder(..), TcTyThing(..), PromotionErr(..), IdBindingInfo(..), ClosedTypeId, RhsNames, IsGroupClosed(..), SelfBootInfo(..), pprTcTyThingCategory, pprPECategory, CompleteMatch(..), -- Desugaring types DsM, DsLclEnv(..), DsGblEnv(..), DsMetaEnv, DsMetaVal(..), CompleteMatchMap, mkCompleteMatchMap, extendCompleteMatchMap, -- Template Haskell ThStage(..), SpliceType(..), PendingStuff(..), topStage, topAnnStage, topSpliceStage, ThLevel, impLevel, outerLevel, thLevel, ForeignSrcLang(..), -- Arrows ArrowCtxt(..), -- TcSigInfo TcSigFun, TcSigInfo(..), TcIdSigInfo(..), TcIdSigInst(..), TcPatSynInfo(..), isPartialSig, hasCompleteSig, -- Misc other types TcId, TcIdSet, Hole(..), holeOcc, NameShape(..), removeBindingShadowing, -- Constraint solver plugins TcPlugin(..), TcPluginResult(..), TcPluginSolver, TcPluginM, runTcPluginM, unsafeTcPluginTcM, getEvBindsTcPluginM, -- Role annotations RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv, lookupRoleAnnot, getRoleAnnots ) where #include "GhclibHsVersions.h" import GhcPrelude import GHC.Hs import HscTypes import TcEvidence import Type import TyCon ( TyCon, tyConKind ) import PatSyn ( PatSyn ) import Id ( idType, idName ) import FieldLabel ( FieldLabel ) import TcType import Constraint import TcOrigin import Annotations import InstEnv import FamInstEnv import {-# SOURCE #-} GHC.HsToCore.PmCheck.Types (Delta) import IOEnv import RdrName import Name import NameEnv import NameSet import Avail import Var import VarEnv import Module import SrcLoc import VarSet import ErrUtils import UniqFM import BasicTypes import Bag import DynFlags import Outputable import ListSetOps import Fingerprint import Util import PrelNames ( isUnboundName ) import CostCentreState import Control.Monad (ap) import qualified Control.Monad.Fail as MonadFail import Data.Set ( Set ) import qualified Data.Set as S import Data.List ( sort ) import Data.Map ( Map ) import Data.Dynamic ( Dynamic ) import Data.Typeable ( TypeRep ) import Data.Maybe ( mapMaybe ) import GHCi.Message import GHCi.RemoteTypes import {-# SOURCE #-} TcHoleFitTypes ( HoleFitPlugin ) import qualified Language.Haskell.TH as TH -- | A 'NameShape' is a substitution on 'Name's that can be used -- to refine the identities of a hole while we are renaming interfaces -- (see 'RnModIface'). Specifically, a 'NameShape' for -- 'ns_module_name' @A@, defines a mapping from @{A.T}@ -- (for some 'OccName' @T@) to some arbitrary other 'Name'. -- -- The most intruiging thing about a 'NameShape', however, is -- how it's constructed. A 'NameShape' is *implied* by the -- exported 'AvailInfo's of the implementor of an interface: -- if an implementor of signature @@ exports @M.T@, you implicitly -- define a substitution from @{H.T}@ to @M.T@. So a 'NameShape' -- is computed from the list of 'AvailInfo's that are exported -- by the implementation of a module, or successively merged -- together by the export lists of signatures which are joining -- together. -- -- It's not the most obvious way to go about doing this, but it -- does seem to work! -- -- NB: Can't boot this and put it in NameShape because then we -- start pulling in too many DynFlags things. data NameShape = NameShape { ns_mod_name :: ModuleName, ns_exports :: [AvailInfo], ns_map :: OccEnv Name } {- ************************************************************************ * * Standard monad definition for TcRn All the combinators for the monad can be found in TcRnMonad * * ************************************************************************ The monad itself has to be defined here, because it is mentioned by ErrCtxt -} type TcRnIf a b = IOEnv (Env a b) type TcRn = TcRnIf TcGblEnv TcLclEnv -- Type inference type IfM lcl = TcRnIf IfGblEnv lcl -- Iface stuff type IfG = IfM () -- Top level type IfL = IfM IfLclEnv -- Nested type DsM = TcRnIf DsGblEnv DsLclEnv -- Desugaring -- TcRn is the type-checking and renaming monad: the main monad that -- most type-checking takes place in. The global environment is -- 'TcGblEnv', which tracks all of the top-level type-checking -- information we've accumulated while checking a module, while the -- local environment is 'TcLclEnv', which tracks local information as -- we move inside expressions. -- | Historical "renaming monad" (now it's just 'TcRn'). type RnM = TcRn -- | Historical "type-checking monad" (now it's just 'TcRn'). type TcM = TcRn -- We 'stack' these envs through the Reader like monad infrastructure -- as we move into an expression (although the change is focused in -- the lcl type). data Env gbl lcl = Env { env_top :: !HscEnv, -- Top-level stuff that never changes -- Includes all info about imported things -- BangPattern is to fix leak, see #15111 env_um :: !Char, -- Mask for Uniques env_gbl :: gbl, -- Info about things defined at the top level -- of the module being compiled env_lcl :: lcl -- Nested stuff; changes as we go into } instance ContainsDynFlags (Env gbl lcl) where extractDynFlags env = hsc_dflags (env_top env) instance ContainsModule gbl => ContainsModule (Env gbl lcl) where extractModule env = extractModule (env_gbl env) {- ************************************************************************ * * The interface environments Used when dealing with IfaceDecls * * ************************************************************************ -} data IfGblEnv = IfGblEnv { -- Some information about where this environment came from; -- useful for debugging. if_doc :: SDoc, -- The type environment for the module being compiled, -- in case the interface refers back to it via a reference that -- was originally a hi-boot file. -- We need the module name so we can test when it's appropriate -- to look in this env. -- See Note [Tying the knot] in TcIface if_rec_types :: Maybe (Module, IfG TypeEnv) -- Allows a read effect, so it can be in a mutable -- variable; c.f. handling the external package type env -- Nothing => interactive stuff, no loops possible } data IfLclEnv = IfLclEnv { -- The module for the current IfaceDecl -- So if we see f = \x -> x -- it means M.f = \x -> x, where M is the if_mod -- NB: This is a semantic module, see -- Note [Identity versus semantic module] if_mod :: Module, -- Whether or not the IfaceDecl came from a boot -- file or not; we'll use this to choose between -- NoUnfolding and BootUnfolding if_boot :: Bool, -- The field is used only for error reporting -- if (say) there's a Lint error in it if_loc :: SDoc, -- Where the interface came from: -- .hi file, or GHCi state, or ext core -- plus which bit is currently being examined if_nsubst :: Maybe NameShape, -- This field is used to make sure "implicit" declarations -- (anything that cannot be exported in mi_exports) get -- wired up correctly in typecheckIfacesForMerging. Most -- of the time it's @Nothing@. See Note [Resolving never-exported Names in TcIface] -- in TcIface. if_implicits_env :: Maybe TypeEnv, if_tv_env :: FastStringEnv TyVar, -- Nested tyvar bindings if_id_env :: FastStringEnv Id -- Nested id binding } {- ************************************************************************ * * Desugarer monad * * ************************************************************************ Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around a @UniqueSupply@ and some annotations, which presumably include source-file location information: -} data DsGblEnv = DsGblEnv { ds_mod :: Module -- For SCC profiling , ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env , ds_unqual :: PrintUnqualified , ds_msgs :: IORef Messages -- Warning messages , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, -- possibly-imported things , ds_complete_matches :: CompleteMatchMap -- Additional complete pattern matches , ds_cc_st :: IORef CostCentreState -- Tracking indices for cost centre annotations } instance ContainsModule DsGblEnv where extractModule = ds_mod data DsLclEnv = DsLclEnv { dsl_meta :: DsMetaEnv, -- Template Haskell bindings dsl_loc :: RealSrcSpan, -- To put in pattern-matching error msgs -- See Note [Note [Type and Term Equality Propagation] in Check.hs -- The oracle state Delta is augmented as we walk inwards, -- through each pattern match in turn dsl_delta :: Delta } -- Inside [| |] brackets, the desugarer looks -- up variables in the DsMetaEnv type DsMetaEnv = NameEnv DsMetaVal data DsMetaVal = DsBound Id -- Bound by a pattern inside the [| |]. -- Will be dynamically alpha renamed. -- The Id has type THSyntax.Var | DsSplice (HsExpr GhcTc) -- These bindings are introduced by -- the PendingSplices on a HsBracketOut {- ************************************************************************ * * Global typechecker environment * * ************************************************************************ -} -- | 'FrontendResult' describes the result of running the -- frontend of a Haskell module. Usually, you'll get -- a 'FrontendTypecheck', since running the frontend involves -- typechecking a program, but for an hs-boot merge you'll -- just get a ModIface, since no actual typechecking occurred. -- -- This data type really should be in HscTypes, but it needs -- to have a TcGblEnv which is only defined here. data FrontendResult = FrontendTypecheck TcGblEnv -- Note [Identity versus semantic module] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- When typechecking an hsig file, it is convenient to keep track -- of two different "this module" identifiers: -- -- - The IDENTITY module is simply thisPackage + the module -- name; i.e. it uniquely *identifies* the interface file -- we're compiling. For example, p[A=]:A is an -- identity module identifying the requirement named A -- from library p. -- -- - The SEMANTIC module, which is the actual module that -- this signature is intended to represent (e.g. if -- we have a identity module p[A=base:Data.IORef]:A, -- then the semantic module is base:Data.IORef) -- -- Which one should you use? -- -- - In the desugarer and later phases of compilation, -- identity and semantic modules coincide, since we never compile -- signatures (we just generate blank object files for -- hsig files.) -- -- A corrolary of this is that the following invariant holds at any point -- past desugaring, -- -- if I have a Module, this_mod, in hand representing the module -- currently being compiled, -- then moduleUnitId this_mod == thisPackage dflags -- -- - For any code involving Names, we want semantic modules. -- See lookupIfaceTop in IfaceEnv, mkIface and addFingerprints -- in MkIface, and tcLookupGlobal in TcEnv -- -- - When reading interfaces, we want the identity module to -- identify the specific interface we want (such interfaces -- should never be loaded into the EPS). However, if a -- hole module is requested, we look for A.hi -- in the home library we are compiling. (See LoadIface.) -- Similarly, in RnNames we check for self-imports using -- identity modules, to allow signatures to import their implementor. -- -- - For recompilation avoidance, you want the identity module, -- since that will actually say the specific interface you -- want to track (and recompile if it changes) -- | 'TcGblEnv' describes the top-level of the module at the -- point at which the typechecker is finished work. -- It is this structure that is handed on to the desugarer -- For state that needs to be updated during the typechecking -- phase and returned at end, use a 'TcRef' (= 'IORef'). data TcGblEnv = TcGblEnv { tcg_mod :: Module, -- ^ Module being compiled tcg_semantic_mod :: Module, -- ^ If a signature, the backing module -- See also Note [Identity versus semantic module] tcg_src :: HscSource, -- ^ What kind of module (regular Haskell, hs-boot, hsig) tcg_rdr_env :: GlobalRdrEnv, -- ^ Top level envt; used during renaming tcg_default :: Maybe [Type], -- ^ Types used for defaulting. @Nothing@ => no @default@ decl tcg_fix_env :: FixityEnv, -- ^ Just for things in this module tcg_field_env :: RecFieldEnv, -- ^ Just for things in this module -- See Note [The interactive package] in HscTypes tcg_type_env :: TypeEnv, -- ^ Global type env for the module we are compiling now. All -- TyCons and Classes (for this module) end up in here right away, -- along with their derived constructors, selectors. -- -- (Ids defined in this module start in the local envt, though they -- move to the global envt during zonking) -- -- NB: for what "things in this module" means, see -- Note [The interactive package] in HscTypes tcg_type_env_var :: TcRef TypeEnv, -- Used only to initialise the interface-file -- typechecker in initIfaceTcRn, so that it can see stuff -- bound in this module when dealing with hi-boot recursions -- Updated at intervals (e.g. after dealing with types and classes) tcg_inst_env :: !InstEnv, -- ^ Instance envt for all /home-package/ modules; -- Includes the dfuns in tcg_insts -- NB. BangPattern is to fix a leak, see #15111 tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances -- NB. BangPattern is to fix a leak, see #15111 tcg_ann_env :: AnnEnv, -- ^ And for annotations -- Now a bunch of things about this module that are simply -- accumulated, but never consulted until the end. -- Nevertheless, it's convenient to accumulate them along -- with the rest of the info from this module. tcg_exports :: [AvailInfo], -- ^ What is exported tcg_imports :: ImportAvails, -- ^ Information about what was imported from where, including -- things bound in this module. Also store Safe Haskell info -- here about transitive trusted package requirements. -- -- There are not many uses of this field, so you can grep for -- all them. -- -- The ImportAvails records information about the following -- things: -- -- 1. All of the modules you directly imported (tcRnImports) -- 2. The orphans (only!) of all imported modules in a GHCi -- session (runTcInteractive) -- 3. The module that instantiated a signature -- 4. Each of the signatures that merged in -- -- It is used in the following ways: -- - imp_orphs is used to determine what orphan modules should be -- visible in the context (tcVisibleOrphanMods) -- - imp_finsts is used to determine what family instances should -- be visible (tcExtendLocalFamInstEnv) -- - To resolve the meaning of the export list of a module -- (tcRnExports) -- - imp_mods is used to compute usage info (mkIfaceTc, deSugar) -- - imp_trust_own_pkg is used for Safe Haskell in interfaces -- (mkIfaceTc, as well as in HscMain) -- - To create the Dependencies field in interface (mkDependencies) -- These three fields track unused bindings and imports -- See Note [Tracking unused binding and imports] tcg_dus :: DefUses, tcg_used_gres :: TcRef [GlobalRdrElt], tcg_keep :: TcRef NameSet, tcg_th_used :: TcRef Bool, -- ^ @True@ <=> Template Haskell syntax used. -- -- We need this so that we can generate a dependency on the -- Template Haskell package, because the desugarer is going -- to emit loads of references to TH symbols. The reference -- is implicit rather than explicit, so we have to zap a -- mutable variable. tcg_th_splice_used :: TcRef Bool, -- ^ @True@ <=> A Template Haskell splice was used. -- -- Splices disable recompilation avoidance (see #481) tcg_th_top_level_locs :: TcRef (Set RealSrcSpan), -- ^ Locations of the top-level splices; used for providing details on -- scope in error messages for out-of-scope variables tcg_dfun_n :: TcRef OccSet, -- ^ Allows us to choose unique DFun names. tcg_merged :: [(Module, Fingerprint)], -- ^ The requirements we merged with; we always have to recompile -- if any of these changed. -- The next fields accumulate the payload of the module -- The binds, rules and foreign-decl fields are collected -- initially in un-zonked form and are finally zonked in tcRnSrcDecls tcg_rn_exports :: Maybe [(Located (IE GhcRn), Avails)], -- Nothing <=> no explicit export list -- Is always Nothing if we don't want to retain renamed -- exports. -- If present contains each renamed export list item -- together with its exported names. tcg_rn_imports :: [LImportDecl GhcRn], -- Keep the renamed imports regardless. They are not -- voluminous and are needed if you want to report unused imports tcg_rn_decls :: Maybe (HsGroup GhcRn), -- ^ Renamed decls, maybe. @Nothing@ <=> Don't retain renamed -- decls. tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile tcg_th_topdecls :: TcRef [LHsDecl GhcPs], -- ^ Top-level declarations from addTopDecls tcg_th_foreign_files :: TcRef [(ForeignSrcLang, FilePath)], -- ^ Foreign files emitted from TH. tcg_th_topnames :: TcRef NameSet, -- ^ Exact names bound in top-level declarations in tcg_th_topdecls tcg_th_modfinalizers :: TcRef [(TcLclEnv, ThModFinalizers)], -- ^ Template Haskell module finalizers. -- -- They can use particular local environments. tcg_th_coreplugins :: TcRef [String], -- ^ Core plugins added by Template Haskell code. tcg_th_state :: TcRef (Map TypeRep Dynamic), tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))), -- ^ Template Haskell state tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings -- Things defined in this module, or (in GHCi) -- in the declarations for a single GHCi command. -- For the latter, see Note [The interactive package] in HscTypes tcg_tr_module :: Maybe Id, -- Id for $trModule :: GHC.Types.Module -- for which every module has a top-level defn -- except in GHCi in which case we have Nothing tcg_binds :: LHsBinds GhcTc, -- Value bindings in this module tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids tcg_warns :: Warnings, -- ...Warnings and deprecations tcg_anns :: [Annotation], -- ...Annotations tcg_tcs :: [TyCon], -- ...TyCons and Classes tcg_insts :: [ClsInst], -- ...Instances tcg_fam_insts :: [FamInst], -- ...Family instances tcg_rules :: [LRuleDecl GhcTc], -- ...Rules tcg_fords :: [LForeignDecl GhcTc], -- ...Foreign import & exports tcg_patsyns :: [PatSyn], -- ...Pattern synonyms tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs tcg_hpc :: !AnyHpcUsage, -- ^ @True@ if any part of the -- prog uses hpc instrumentation. -- NB. BangPattern is to fix a leak, see #15111 tcg_self_boot :: SelfBootInfo, -- ^ Whether this module has a -- corresponding hi-boot file tcg_main :: Maybe Name, -- ^ The Name of the main -- function, if this module is -- the main module. tcg_safeInfer :: TcRef (Bool, WarningMessages), -- ^ Has the typechecker inferred this module as -XSafe (Safe Haskell) -- See Note [Safe Haskell Overlapping Instances Implementation], -- although this is used for more than just that failure case. tcg_tc_plugins :: [TcPluginSolver], -- ^ A list of user-defined plugins for the constraint solver. tcg_hf_plugins :: [HoleFitPlugin], -- ^ A list of user-defined plugins for hole fit suggestions. tcg_top_loc :: RealSrcSpan, -- ^ The RealSrcSpan this module came from tcg_static_wc :: TcRef WantedConstraints, -- ^ Wanted constraints of static forms. -- See Note [Constraints in static forms]. tcg_complete_matches :: [CompleteMatch], -- ^ Tracking indices for cost centre annotations tcg_cc_st :: TcRef CostCentreState } -- NB: topModIdentity, not topModSemantic! -- Definition sites of orphan identities will be identity modules, not semantic -- modules. -- Note [Constraints in static forms] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- When a static form produces constraints like -- -- f :: StaticPtr (Bool -> String) -- f = static show -- -- we collect them in tcg_static_wc and resolve them at the end -- of type checking. They need to be resolved separately because -- we don't want to resolve them in the context of the enclosing -- expression. Consider -- -- g :: Show a => StaticPtr (a -> String) -- g = static show -- -- If the @Show a0@ constraint that the body of the static form produces was -- resolved in the context of the enclosing expression, then the body of the -- static form wouldn't be closed because the Show dictionary would come from -- g's context instead of coming from the top level. tcVisibleOrphanMods :: TcGblEnv -> ModuleSet tcVisibleOrphanMods tcg_env = mkModuleSet (tcg_mod tcg_env : imp_orphs (tcg_imports tcg_env)) instance ContainsModule TcGblEnv where extractModule env = tcg_semantic_mod env type RecFieldEnv = NameEnv [FieldLabel] -- Maps a constructor name *in this module* -- to the fields for that constructor. -- This is used when dealing with ".." notation in record -- construction and pattern matching. -- The FieldEnv deals *only* with constructors defined in *this* -- module. For imported modules, we get the same info from the -- TypeEnv data SelfBootInfo = NoSelfBoot -- No corresponding hi-boot file | SelfBoot { sb_mds :: ModDetails -- There was a hi-boot file, , sb_tcs :: NameSet } -- defining these TyCons, -- What is sb_tcs used for? See Note [Extra dependencies from .hs-boot files] -- in RnSource {- Note [Tracking unused binding and imports] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We gather three sorts of usage information * tcg_dus :: DefUses (defs/uses) Records what is defined in this module and what is used. Records *defined* Names (local, top-level) and *used* Names (local or imported) Used (a) to report "defined but not used" (see RnNames.reportUnusedNames) (b) to generate version-tracking usage info in interface files (see MkIface.mkUsedNames) This usage info is mainly gathered by the renamer's gathering of free-variables * tcg_used_gres :: TcRef [GlobalRdrElt] Records occurrences of imported entities. Used only to report unused import declarations Records each *occurrence* an *imported* (not locally-defined) entity. The occurrence is recorded by keeping a GlobalRdrElt for it. These is not the GRE that is in the GlobalRdrEnv; rather it is recorded *after* the filtering done by pickGREs. So it reflect /how that occurrence is in scope/. See Note [GRE filtering] in RdrName. * tcg_keep :: TcRef NameSet Records names of the type constructors, data constructors, and Ids that are used by the constraint solver. The typechecker may use find that some imported or locally-defined things are used, even though they do not appear to be mentioned in the source code: (a) The to/from functions for generic data types (b) Top-level variables appearing free in the RHS of an orphan rule (c) Top-level variables appearing free in a TH bracket See Note [Keeping things alive for Template Haskell] in RnSplice (d) The data constructor of a newtype that is used to solve a Coercible instance (e.g. #10347). Example module T10347 (N, mkN) where import Data.Coerce newtype N a = MkN Int mkN :: Int -> N a mkN = coerce Then we wish to record `MkN` as used, since it is (morally) used to perform the coercion in `mkN`. To do so, the Coercible solver updates tcg_keep's TcRef whenever it encounters a use of `coerce` that crosses newtype boundaries. The tcg_keep field is used in two distinct ways: * Desugar.addExportFlagsAndRules. Where things like (a-c) are locally defined, we should give them an an Exported flag, so that the simplifier does not discard them as dead code, and so that they are exposed in the interface file (but not to export to the user). * RnNames.reportUnusedNames. Where newtype data constructors like (d) are imported, we don't want to report them as unused. ************************************************************************ * * The local typechecker environment * * ************************************************************************ Note [The Global-Env/Local-Env story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ During type checking, we keep in the tcg_type_env * All types and classes * All Ids derived from types and classes (constructors, selectors) At the end of type checking, we zonk the local bindings, and as we do so we add to the tcg_type_env * Locally defined top-level Ids Why? Because they are now Ids not TcIds. This final GlobalEnv is a) fed back (via the knot) to typechecking the unfoldings of interface signatures b) used in the ModDetails of this module -} data TcLclEnv -- Changes as we move inside an expression -- Discarded after typecheck/rename; not passed on to desugarer = TcLclEnv { tcl_loc :: RealSrcSpan, -- Source span tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top tcl_tclvl :: TcLevel, -- Birthplace for new unification variables tcl_th_ctxt :: ThStage, -- Template Haskell context tcl_th_bndrs :: ThBindEnv, -- and binder info -- The ThBindEnv records the TH binding level of in-scope Names -- defined in this module (not imported) -- We can't put this info in the TypeEnv because it's needed -- (and extended) in the renamer, for untyed splices tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context tcl_rdr :: LocalRdrEnv, -- Local name envt -- Maintained during renaming, of course, but also during -- type checking, solely so that when renaming a Template-Haskell -- splice we have the right environment for the renamer. -- -- Does *not* include global name envt; may shadow it -- Includes both ordinary variables and type variables; -- they are kept distinct because tyvar have a different -- occurrence constructor (Name.TvOcc) -- We still need the unsullied global name env so that -- we can look up record field names tcl_env :: TcTypeEnv, -- The local type environment: -- Ids and TyVars defined in this module tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, -- and for tidying types tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints tcl_errs :: TcRef Messages -- Place to accumulate errors } setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv setLclEnvTcLevel env lvl = env { tcl_tclvl = lvl } getLclEnvTcLevel :: TcLclEnv -> TcLevel getLclEnvTcLevel = tcl_tclvl setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv setLclEnvLoc env loc = env { tcl_loc = loc } getLclEnvLoc :: TcLclEnv -> RealSrcSpan getLclEnvLoc = tcl_loc type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) -- Monadic so that we have a chance -- to deal with bound type variables just before error -- message construction -- Bool: True <=> this is a landmark context; do not -- discard it when trimming for display -- These are here to avoid module loops: one might expect them -- in Constraint, but they refer to ErrCtxt which refers to TcM. -- Easier to just keep these definitions here, alongside TcM. pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc pushErrCtxt o err loc@(CtLoc { ctl_env = lcl }) = loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc -> CtLoc -- Just add information w/o updating the origin! pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl }) = loc { ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } type TcTypeEnv = NameEnv TcTyThing type ThBindEnv = NameEnv (TopLevelFlag, ThLevel) -- Domain = all Ids bound in this module (ie not imported) -- The TopLevelFlag tells if the binding is syntactically top level. -- We need to know this, because the cross-stage persistence story allows -- cross-stage at arbitrary types if the Id is bound at top level. -- -- Nota bene: a ThLevel of 'outerLevel' is *not* the same as being -- bound at top level! See Note [Template Haskell levels] in TcSplice {- Note [Given Insts] ~~~~~~~~~~~~~~~~~~ Because of GADTs, we have to pass inwards the Insts provided by type signatures and existential contexts. Consider data T a where { T1 :: b -> b -> T [b] } f :: Eq a => T a -> Bool f (T1 x y) = [x]==[y] The constructor T1 binds an existential variable 'b', and we need Eq [b]. Well, we have it, because Eq a refines to Eq [b], but we can only spot that if we pass it inwards. -} -- | Type alias for 'IORef'; the convention is we'll use this for mutable -- bits of data in 'TcGblEnv' which are updated during typechecking and -- returned at the end. type TcRef a = IORef a -- ToDo: when should I refer to it as a 'TcId' instead of an 'Id'? type TcId = Id type TcIdSet = IdSet --------------------------- -- The TcBinderStack --------------------------- type TcBinderStack = [TcBinder] -- This is a stack of locally-bound ids and tyvars, -- innermost on top -- Used only in error reporting (relevantBindings in TcError), -- and in tidying -- We can't use the tcl_env type environment, because it doesn't -- keep track of the nesting order data TcBinder = TcIdBndr TcId TopLevelFlag -- Tells whether the binding is syntactically top-level -- (The monomorphic Ids for a recursive group count -- as not-top-level for this purpose.) | TcIdBndr_ExpType -- Variant that allows the type to be specified as -- an ExpType Name ExpType TopLevelFlag | TcTvBndr -- e.g. case x of P (y::a) -> blah Name -- We bind the lexical name "a" to the type of y, TyVar -- which might be an utterly different (perhaps -- existential) tyvar instance Outputable TcBinder where ppr (TcIdBndr id top_lvl) = ppr id <> brackets (ppr top_lvl) ppr (TcIdBndr_ExpType id _ top_lvl) = ppr id <> brackets (ppr top_lvl) ppr (TcTvBndr name tv) = ppr name <+> ppr tv instance HasOccName TcBinder where occName (TcIdBndr id _) = occName (idName id) occName (TcIdBndr_ExpType name _ _) = occName name occName (TcTvBndr name _) = occName name -- fixes #12177 -- Builds up a list of bindings whose OccName has not been seen before -- i.e., If ys = removeBindingShadowing xs -- then -- - ys is obtained from xs by deleting some elements -- - ys has no duplicate OccNames -- - The first duplicated OccName in xs is retained in ys -- Overloaded so that it can be used for both GlobalRdrElt in typed-hole -- substitutions and TcBinder when looking for relevant bindings. removeBindingShadowing :: HasOccName a => [a] -> [a] removeBindingShadowing bindings = reverse $ fst $ foldl (\(bindingAcc, seenNames) binding -> if occName binding `elemOccSet` seenNames -- if we've seen it then (bindingAcc, seenNames) -- skip it else (binding:bindingAcc, extendOccSet seenNames (occName binding))) ([], emptyOccSet) bindings --------------------------- -- Template Haskell stages and levels --------------------------- data SpliceType = Typed | Untyped data ThStage -- See Note [Template Haskell state diagram] in TcSplice = Splice SpliceType -- Inside a top-level splice -- This code will be run *at compile time*; -- the result replaces the splice -- Binding level = 0 | RunSplice (TcRef [ForeignRef (TH.Q ())]) -- Set when running a splice, i.e. NOT when renaming or typechecking the -- Haskell code for the splice. See Note [RunSplice ThLevel]. -- -- Contains a list of mod finalizers collected while executing the splice. -- -- 'addModFinalizer' inserts finalizers here, and from here they are taken -- to construct an @HsSpliced@ annotation for untyped splices. See Note -- [Delaying modFinalizers in untyped splices] in "RnSplice". -- -- For typed splices, the typechecker takes finalizers from here and -- inserts them in the list of finalizers in the global environment. -- -- See Note [Collecting modFinalizers in typed splices] in "TcSplice". | Comp -- Ordinary Haskell code -- Binding level = 1 | Brack -- Inside brackets ThStage -- Enclosing stage PendingStuff data PendingStuff = RnPendingUntyped -- Renaming the inside of an *untyped* bracket (TcRef [PendingRnSplice]) -- Pending splices in here | RnPendingTyped -- Renaming the inside of a *typed* bracket | TcPending -- Typechecking the inside of a typed bracket (TcRef [PendingTcSplice]) -- Accumulate pending splices here (TcRef WantedConstraints) -- and type constraints here topStage, topAnnStage, topSpliceStage :: ThStage topStage = Comp topAnnStage = Splice Untyped topSpliceStage = Splice Untyped instance Outputable ThStage where ppr (Splice _) = text "Splice" ppr (RunSplice _) = text "RunSplice" ppr Comp = text "Comp" ppr (Brack s _) = text "Brack" <> parens (ppr s) type ThLevel = Int -- NB: see Note [Template Haskell levels] in TcSplice -- Incremented when going inside a bracket, -- decremented when going inside a splice -- NB: ThLevel is one greater than the 'n' in Fig 2 of the -- original "Template meta-programming for Haskell" paper impLevel, outerLevel :: ThLevel impLevel = 0 -- Imported things; they can be used inside a top level splice outerLevel = 1 -- Things defined outside brackets thLevel :: ThStage -> ThLevel thLevel (Splice _) = 0 thLevel (RunSplice _) = -- See Note [RunSplice ThLevel]. panic "thLevel: called when running a splice" thLevel Comp = 1 thLevel (Brack s _) = thLevel s + 1 {- Node [RunSplice ThLevel] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The 'RunSplice' stage is set when executing a splice, and only when running a splice. In particular it is not set when the splice is renamed or typechecked. 'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert the finalizer (see Note [Delaying modFinalizers in untyped splices]), and 'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to set 'RunSplice' when renaming or typechecking the splice, where 'Splice', 'Brack' or 'Comp' are used instead. -} --------------------------- -- Arrow-notation context --------------------------- {- Note [Escaping the arrow scope] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In arrow notation, a variable bound by a proc (or enclosed let/kappa) is not in scope to the left of an arrow tail (-<) or the head of (|..|). For example proc x -> (e1 -< e2) Here, x is not in scope in e1, but it is in scope in e2. This can get a bit complicated: let x = 3 in proc y -> (proc z -> e1) -< e2 Here, x and z are in scope in e1, but y is not. We implement this by recording the environment when passing a proc (using newArrowScope), and returning to that (using escapeArrowScope) on the left of -< and the head of (|..|). All this can be dealt with by the *renamer*. But the type checker needs to be involved too. Example (arrowfail001) class Foo a where foo :: a -> () data Bar = forall a. Foo a => Bar a get :: Bar -> () get = proc x -> case x of Bar a -> foo -< a Here the call of 'foo' gives rise to a (Foo a) constraint that should not be captured by the pattern match on 'Bar'. Rather it should join the constraints from further out. So we must capture the constraint bag from further out in the ArrowCtxt that we push inwards. -} data ArrowCtxt -- Note [Escaping the arrow scope] = NoArrowCtxt | ArrowCtxt LocalRdrEnv (TcRef WantedConstraints) --------------------------- -- TcTyThing --------------------------- -- | A typecheckable thing available in a local context. Could be -- 'AGlobal' 'TyThing', but also lexically scoped variables, etc. -- See 'TcEnv' for how to retrieve a 'TyThing' given a 'Name'. data TcTyThing = AGlobal TyThing -- Used only in the return type of a lookup | ATcId -- Ids defined in this module; may not be fully zonked { tct_id :: TcId , tct_info :: IdBindingInfo -- See Note [Meaning of IdBindingInfo] } | ATyVar Name TcTyVar -- See Note [Type variables in the type environment] | ATcTyCon TyCon -- Used temporarily, during kind checking, for the -- tycons and clases in this recursive group -- The TyCon is always a TcTyCon. Its kind -- can be a mono-kind or a poly-kind; in TcTyClsDcls see -- Note [Type checking recursive type and class declarations] | APromotionErr PromotionErr data PromotionErr = TyConPE -- TyCon used in a kind before we are ready -- data T :: T -> * where ... | ClassPE -- Ditto Class | FamDataConPE -- Data constructor for a data family -- See Note [AFamDataCon: not promoting data family constructors] -- in TcEnv. | ConstrainedDataConPE PredType -- Data constructor with a non-equality context -- See Note [Don't promote data constructors with -- non-equality contexts] in TcHsType | PatSynPE -- Pattern synonyms -- See Note [Don't promote pattern synonyms] in TcEnv | RecDataConPE -- Data constructor in a recursive loop -- See Note [Recursion and promoting data constructors] in TcTyClsDecls | NoDataKindsTC -- -XDataKinds not enabled (for a tycon) | NoDataKindsDC -- -XDataKinds not enabled (for a datacon) instance Outputable TcTyThing where -- Debugging only ppr (AGlobal g) = ppr g ppr elt@(ATcId {}) = text "Identifier" <> brackets (ppr (tct_id elt) <> dcolon <> ppr (varType (tct_id elt)) <> comma <+> ppr (tct_info elt)) ppr (ATyVar n tv) = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv <+> dcolon <+> ppr (varType tv) ppr (ATcTyCon tc) = text "ATcTyCon" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc) ppr (APromotionErr err) = text "APromotionErr" <+> ppr err -- | IdBindingInfo describes how an Id is bound. -- -- It is used for the following purposes: -- a) for static forms in TcExpr.checkClosedInStaticForm and -- b) to figure out when a nested binding can be generalised, -- in TcBinds.decideGeneralisationPlan. -- data IdBindingInfo -- See Note [Meaning of IdBindingInfo and ClosedTypeId] = NotLetBound | ClosedLet | NonClosedLet RhsNames -- Used for (static e) checks only ClosedTypeId -- Used for generalisation checks -- and for (static e) checks -- | IsGroupClosed describes a group of mutually-recursive bindings data IsGroupClosed = IsGroupClosed (NameEnv RhsNames) -- Free var info for the RHS of each binding in the goup -- Used only for (static e) checks ClosedTypeId -- True <=> all the free vars of the group are -- imported or ClosedLet or -- NonClosedLet with ClosedTypeId=True. -- In particular, no tyvars, no NotLetBound type RhsNames = NameSet -- Names of variables, mentioned on the RHS of -- a definition, that are not Global or ClosedLet type ClosedTypeId = Bool -- See Note [Meaning of IdBindingInfo and ClosedTypeId] {- Note [Meaning of IdBindingInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NotLetBound means that the Id is not let-bound (e.g. it is bound in a lambda-abstraction or in a case pattern) ClosedLet means that - The Id is let-bound, - Any free term variables are also Global or ClosedLet - Its type has no free variables (NB: a top-level binding subject to the MR might have free vars in its type) These ClosedLets can definitely be floated to top level; and we may need to do so for static forms. Property: ClosedLet is equivalent to NonClosedLet emptyNameSet True (NonClosedLet (fvs::RhsNames) (cl::ClosedTypeId)) means that - The Id is let-bound - The fvs::RhsNames contains the free names of the RHS, excluding Global and ClosedLet ones. - For the ClosedTypeId field see Note [Bindings with closed types] For (static e) to be valid, we need for every 'x' free in 'e', that x's binding is floatable to the top level. Specifically: * x's RhsNames must be empty * x's type has no free variables See Note [Grand plan for static forms] in StaticPtrTable.hs. This test is made in TcExpr.checkClosedInStaticForm. Actually knowing x's RhsNames (rather than just its emptiness or otherwise) is just so we can produce better error messages Note [Bindings with closed types: ClosedTypeId] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider f x = let g ys = map not ys in ... Can we generalise 'g' under the OutsideIn algorithm? Yes, because all g's free variables are top-level; that is they themselves have no free type variables, and it is the type variables in the environment that makes things tricky for OutsideIn generalisation. Here's the invariant: If an Id has ClosedTypeId=True (in its IdBindingInfo), then the Id's type is /definitely/ closed (has no free type variables). Specifically, a) The Id's acutal type is closed (has no free tyvars) b) Either the Id has a (closed) user-supplied type signature or all its free variables are Global/ClosedLet or NonClosedLet with ClosedTypeId=True. In particular, none are NotLetBound. Why is (b) needed? Consider \x. (x :: Int, let y = x+1 in ...) Initially x::alpha. If we happen to typecheck the 'let' before the (x::Int), y's type will have a free tyvar; but if the other way round it won't. So we treat any let-bound variable with a free non-let-bound variable as not ClosedTypeId, regardless of what the free vars of its type actually are. But if it has a signature, all is well: \x. ...(let { y::Int; y = x+1 } in let { v = y+2 } in ...)... Here the signature on 'v' makes 'y' a ClosedTypeId, so we can generalise 'v'. Note that: * A top-level binding may not have ClosedTypeId=True, if it suffers from the MR * A nested binding may be closed (eg 'g' in the example we started with). Indeed, that's the point; whether a function is defined at top level or nested is orthogonal to the question of whether or not it is closed. * A binding may be non-closed because it mentions a lexically scoped *type variable* Eg f :: forall a. blah f x = let g y = ...(y::a)... Under OutsideIn we are free to generalise an Id all of whose free variables have ClosedTypeId=True (or imported). This is an extension compared to the JFP paper on OutsideIn, which used "top-level" as a proxy for "closed". (It's not a good proxy anyway -- the MR can make a top-level binding with a free type variable.) Note [Type variables in the type environment] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The type environment has a binding for each lexically-scoped type variable that is in scope. For example f :: forall a. a -> a f x = (x :: a) g1 :: [a] -> a g1 (ys :: [b]) = head ys :: b g2 :: [Int] -> Int g2 (ys :: [c]) = head ys :: c * The forall'd variable 'a' in the signature scopes over f's RHS. * The pattern-bound type variable 'b' in 'g1' scopes over g1's RHS; note that it is bound to a skolem 'a' which is not itself lexically in scope. * The pattern-bound type variable 'c' in 'g2' is bound to Int; that is, pattern-bound type variables can stand for arbitrary types. (see GHC proposal #128 "Allow ScopedTypeVariables to refer to types" https://github.com/ghc-proposals/ghc-proposals/pull/128, and the paper "Type variables in patterns", Haskell Symposium 2018. This is implemented by the constructor ATyVar Name TcTyVar in the type environment. * The Name is the name of the original, lexically scoped type variable * The TcTyVar is sometimes a skolem (like in 'f'), and sometimes a unification variable (like in 'g1', 'g2'). We never zonk the type environment so in the latter case it always stays as a unification variable, although that variable may be later unified with a type (such as Int in 'g2'). -} instance Outputable IdBindingInfo where ppr NotLetBound = text "NotLetBound" ppr ClosedLet = text "TopLevelLet" ppr (NonClosedLet fvs closed_type) = text "TopLevelLet" <+> ppr fvs <+> ppr closed_type instance Outputable PromotionErr where ppr ClassPE = text "ClassPE" ppr TyConPE = text "TyConPE" ppr PatSynPE = text "PatSynPE" ppr FamDataConPE = text "FamDataConPE" ppr (ConstrainedDataConPE pred) = text "ConstrainedDataConPE" <+> parens (ppr pred) ppr RecDataConPE = text "RecDataConPE" ppr NoDataKindsTC = text "NoDataKindsTC" ppr NoDataKindsDC = text "NoDataKindsDC" pprTcTyThingCategory :: TcTyThing -> SDoc pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing pprTcTyThingCategory (ATyVar {}) = text "Type variable" pprTcTyThingCategory (ATcId {}) = text "Local identifier" pprTcTyThingCategory (ATcTyCon {}) = text "Local tycon" pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe pprPECategory :: PromotionErr -> SDoc pprPECategory ClassPE = text "Class" pprPECategory TyConPE = text "Type constructor" pprPECategory PatSynPE = text "Pattern synonym" pprPECategory FamDataConPE = text "Data constructor" pprPECategory ConstrainedDataConPE{} = text "Data constructor" pprPECategory RecDataConPE = text "Data constructor" pprPECategory NoDataKindsTC = text "Type constructor" pprPECategory NoDataKindsDC = text "Data constructor" {- ************************************************************************ * * Operations over ImportAvails * * ************************************************************************ -} -- | 'ImportAvails' summarises what was imported from where, irrespective of -- whether the imported things are actually used or not. It is used: -- -- * when processing the export list, -- -- * when constructing usage info for the interface file, -- -- * to identify the list of directly imported modules for initialisation -- purposes and for optimised overlap checking of family instances, -- -- * when figuring out what things are really unused -- data ImportAvails = ImportAvails { imp_mods :: ImportedMods, -- = ModuleEnv [ImportedModsVal], -- ^ Domain is all directly-imported modules -- -- See the documentation on ImportedModsVal in HscTypes for the -- meaning of the fields. -- -- We need a full ModuleEnv rather than a ModuleNameEnv here, -- because we might be importing modules of the same name from -- different packages. (currently not the case, but might be in the -- future). imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface), -- ^ Home-package modules needed by the module being compiled -- -- It doesn't matter whether any of these dependencies -- are actually /used/ when compiling the module; they -- are listed if they are below it at all. For -- example, suppose M imports A which imports X. Then -- compiling M might not need to consult X.hi, but X -- is still listed in M's dependencies. imp_dep_pkgs :: Set InstalledUnitId, -- ^ Packages needed by the module being compiled, whether directly, -- or via other modules in this package, or via modules imported -- from other packages. imp_trust_pkgs :: Set InstalledUnitId, -- ^ This is strictly a subset of imp_dep_pkgs and records the -- packages the current module needs to trust for Safe Haskell -- compilation to succeed. A package is required to be trusted if -- we are dependent on a trustworthy module in that package. -- While perhaps making imp_dep_pkgs a tuple of (UnitId, Bool) -- where True for the bool indicates the package is required to be -- trusted is the more logical design, doing so complicates a lot -- of code not concerned with Safe Haskell. -- See Note [RnNames . Tracking Trust Transitively] imp_trust_own_pkg :: Bool, -- ^ Do we require that our own package is trusted? -- This is to handle efficiently the case where a Safe module imports -- a Trustworthy module that resides in the same package as it. -- See Note [RnNames . Trust Own Package] imp_orphs :: [Module], -- ^ Orphan modules below us in the import tree (and maybe including -- us for imported modules) imp_finsts :: [Module] -- ^ Family instance modules below us in the import tree (and maybe -- including us for imported modules) } mkModDeps :: [(ModuleName, IsBootInterface)] -> ModuleNameEnv (ModuleName, IsBootInterface) mkModDeps deps = foldl' add emptyUFM deps where add env elt@(m,_) = addToUFM env m elt modDepsElts :: ModuleNameEnv (ModuleName, IsBootInterface) -> [(ModuleName, IsBootInterface)] modDepsElts = sort . nonDetEltsUFM -- It's OK to use nonDetEltsUFM here because sorting by module names -- restores determinism emptyImportAvails :: ImportAvails emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, imp_dep_mods = emptyUFM, imp_dep_pkgs = S.empty, imp_trust_pkgs = S.empty, imp_trust_own_pkg = False, imp_orphs = [], imp_finsts = [] } -- | Union two ImportAvails -- -- This function is a key part of Import handling, basically -- for each import we create a separate ImportAvails structure -- and then union them all together with this function. plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails plusImportAvails (ImportAvails { imp_mods = mods1, imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1, imp_orphs = orphs1, imp_finsts = finsts1 }) (ImportAvails { imp_mods = mods2, imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2, imp_orphs = orphs2, imp_finsts = finsts2 }) = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, imp_dep_pkgs = dpkgs1 `S.union` dpkgs2, imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, imp_trust_own_pkg = tself1 || tself2, imp_orphs = orphs1 `unionLists` orphs2, imp_finsts = finsts1 `unionLists` finsts2 } where plus_mod_dep r1@(m1, boot1) r2@(m2, boot2) | ASSERT2( m1 == m2, (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) boot1 = r2 | otherwise = r1 -- If either side can "see" a non-hi-boot interface, use that -- Reusing existing tuples saves 10% of allocations on test -- perf/compiler/MultiLayerModules {- ************************************************************************ * * \subsection{Where from} * * ************************************************************************ The @WhereFrom@ type controls where the renamer looks for an interface file -} data WhereFrom = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) | ImportBySystem -- Non user import. | ImportByPlugin -- Importing a plugin; -- See Note [Care with plugin imports] in LoadIface instance Outputable WhereFrom where ppr (ImportByUser is_boot) | is_boot = text "{- SOURCE -}" | otherwise = empty ppr ImportBySystem = text "{- SYSTEM -}" ppr ImportByPlugin = text "{- PLUGIN -}" {- ********************************************************************* * * Type signatures * * ********************************************************************* -} -- These data types need to be here only because -- TcSimplify uses them, and TcSimplify is fairly -- low down in the module hierarchy type TcSigFun = Name -> Maybe TcSigInfo data TcSigInfo = TcIdSig TcIdSigInfo | TcPatSynSig TcPatSynInfo data TcIdSigInfo -- See Note [Complete and partial type signatures] = CompleteSig -- A complete signature with no wildcards, -- so the complete polymorphic type is known. { sig_bndr :: TcId -- The polymorphic Id with that type , sig_ctxt :: UserTypeCtxt -- In the case of type-class default methods, -- the Name in the FunSigCtxt is not the same -- as the TcId; the former is 'op', while the -- latter is '$dmop' or some such , sig_loc :: SrcSpan -- Location of the type signature } | PartialSig -- A partial type signature (i.e. includes one or more -- wildcards). In this case it doesn't make sense to give -- the polymorphic Id, because we are going to /infer/ its -- type, so we can't make the polymorphic Id ab-initio { psig_name :: Name -- Name of the function; used when report wildcards , psig_hs_ty :: LHsSigWcType GhcRn -- The original partial signature in -- HsSyn form , sig_ctxt :: UserTypeCtxt , sig_loc :: SrcSpan -- Location of the type signature } {- Note [Complete and partial type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A type signature is partial when it contains one or more wildcards (= type holes). The wildcard can either be: * A (type) wildcard occurring in sig_theta or sig_tau. These are stored in sig_wcs. f :: Bool -> _ g :: Eq _a => _a -> _a -> Bool * Or an extra-constraints wildcard, stored in sig_cts: h :: (Num a, _) => a -> a A type signature is a complete type signature when there are no wildcards in the type signature, i.e. iff sig_wcs is empty and sig_extra_cts is Nothing. -} data TcIdSigInst = TISI { sig_inst_sig :: TcIdSigInfo , sig_inst_skols :: [(Name, TcTyVar)] -- Instantiated type and kind variables, TyVarTvs -- The Name is the Name that the renamer chose; -- but the TcTyVar may come from instantiating -- the type and hence have a different unique. -- No need to keep track of whether they are truly lexically -- scoped because the renamer has named them uniquely -- See Note [Binding scoped type variables] in TcSigs -- -- NB: The order of sig_inst_skols is irrelevant -- for a CompleteSig, but for a PartialSig see -- Note [Quantified varaibles in partial type signatures] , sig_inst_theta :: TcThetaType -- Instantiated theta. In the case of a -- PartialSig, sig_theta does not include -- the extra-constraints wildcard , sig_inst_tau :: TcSigmaType -- Instantiated tau -- See Note [sig_inst_tau may be polymorphic] -- Relevant for partial signature only , sig_inst_wcs :: [(Name, TcTyVar)] -- Like sig_inst_skols, but for /named/ wildcards (_a etc). -- The named wildcards scope over the binding, and hence -- their Names may appear in type signatures in the binding , sig_inst_wcx :: Maybe TcType -- Extra-constraints wildcard to fill in, if any -- If this exists, it is surely of the form (meta_tv |> co) -- (where the co might be reflexive). This is filled in -- only from the return value of TcHsType.tcAnonWildCardOcc } {- Note [sig_inst_tau may be polymorphic] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that "sig_inst_tau" might actually be a polymorphic type, if the original function had a signature like forall a. Eq a => forall b. Ord b => .... But that's ok: tcMatchesFun (called by tcRhs) can deal with that It happens, too! See Note [Polymorphic methods] in TcClassDcl. Note [Quantified varaibles in partial type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider f :: forall a b. _ -> a -> _ -> b f (x,y) p q = q Then we expect f's final type to be f :: forall {x,y}. forall a b. (x,y) -> a -> b -> b Note that x,y are Inferred, and can't be use for visible type application (VTA). But a,b are Specified, and remain Specified in the final type, so we can use VTA for them. (Exception: if it turns out that a's kind mentions b we need to reorder them with scopedSort.) The sig_inst_skols of the TISI from a partial signature records that original order, and is used to get the variables of f's final type in the correct order. Note [Wildcards in partial signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The wildcards in psig_wcs may stand for a type mentioning the universally-quantified tyvars of psig_ty E.g. f :: forall a. _ -> a f x = x We get sig_inst_skols = [a] sig_inst_tau = _22 -> a sig_inst_wcs = [_22] and _22 in the end is unified with the type 'a' Moreover the kind of a wildcard in sig_inst_wcs may mention the universally-quantified tyvars sig_inst_skols e.g. f :: t a -> t _ Here we get sig_inst_skols = [k:*, (t::k ->*), (a::k)] sig_inst_tau = t a -> t _22 sig_inst_wcs = [ _22::k ] -} data TcPatSynInfo = TPSI { patsig_name :: Name, patsig_implicit_bndrs :: [TyVarBinder], -- Implicitly-bound kind vars (Inferred) and -- implicitly-bound type vars (Specified) -- See Note [The pattern-synonym signature splitting rule] in TcPatSyn patsig_univ_bndrs :: [TyVar], -- Bound by explicit user forall patsig_req :: TcThetaType, patsig_ex_bndrs :: [TyVar], -- Bound by explicit user forall patsig_prov :: TcThetaType, patsig_body_ty :: TcSigmaType } instance Outputable TcSigInfo where ppr (TcIdSig idsi) = ppr idsi ppr (TcPatSynSig tpsi) = text "TcPatSynInfo" <+> ppr tpsi instance Outputable TcIdSigInfo where ppr (CompleteSig { sig_bndr = bndr }) = ppr bndr <+> dcolon <+> ppr (idType bndr) ppr (PartialSig { psig_name = name, psig_hs_ty = hs_ty }) = text "psig" <+> ppr name <+> dcolon <+> ppr hs_ty instance Outputable TcIdSigInst where ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols , sig_inst_theta = theta, sig_inst_tau = tau }) = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ]) instance Outputable TcPatSynInfo where ppr (TPSI{ patsig_name = name}) = ppr name isPartialSig :: TcIdSigInst -> Bool isPartialSig (TISI { sig_inst_sig = PartialSig {} }) = True isPartialSig _ = False -- | No signature or a partial signature hasCompleteSig :: TcSigFun -> Name -> Bool hasCompleteSig sig_fn name = case sig_fn name of Just (TcIdSig (CompleteSig {})) -> True _ -> False {- Constraint Solver Plugins ------------------------- -} type TcPluginSolver = [Ct] -- given -> [Ct] -- derived -> [Ct] -- wanted -> TcPluginM TcPluginResult newtype TcPluginM a = TcPluginM (EvBindsVar -> TcM a) deriving (Functor) instance Applicative TcPluginM where pure x = TcPluginM (const $ pure x) (<*>) = ap instance Monad TcPluginM where #if !MIN_VERSION_base(4,13,0) fail = MonadFail.fail #endif TcPluginM m >>= k = TcPluginM (\ ev -> do a <- m ev runTcPluginM (k a) ev) instance MonadFail.MonadFail TcPluginM where fail x = TcPluginM (const $ fail x) runTcPluginM :: TcPluginM a -> EvBindsVar -> TcM a runTcPluginM (TcPluginM m) = m -- | This function provides an escape for direct access to -- the 'TcM` monad. It should not be used lightly, and -- the provided 'TcPluginM' API should be favoured instead. unsafeTcPluginTcM :: TcM a -> TcPluginM a unsafeTcPluginTcM = TcPluginM . const -- | Access the 'EvBindsVar' carried by the 'TcPluginM' during -- constraint solving. Returns 'Nothing' if invoked during -- 'tcPluginInit' or 'tcPluginStop'. getEvBindsTcPluginM :: TcPluginM EvBindsVar getEvBindsTcPluginM = TcPluginM return data TcPlugin = forall s. TcPlugin { tcPluginInit :: TcPluginM s -- ^ Initialize plugin, when entering type-checker. , tcPluginSolve :: s -> TcPluginSolver -- ^ Solve some constraints. -- TODO: WRITE MORE DETAILS ON HOW THIS WORKS. , tcPluginStop :: s -> TcPluginM () -- ^ Clean up after the plugin, when exiting the type-checker. } data TcPluginResult = TcPluginContradiction [Ct] -- ^ The plugin found a contradiction. -- The returned constraints are removed from the inert set, -- and recorded as insoluble. | TcPluginOk [(EvTerm,Ct)] [Ct] -- ^ The first field is for constraints that were solved. -- These are removed from the inert set, -- and the evidence for them is recorded. -- The second field contains new work, that should be processed by -- the constraint solver. {- ********************************************************************* * * Role annotations * * ********************************************************************* -} type RoleAnnotEnv = NameEnv (LRoleAnnotDecl GhcRn) mkRoleAnnotEnv :: [LRoleAnnotDecl GhcRn] -> RoleAnnotEnv mkRoleAnnotEnv role_annot_decls = mkNameEnv [ (name, ra_decl) | ra_decl <- role_annot_decls , let name = roleAnnotDeclName (unLoc ra_decl) , not (isUnboundName name) ] -- Some of the role annots will be unbound; -- we don't wish to include these emptyRoleAnnotEnv :: RoleAnnotEnv emptyRoleAnnotEnv = emptyNameEnv lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl GhcRn) lookupRoleAnnot = lookupNameEnv getRoleAnnots :: [Name] -> RoleAnnotEnv -> [LRoleAnnotDecl GhcRn] getRoleAnnots bndrs role_env = mapMaybe (lookupRoleAnnot role_env) bndrs ghc-lib-parser-8.10.2.20200808/compiler/typecheck/TcType.hs0000644000000000000000000026770513713635745021065 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section[TcType]{Types used in the typechecker} This module provides the Type interface for front-end parts of the compiler. These parts * treat "source types" as opaque: newtypes, and predicates are meaningful. * look through usage types The "tc" prefix is for "TypeChecker", because the type checker is the principal client. -} {-# LANGUAGE CPP, ScopedTypeVariables, MultiWayIf, FlexibleContexts #-} module TcType ( -------------------------------- -- Types TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcTyCon, KnotTied, ExpType(..), InferResult(..), ExpSigmaType, ExpRhoType, mkCheckExpType, SyntaxOpType(..), synKnownType, mkSynFunTys, -- TcLevel TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel, strictlyDeeperThan, sameDepthAs, tcTypeLevel, tcTyVarLevel, maxTcLevel, promoteSkolem, promoteSkolemX, promoteSkolemsX, -------------------------------- -- MetaDetails TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv, MetaDetails(Flexi, Indirect), MetaInfo(..), isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar, isTyConableTyVar, isFskTyVar, isFmvTyVar, isFlattenTyVar, isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo, isFlexi, isIndirect, isRuntimeUnkSkol, metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe, isTouchableMetaTyVar, isFloatedTouchableMetaTyVar, findDupTyVarTvs, mkTyVarNamePairs, -------------------------------- -- Builders mkPhiTy, mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy, mkTcAppTy, mkTcAppTys, mkTcCastTy, -------------------------------- -- Splitters -- These are important because they do not look through newtypes getTyVar, tcSplitForAllTy_maybe, tcSplitForAllTys, tcSplitForAllTysSameVis, tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllVarBndrs, tcSplitPhiTy, tcSplitPredFunTy_maybe, tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN, tcSplitFunTysN, tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs, tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe, tcRepGetNumAppTys, tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar, nextRole, tcSplitSigmaTy, tcSplitNestedSigmaTys, tcDeepSplitSigmaTy_maybe, --------------------------------- -- Predicates. -- Again, newtypes are opaque eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX, pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy, isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, isIntegerTy, isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred, hasIPPred, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck, checkValidClsArgs, hasTyVarHead, isRigidTy, isAlmostFunctionFree, --------------------------------- -- Misc type manipulators deNoteType, orphNamesOfType, orphNamesOfCo, orphNamesOfTypes, orphNamesOfCoCon, getDFunTyKey, evVarPred, --------------------------------- -- Predicate types mkMinimalBySCs, transSuperClasses, pickQuantifiablePreds, pickCapturedPreds, immSuperClasses, boxEqPred, isImprovementPred, -- * Finding type instances tcTyFamInsts, tcTyFamInstsAndVis, tcTyConAppTyFamInstsAndVis, isTyFamFree, -- * Finding "exact" (non-dead) type variables exactTyCoVarsOfType, exactTyCoVarsOfTypes, anyRewritableTyVar, --------------------------------- -- Foreign import and export isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool isFFIImportResultTy, -- :: DynFlags -> Type -> Bool isFFIExportResultTy, -- :: Type -> Bool isFFIExternalTy, -- :: Type -> Bool isFFIDynTy, -- :: Type -> Type -> Bool isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool isFFILabelTy, -- :: Type -> Bool isFFITy, -- :: Type -> Bool isFunPtrTy, -- :: Type -> Bool tcSplitIOType_maybe, -- :: Type -> Maybe Type -------------------------------- -- Rexported from Kind Kind, tcTypeKind, liftedTypeKind, constraintKind, isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues, -------------------------------- -- Rexported from Type Type, PredType, ThetaType, TyCoBinder, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys, mkTyCoInvForAllTy, mkInvForAllTy, mkInvForAllTys, mkVisFunTy, mkVisFunTys, mkInvisFunTy, mkInvisFunTys, mkTyConApp, mkAppTy, mkAppTys, mkTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, isClassPred, isEqPrimPred, isIPPred, isEqPred, isEqPredClass, mkClassPred, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, isRuntimeRepVar, isKindLevPoly, isVisibleBinder, isInvisibleBinder, -- Type substitutions TCvSubst(..), -- Representation visible to a few friends TvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, zipTvSubst, mkTvSubstPrs, notElemTCvSubst, unionTCvSubst, getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, extendTvSubstAndInScope, Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr, Type.extendTvSubst, isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv, Type.substTy, substTys, substTyWith, substTyWithCoVars, substTyAddInScope, substTyUnchecked, substTysUnchecked, substThetaUnchecked, substTyWithUnchecked, substCoUnchecked, substCoWithUnchecked, substTheta, isUnliftedType, -- Source types are always lifted isUnboxedTupleType, -- Ditto isPrimitiveType, tcView, coreView, tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds, tyCoFVsOfType, tyCoFVsOfTypes, tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet, tyCoVarsOfTypeList, tyCoVarsOfTypesList, noFreeVarsOfType, -------------------------------- pprKind, pprParendKind, pprSigmaType, pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory, pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred, pprTCvBndr, pprTCvBndrs, TypeSize, sizeType, sizeTypes, scopedSort, --------------------------------- -- argument visibility tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible ) where #include "GhclibHsVersions.h" -- friends: import GhcPrelude import TyCoRep import TyCoSubst ( mkTvSubst, substTyWithCoVars ) import TyCoFVs import TyCoPpr import Class import Var import ForeignCall import VarSet import Coercion import Type import Predicate import RepType import TyCon -- others: import DynFlags import CoreFVs import Name -- hiding (varName) -- We use this to make dictionaries for type literals. -- Perhaps there's a better way to do this? import NameSet import VarEnv import PrelNames import TysWiredIn( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey , listTyCon, constraintKind ) import BasicTypes import Util import Maybes import ListSetOps ( getNth, findDupsEq ) import Outputable import FastString import ErrUtils( Validity(..), MsgDoc, isValid ) import qualified GHC.LanguageExtensions as LangExt import Data.List ( mapAccumL ) -- import Data.Functor.Identity( Identity(..) ) import Data.IORef import Data.List.NonEmpty( NonEmpty(..) ) {- ************************************************************************ * * Types * * ************************************************************************ The type checker divides the generic Type world into the following more structured beasts: sigma ::= forall tyvars. phi -- A sigma type is a qualified type -- -- Note that even if 'tyvars' is empty, theta -- may not be: e.g. (?x::Int) => Int -- Note that 'sigma' is in prenex form: -- all the foralls are at the front. -- A 'phi' type has no foralls to the right of -- an arrow phi :: theta => rho rho ::= sigma -> rho | tau -- A 'tau' type has no quantification anywhere -- Note that the args of a type constructor must be taus tau ::= tyvar | tycon tau_1 .. tau_n | tau_1 tau_2 | tau_1 -> tau_2 -- In all cases, a (saturated) type synonym application is legal, -- provided it expands to the required form. Note [TcTyVars and TyVars in the typechecker] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The typechecker uses a lot of type variables with special properties, notably being a unification variable with a mutable reference. These use the 'TcTyVar' variant of Var.Var. Note, though, that a /bound/ type variable can (and probably should) be a TyVar. E.g forall a. a -> a Here 'a' is really just a deBruijn-number; it certainly does not have a signficant TcLevel (as every TcTyVar does). So a forall-bound type variable should be TyVars; and hence a TyVar can appear free in a TcType. The type checker and constraint solver can also encounter /free/ type variables that use the 'TyVar' variant of Var.Var, for a couple of reasons: - When typechecking a class decl, say class C (a :: k) where foo :: T a -> Int We have first kind-check the header; fix k and (a:k) to be TyVars, bring 'k' and 'a' into scope, and kind check the signature for 'foo'. In doing so we call solveEqualities to solve any kind equalities in foo's signature. So the solver may see free occurrences of 'k'. See calls to tcExtendTyVarEnv for other places that ordinary TyVars are bought into scope, and hence may show up in the types and kinds generated by TcHsType. - The pattern-match overlap checker calls the constraint solver, long afer TcTyVars have been zonked away It's convenient to simply treat these TyVars as skolem constants, which of course they are. We give them a level number of "outermost", so they behave as global constants. Specifically: * Var.tcTyVarDetails succeeds on a TyVar, returning vanillaSkolemTv, as well as on a TcTyVar. * tcIsTcTyVar returns True for both TyVar and TcTyVar variants of Var.Var. The "tc" prefix means "a type variable that can be encountered by the typechecker". This is a bit of a change from an earlier era when we remoselessly insisted on real TcTyVars in the type checker. But that seems unnecessary (for skolems, TyVars are fine) and it's now very hard to guarantee, with the advent of kind equalities. Note [Coercion variables in free variable lists] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are several places in the GHC codebase where functions like tyCoVarsOfType, tyCoVarsOfCt, et al. are used to compute the free type variables of a type. The "Co" part of these functions' names shouldn't be dismissed, as it is entirely possible that they will include coercion variables in addition to type variables! As a result, there are some places in TcType where we must take care to check that a variable is a _type_ variable (using isTyVar) before calling tcTyVarDetails--a partial function that is not defined for coercion variables--on the variable. Failing to do so led to GHC #12785. -} -- See Note [TcTyVars and TyVars in the typechecker] type TcCoVar = CoVar -- Used only during type inference type TcType = Type -- A TcType can have mutable type variables type TcTyCoVar = Var -- Either a TcTyVar or a CoVar -- Invariant on ForAllTy in TcTypes: -- forall a. T -- a cannot occur inside a MutTyVar in T; that is, -- T is "flattened" before quantifying over a type TcTyVarBinder = TyVarBinder type TcTyCon = TyCon -- these can be the TcTyCon constructor -- These types do not have boxy type variables in them type TcPredType = PredType type TcThetaType = ThetaType type TcSigmaType = TcType type TcRhoType = TcType -- Note [TcRhoType] type TcTauType = TcType type TcKind = Kind type TcTyVarSet = TyVarSet type TcTyCoVarSet = TyCoVarSet type TcDTyVarSet = DTyVarSet type TcDTyCoVarSet = DTyCoVarSet {- ********************************************************************* * * ExpType: an "expected type" in the type checker * * ********************************************************************* -} -- | An expected type to check against during type-checking. -- See Note [ExpType] in TcMType, where you'll also find manipulators. data ExpType = Check TcType | Infer !InferResult data InferResult = IR { ir_uniq :: Unique -- For debugging only , ir_lvl :: TcLevel -- See Note [TcLevel of ExpType] in TcMType , ir_inst :: Bool -- True <=> deeply instantiate before returning -- i.e. return a RhoType -- False <=> do not instantiate before returning -- i.e. return a SigmaType -- See Note [Deep instantiation of InferResult] in TcUnify , ir_ref :: IORef (Maybe TcType) } -- The type that fills in this hole should be a Type, -- that is, its kind should be (TYPE rr) for some rr type ExpSigmaType = ExpType type ExpRhoType = ExpType instance Outputable ExpType where ppr (Check ty) = text "Check" <> braces (ppr ty) ppr (Infer ir) = ppr ir instance Outputable InferResult where ppr (IR { ir_uniq = u, ir_lvl = lvl , ir_inst = inst }) = text "Infer" <> braces (ppr u <> comma <> ppr lvl <+> ppr inst) -- | Make an 'ExpType' suitable for checking. mkCheckExpType :: TcType -> ExpType mkCheckExpType = Check {- ********************************************************************* * * SyntaxOpType * * ********************************************************************* -} -- | What to expect for an argument to a rebindable-syntax operator. -- Quite like 'Type', but allows for holes to be filled in by tcSyntaxOp. -- The callback called from tcSyntaxOp gets a list of types; the meaning -- of these types is determined by a left-to-right depth-first traversal -- of the 'SyntaxOpType' tree. So if you pass in -- -- > SynAny `SynFun` (SynList `SynFun` SynType Int) `SynFun` SynAny -- -- you'll get three types back: one for the first 'SynAny', the /element/ -- type of the list, and one for the last 'SynAny'. You don't get anything -- for the 'SynType', because you've said positively that it should be an -- Int, and so it shall be. -- -- This is defined here to avoid defining it in TcExpr.hs-boot. data SyntaxOpType = SynAny -- ^ Any type | SynRho -- ^ A rho type, deeply skolemised or instantiated as appropriate | SynList -- ^ A list type. You get back the element type of the list | SynFun SyntaxOpType SyntaxOpType -- ^ A function. | SynType ExpType -- ^ A known type. infixr 0 `SynFun` -- | Like 'SynType' but accepts a regular TcType synKnownType :: TcType -> SyntaxOpType synKnownType = SynType . mkCheckExpType -- | Like 'mkFunTys' but for 'SyntaxOpType' mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType mkSynFunTys arg_tys res_ty = foldr SynFun (SynType res_ty) arg_tys {- Note [TcRhoType] ~~~~~~~~~~~~~~~~ A TcRhoType has no foralls or contexts at the top, or to the right of an arrow YES (forall a. a->a) -> Int NO forall a. a -> Int NO Eq a => a -> a NO Int -> forall a. a -> Int ************************************************************************ * * TyVarDetails, MetaDetails, MetaInfo * * ************************************************************************ TyVarDetails gives extra info about type variables, used during type checking. It's attached to mutable type variables only. It's knot-tied back to Var.hs. There is no reason in principle why Var.hs shouldn't actually have the definition, but it "belongs" here. Note [Signature skolems] ~~~~~~~~~~~~~~~~~~~~~~~~ A TyVarTv is a specialised variant of TauTv, with the following invarints: * A TyVarTv can be unified only with a TyVar, not with any other type * Its MetaDetails, if filled in, will always be another TyVarTv or a SkolemTv TyVarTvs are only distinguished to improve error messages. Consider this data T (a:k1) = MkT (S a) data S (b:k2) = MkS (T b) When doing kind inference on {S,T} we don't want *skolems* for k1,k2, because they end up unifying; we want those TyVarTvs again. Note [TyVars and TcTyVars during type checking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Var type has constructors TyVar and TcTyVar. They are used as follows: * TcTyVar: used /only/ during type checking. Should never appear afterwards. May contain a mutable field, in the MetaTv case. * TyVar: is never seen by the constraint solver, except locally inside a type like (forall a. [a] ->[a]), where 'a' is a TyVar. We instantiate these with TcTyVars before exposing the type to the constraint solver. I have swithered about the latter invariant, excluding TyVars from the constraint solver. It's not strictly essential, and indeed (historically but still there) Var.tcTyVarDetails returns vanillaSkolemTv for a TyVar. But ultimately I want to seeparate Type from TcType, and in that case we would need to enforce the separation. -} -- A TyVarDetails is inside a TyVar -- See Note [TyVars and TcTyVars] data TcTyVarDetails = SkolemTv -- A skolem TcLevel -- Level of the implication that binds it -- See TcUnify Note [Deeper level on the left] for -- how this level number is used Bool -- True <=> this skolem type variable can be overlapped -- when looking up instances -- See Note [Binding when looking up instances] in InstEnv | RuntimeUnk -- Stands for an as-yet-unknown type in the GHCi -- interactive context | MetaTv { mtv_info :: MetaInfo , mtv_ref :: IORef MetaDetails , mtv_tclvl :: TcLevel } -- See Note [TcLevel and untouchable type variables] vanillaSkolemTv, superSkolemTv :: TcTyVarDetails -- See Note [Binding when looking up instances] in InstEnv vanillaSkolemTv = SkolemTv topTcLevel False -- Might be instantiated superSkolemTv = SkolemTv topTcLevel True -- Treat this as a completely distinct type -- The choice of level number here is a bit dodgy, but -- topTcLevel works in the places that vanillaSkolemTv is used instance Outputable TcTyVarDetails where ppr = pprTcTyVarDetails pprTcTyVarDetails :: TcTyVarDetails -> SDoc -- For debugging pprTcTyVarDetails (RuntimeUnk {}) = text "rt" pprTcTyVarDetails (SkolemTv lvl True) = text "ssk" <> colon <> ppr lvl pprTcTyVarDetails (SkolemTv lvl False) = text "sk" <> colon <> ppr lvl pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl }) = ppr info <> colon <> ppr tclvl ----------------------------- data MetaDetails = Flexi -- Flexi type variables unify to become Indirects | Indirect TcType data MetaInfo = TauTv -- This MetaTv is an ordinary unification variable -- A TauTv is always filled in with a tau-type, which -- never contains any ForAlls. | TyVarTv -- A variant of TauTv, except that it should not be -- unified with a type, only with a type variable -- See Note [Signature skolems] | FlatMetaTv -- A flatten meta-tyvar -- It is a meta-tyvar, but it is always untouchable, with level 0 -- See Note [The flattening story] in TcFlatten | FlatSkolTv -- A flatten skolem tyvar -- Just like FlatMetaTv, but is comletely "owned" by -- its Given CFunEqCan. -- It is filled in /only/ by unflattenGivens -- See Note [The flattening story] in TcFlatten instance Outputable MetaDetails where ppr Flexi = text "Flexi" ppr (Indirect ty) = text "Indirect" <+> ppr ty instance Outputable MetaInfo where ppr TauTv = text "tau" ppr TyVarTv = text "tyv" ppr FlatMetaTv = text "fmv" ppr FlatSkolTv = text "fsk" {- ********************************************************************* * * Untouchable type variables * * ********************************************************************* -} newtype TcLevel = TcLevel Int deriving( Eq, Ord ) -- See Note [TcLevel and untouchable type variables] for what this Int is -- See also Note [TcLevel assignment] {- Note [TcLevel and untouchable type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Each unification variable (MetaTv) and each Implication has a level number (of type TcLevel) * INVARIANTS. In a tree of Implications, (ImplicInv) The level number (ic_tclvl) of an Implication is STRICTLY GREATER THAN that of its parent (SkolInv) The level number of the skolems (ic_skols) of an Implication is equal to the level of the implication itself (ic_tclvl) (GivenInv) The level number of a unification variable appearing in the 'ic_given' of an implication I should be STRICTLY LESS THAN the ic_tclvl of I (WantedInv) The level number of a unification variable appearing in the 'ic_wanted' of an implication I should be LESS THAN OR EQUAL TO the ic_tclvl of I See Note [WantedInv] * A unification variable is *touchable* if its level number is EQUAL TO that of its immediate parent implication, and it is a TauTv or TyVarTv (but /not/ FlatMetaTv or FlatSkolTv) Note [WantedInv] ~~~~~~~~~~~~~~~~ Why is WantedInv important? Consider this implication, where the constraint (C alpha[3]) disobeys WantedInv: forall[2] a. blah => (C alpha[3]) (forall[3] b. alpha[3] ~ b) We can unify alpha:=b in the inner implication, because 'alpha' is touchable; but then 'b' has excaped its scope into the outer implication. Note [Skolem escape prevention] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We only unify touchable unification variables. Because of (WantedInv), there can be no occurrences of the variable further out, so the unification can't cause the skolems to escape. Example: data T = forall a. MkT a (a->Int) f x (MkT v f) = length [v,x] We decide (x::alpha), and generate an implication like [1]forall a. (a ~ alpha[0]) But we must not unify alpha:=a, because the skolem would escape. For the cases where we DO want to unify, we rely on floating the equality. Example (with same T) g x (MkT v f) = x && True We decide (x::alpha), and generate an implication like [1]forall a. (Bool ~ alpha[0]) We do NOT unify directly, bur rather float out (if the constraint does not mention 'a') to get (Bool ~ alpha[0]) /\ [1]forall a.() and NOW we can unify alpha. The same idea of only unifying touchables solves another problem. Suppose we had (F Int ~ uf[0]) /\ [1](forall a. C a => F Int ~ beta[1]) In this example, beta is touchable inside the implication. The first solveSimpleWanteds step leaves 'uf' un-unified. Then we move inside the implication where a new constraint uf ~ beta emerges. If we (wrongly) spontaneously solved it to get uf := beta, the whole implication disappears but when we pop out again we are left with (F Int ~ uf) which will be unified by our final zonking stage and uf will get unified *once more* to (F Int). Note [TcLevel assignment] ~~~~~~~~~~~~~~~~~~~~~~~~~ We arrange the TcLevels like this 0 Top level 1 First-level implication constraints 2 Second-level implication constraints ...etc... -} maxTcLevel :: TcLevel -> TcLevel -> TcLevel maxTcLevel (TcLevel a) (TcLevel b) = TcLevel (a `max` b) topTcLevel :: TcLevel -- See Note [TcLevel assignment] topTcLevel = TcLevel 0 -- 0 = outermost level isTopTcLevel :: TcLevel -> Bool isTopTcLevel (TcLevel 0) = True isTopTcLevel _ = False pushTcLevel :: TcLevel -> TcLevel -- See Note [TcLevel assignment] pushTcLevel (TcLevel us) = TcLevel (us + 1) strictlyDeeperThan :: TcLevel -> TcLevel -> Bool strictlyDeeperThan (TcLevel tv_tclvl) (TcLevel ctxt_tclvl) = tv_tclvl > ctxt_tclvl sameDepthAs :: TcLevel -> TcLevel -> Bool sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) = ctxt_tclvl == tv_tclvl -- NB: invariant ctxt_tclvl >= tv_tclvl -- So <= would be equivalent checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool -- Checks (WantedInv) from Note [TcLevel and untouchable type variables] checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) = ctxt_tclvl >= tv_tclvl -- Returns topTcLevel for non-TcTyVars tcTyVarLevel :: TcTyVar -> TcLevel tcTyVarLevel tv = case tcTyVarDetails tv of MetaTv { mtv_tclvl = tv_lvl } -> tv_lvl SkolemTv tv_lvl _ -> tv_lvl RuntimeUnk -> topTcLevel tcTypeLevel :: TcType -> TcLevel -- Max level of any free var of the type tcTypeLevel ty = foldDVarSet add topTcLevel (tyCoVarsOfTypeDSet ty) where add v lvl | isTcTyVar v = lvl `maxTcLevel` tcTyVarLevel v | otherwise = lvl instance Outputable TcLevel where ppr (TcLevel us) = ppr us promoteSkolem :: TcLevel -> TcTyVar -> TcTyVar promoteSkolem tclvl skol | tclvl < tcTyVarLevel skol = ASSERT( isTcTyVar skol && isSkolemTyVar skol ) setTcTyVarDetails skol (SkolemTv tclvl (isOverlappableTyVar skol)) | otherwise = skol -- | Change the TcLevel in a skolem, extending a substitution promoteSkolemX :: TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar) promoteSkolemX tclvl subst skol = ASSERT( isTcTyVar skol && isSkolemTyVar skol ) (new_subst, new_skol) where new_skol | tclvl < tcTyVarLevel skol = setTcTyVarDetails (updateTyVarKind (substTy subst) skol) (SkolemTv tclvl (isOverlappableTyVar skol)) | otherwise = updateTyVarKind (substTy subst) skol new_subst = extendTvSubstWithClone subst skol new_skol promoteSkolemsX :: TcLevel -> TCvSubst -> [TcTyVar] -> (TCvSubst, [TcTyVar]) promoteSkolemsX tclvl = mapAccumL (promoteSkolemX tclvl) {- ********************************************************************* * * Finding type family instances * * ************************************************************************ -} -- | Finds outermost type-family applications occurring in a type, -- after expanding synonyms. In the list (F, tys) that is returned -- we guarantee that tys matches F's arity. For example, given -- type family F a :: * -> * (arity 1) -- calling tcTyFamInsts on (Maybe (F Int Bool) will return -- (F, [Int]), not (F, [Int,Bool]) -- -- This is important for its use in deciding termination of type -- instances (see #11581). E.g. -- type instance G [Int] = ...(F Int )... -- we don't need to take into account when asking if -- the calls on the RHS are smaller than the LHS tcTyFamInsts :: Type -> [(TyCon, [Type])] tcTyFamInsts = map (\(_,b,c) -> (b,c)) . tcTyFamInstsAndVis -- | Like 'tcTyFamInsts', except that the output records whether the -- type family and its arguments occur as an /invisible/ argument in -- some type application. This information is useful because it helps GHC know -- when to turn on @-fprint-explicit-kinds@ during error reporting so that -- users can actually see the type family being mentioned. -- -- As an example, consider: -- -- @ -- class C a -- data T (a :: k) -- type family F a :: k -- instance C (T @(F Int) (F Bool)) -- @ -- -- There are two occurrences of the type family `F` in that `C` instance, so -- @'tcTyFamInstsAndVis' (C (T \@(F Int) (F Bool)))@ will return: -- -- @ -- [ ('True', F, [Int]) -- , ('False', F, [Bool]) ] -- @ -- -- @F Int@ is paired with 'True' since it appears as an /invisible/ argument -- to @C@, whereas @F Bool@ is paired with 'False' since it appears an a -- /visible/ argument to @C@. -- -- See also @Note [Kind arguments in error messages]@ in "TcErrors". tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])] tcTyFamInstsAndVis = tcTyFamInstsAndVisX False tcTyFamInstsAndVisX :: Bool -- ^ Is this an invisible argument to some type application? -> Type -> [(Bool, TyCon, [Type])] tcTyFamInstsAndVisX = go where go is_invis_arg ty | Just exp_ty <- tcView ty = go is_invis_arg exp_ty go _ (TyVarTy _) = [] go is_invis_arg (TyConApp tc tys) | isTypeFamilyTyCon tc = [(is_invis_arg, tc, take (tyConArity tc) tys)] | otherwise = tcTyConAppTyFamInstsAndVisX is_invis_arg tc tys go _ (LitTy {}) = [] go is_invis_arg (ForAllTy bndr ty) = go is_invis_arg (binderType bndr) ++ go is_invis_arg ty go is_invis_arg (FunTy _ ty1 ty2) = go is_invis_arg ty1 ++ go is_invis_arg ty2 go is_invis_arg ty@(AppTy _ _) = let (ty_head, ty_args) = splitAppTys ty ty_arg_flags = appTyArgFlags ty_head ty_args in go is_invis_arg ty_head ++ concat (zipWith (\flag -> go (isInvisibleArgFlag flag)) ty_arg_flags ty_args) go is_invis_arg (CastTy ty _) = go is_invis_arg ty go _ (CoercionTy _) = [] -- don't count tyfams in coercions, -- as they never get normalized, -- anyway -- | In an application of a 'TyCon' to some arguments, find the outermost -- occurrences of type family applications within the arguments. This function -- will not consider the 'TyCon' itself when checking for type family -- applications. -- -- See 'tcTyFamInstsAndVis' for more details on how this works (as this -- function is called inside of 'tcTyFamInstsAndVis'). tcTyConAppTyFamInstsAndVis :: TyCon -> [Type] -> [(Bool, TyCon, [Type])] tcTyConAppTyFamInstsAndVis = tcTyConAppTyFamInstsAndVisX False tcTyConAppTyFamInstsAndVisX :: Bool -- ^ Is this an invisible argument to some type application? -> TyCon -> [Type] -> [(Bool, TyCon, [Type])] tcTyConAppTyFamInstsAndVisX is_invis_arg tc tys = let (invis_tys, vis_tys) = partitionInvisibleTypes tc tys in concat $ map (tcTyFamInstsAndVisX True) invis_tys ++ map (tcTyFamInstsAndVisX is_invis_arg) vis_tys isTyFamFree :: Type -> Bool -- ^ Check that a type does not contain any type family applications. isTyFamFree = null . tcTyFamInsts anyRewritableTyVar :: Bool -- Ignore casts and coercions -> EqRel -- Ambient role -> (EqRel -> TcTyVar -> Bool) -> TcType -> Bool -- (anyRewritableTyVar ignore_cos pred ty) returns True -- if the 'pred' returns True of any free TyVar in 'ty' -- Do not look inside casts and coercions if 'ignore_cos' is True -- See Note [anyRewritableTyVar must be role-aware] anyRewritableTyVar ignore_cos role pred ty = go role emptyVarSet ty where go_tv rl bvs tv | tv `elemVarSet` bvs = False | otherwise = pred rl tv go rl bvs (TyVarTy tv) = go_tv rl bvs tv go _ _ (LitTy {}) = False go rl bvs (TyConApp tc tys) = go_tc rl bvs tc tys go rl bvs (AppTy fun arg) = go rl bvs fun || go NomEq bvs arg go rl bvs (FunTy _ arg res) = go rl bvs arg || go rl bvs res go rl bvs (ForAllTy tv ty) = go rl (bvs `extendVarSet` binderVar tv) ty go rl bvs (CastTy ty co) = go rl bvs ty || go_co rl bvs co go rl bvs (CoercionTy co) = go_co rl bvs co -- ToDo: check go_tc NomEq bvs _ tys = any (go NomEq bvs) tys go_tc ReprEq bvs tc tys = any (go_arg bvs) (tyConRolesRepresentational tc `zip` tys) go_arg bvs (Nominal, ty) = go NomEq bvs ty go_arg bvs (Representational, ty) = go ReprEq bvs ty go_arg _ (Phantom, _) = False -- We never rewrite with phantoms go_co rl bvs co | ignore_cos = False | otherwise = anyVarSet (go_tv rl bvs) (tyCoVarsOfCo co) -- We don't have an equivalent of anyRewritableTyVar for coercions -- (at least not yet) so take the free vars and test them {- Note [anyRewritableTyVar must be role-aware] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ anyRewritableTyVar is used during kick-out from the inert set, to decide if, given a new equality (a ~ ty), we should kick out a constraint C. Rather than gather free variables and see if 'a' is among them, we instead pass in a predicate; this is just efficiency. Moreover, consider work item: [G] a ~R f b inert item: [G] b ~R f a We use anyRewritableTyVar to decide whether to kick out the inert item, on the grounds that the work item might rewrite it. Well, 'a' is certainly free in [G] b ~R f a. But because the role of a type variable ('f' in this case) is nominal, the work item can't actually rewrite the inert item. Moreover, if we were to kick out the inert item the exact same situation would re-occur and we end up with an infinite loop in which each kicks out the other (#14363). -} {- ************************************************************************ * * Predicates * * ************************************************************************ -} tcIsTcTyVar :: TcTyVar -> Bool -- See Note [TcTyVars and TyVars in the typechecker] tcIsTcTyVar tv = isTyVar tv isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool isTouchableMetaTyVar ctxt_tclvl tv | isTyVar tv -- See Note [Coercion variables in free variable lists] , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv , not (isFlattenInfo info) = ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl, ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl ) tv_tclvl `sameDepthAs` ctxt_tclvl | otherwise = False isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool isFloatedTouchableMetaTyVar ctxt_tclvl tv | isTyVar tv -- See Note [Coercion variables in free variable lists] , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv , not (isFlattenInfo info) = tv_tclvl `strictlyDeeperThan` ctxt_tclvl | otherwise = False isImmutableTyVar :: TyVar -> Bool isImmutableTyVar tv = isSkolemTyVar tv isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, isMetaTyVar, isAmbiguousTyVar, isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool isTyConableTyVar tv -- True of a meta-type variable that can be filled in -- with a type constructor application; in particular, -- not a TyVarTv | isTyVar tv -- See Note [Coercion variables in free variable lists] = case tcTyVarDetails tv of MetaTv { mtv_info = TyVarTv } -> False _ -> True | otherwise = True isFmvTyVar tv = ASSERT2( tcIsTcTyVar tv, ppr tv ) case tcTyVarDetails tv of MetaTv { mtv_info = FlatMetaTv } -> True _ -> False isFskTyVar tv = ASSERT2( tcIsTcTyVar tv, ppr tv ) case tcTyVarDetails tv of MetaTv { mtv_info = FlatSkolTv } -> True _ -> False -- | True of both given and wanted flatten-skolems (fmv and fsk) isFlattenTyVar tv = ASSERT2( tcIsTcTyVar tv, ppr tv ) case tcTyVarDetails tv of MetaTv { mtv_info = info } -> isFlattenInfo info _ -> False isSkolemTyVar tv = ASSERT2( tcIsTcTyVar tv, ppr tv ) case tcTyVarDetails tv of MetaTv {} -> False _other -> True isOverlappableTyVar tv | isTyVar tv -- See Note [Coercion variables in free variable lists] = case tcTyVarDetails tv of SkolemTv _ overlappable -> overlappable _ -> False | otherwise = False isMetaTyVar tv | isTyVar tv -- See Note [Coercion variables in free variable lists] = case tcTyVarDetails tv of MetaTv {} -> True _ -> False | otherwise = False -- isAmbiguousTyVar is used only when reporting type errors -- It picks out variables that are unbound, namely meta -- type variables and the RuntimUnk variables created by -- RtClosureInspect.zonkRTTIType. These are "ambiguous" in -- the sense that they stand for an as-yet-unknown type isAmbiguousTyVar tv | isTyVar tv -- See Note [Coercion variables in free variable lists] = case tcTyVarDetails tv of MetaTv {} -> True RuntimeUnk {} -> True _ -> False | otherwise = False isMetaTyVarTy :: TcType -> Bool isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv isMetaTyVarTy _ = False metaTyVarInfo :: TcTyVar -> MetaInfo metaTyVarInfo tv = case tcTyVarDetails tv of MetaTv { mtv_info = info } -> info _ -> pprPanic "metaTyVarInfo" (ppr tv) isFlattenInfo :: MetaInfo -> Bool isFlattenInfo FlatMetaTv = True isFlattenInfo FlatSkolTv = True isFlattenInfo _ = False metaTyVarTcLevel :: TcTyVar -> TcLevel metaTyVarTcLevel tv = case tcTyVarDetails tv of MetaTv { mtv_tclvl = tclvl } -> tclvl _ -> pprPanic "metaTyVarTcLevel" (ppr tv) metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel metaTyVarTcLevel_maybe tv = case tcTyVarDetails tv of MetaTv { mtv_tclvl = tclvl } -> Just tclvl _ -> Nothing metaTyVarRef :: TyVar -> IORef MetaDetails metaTyVarRef tv = case tcTyVarDetails tv of MetaTv { mtv_ref = ref } -> ref _ -> pprPanic "metaTyVarRef" (ppr tv) setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar setMetaTyVarTcLevel tv tclvl = case tcTyVarDetails tv of details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_tclvl = tclvl }) _ -> pprPanic "metaTyVarTcLevel" (ppr tv) isTyVarTyVar :: Var -> Bool isTyVarTyVar tv = case tcTyVarDetails tv of MetaTv { mtv_info = TyVarTv } -> True _ -> False isFlexi, isIndirect :: MetaDetails -> Bool isFlexi Flexi = True isFlexi _ = False isIndirect (Indirect _) = True isIndirect _ = False isRuntimeUnkSkol :: TyVar -> Bool -- Called only in TcErrors; see Note [Runtime skolems] there isRuntimeUnkSkol x | RuntimeUnk <- tcTyVarDetails x = True | otherwise = False mkTyVarNamePairs :: [TyVar] -> [(Name,TyVar)] -- Just pair each TyVar with its own name mkTyVarNamePairs tvs = [(tyVarName tv, tv) | tv <- tvs] findDupTyVarTvs :: [(Name,TcTyVar)] -> [(Name,Name)] -- If we have [...(x1,tv)...(x2,tv)...] -- return (x1,x2) in the result list findDupTyVarTvs prs = concatMap mk_result_prs $ findDupsEq eq_snd prs where eq_snd (_,tv1) (_,tv2) = tv1 == tv2 mk_result_prs ((n1,_) :| xs) = map (\(n2,_) -> (n1,n2)) xs {- ************************************************************************ * * \subsection{Tau, sigma and rho} * * ************************************************************************ -} mkSigmaTy :: [TyCoVarBinder] -> [PredType] -> Type -> Type mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau) -- | Make a sigma ty where all type variables are 'Inferred'. That is, -- they cannot be used with visible type application. mkInfSigmaTy :: [TyCoVar] -> [PredType] -> Type -> Type mkInfSigmaTy tyvars theta ty = mkSigmaTy (mkTyCoVarBinders Inferred tyvars) theta ty -- | Make a sigma ty where all type variables are "specified". That is, -- they can be used with visible type application mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkTyCoVarBinders Specified tyvars) preds ty mkPhiTy :: [PredType] -> Type -> Type mkPhiTy = mkInvisFunTys --------------- getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to -- construct a dictionary function name getDFunTyKey ty | Just ty' <- coreView ty = getDFunTyKey ty' getDFunTyKey (TyVarTy tv) = getOccName tv getDFunTyKey (TyConApp tc _) = getOccName tc getDFunTyKey (LitTy x) = getDFunTyLitKey x getDFunTyKey (AppTy fun _) = getDFunTyKey fun getDFunTyKey (FunTy {}) = getOccName funTyCon getDFunTyKey (ForAllTy _ t) = getDFunTyKey t getDFunTyKey (CastTy ty _) = getDFunTyKey ty getDFunTyKey t@(CoercionTy _) = pprPanic "getDFunTyKey" (ppr t) getDFunTyLitKey :: TyLit -> OccName getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm {- ********************************************************************* * * Building types * * ********************************************************************* -} -- ToDo: I think we need Tc versions of these -- Reason: mkCastTy checks isReflexiveCastTy, which checks -- for equality; and that has a different answer -- depending on whether or not Type = Constraint mkTcAppTys :: Type -> [Type] -> Type mkTcAppTys = mkAppTys mkTcAppTy :: Type -> Type -> Type mkTcAppTy = mkAppTy mkTcCastTy :: Type -> Coercion -> Type mkTcCastTy = mkCastTy -- Do we need a tc version of mkCastTy? {- ************************************************************************ * * \subsection{Expanding and splitting} * * ************************************************************************ These tcSplit functions are like their non-Tc analogues, but *) they do not look through newtypes However, they are non-monadic and do not follow through mutable type variables. It's up to you to make sure this doesn't matter. -} -- | Splits a forall type into a list of 'TyBinder's and the inner type. -- Always succeeds, even if it returns an empty list. tcSplitPiTys :: Type -> ([TyBinder], Type) tcSplitPiTys ty = ASSERT( all isTyBinder (fst sty) ) sty where sty = splitPiTys ty -- | Splits a type into a TyBinder and a body, if possible. Panics otherwise tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type) tcSplitPiTy_maybe ty = ASSERT( isMaybeTyBinder sty ) sty where sty = splitPiTy_maybe ty isMaybeTyBinder (Just (t,_)) = isTyBinder t isMaybeTyBinder _ = True tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type) tcSplitForAllTy_maybe ty | Just ty' <- tcView ty = tcSplitForAllTy_maybe ty' tcSplitForAllTy_maybe (ForAllTy tv ty) = ASSERT( isTyVarBinder tv ) Just (tv, ty) tcSplitForAllTy_maybe _ = Nothing -- | Like 'tcSplitPiTys', but splits off only named binders, -- returning just the tycovars. tcSplitForAllTys :: Type -> ([TyVar], Type) tcSplitForAllTys ty = ASSERT( all isTyVar (fst sty) ) sty where sty = splitForAllTys ty -- | Like 'tcSplitForAllTys', but only splits a 'ForAllTy' if -- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility -- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided -- as an argument to this function. tcSplitForAllTysSameVis :: ArgFlag -> Type -> ([TyVar], Type) tcSplitForAllTysSameVis supplied_argf ty = ASSERT( all isTyVar (fst sty) ) sty where sty = splitForAllTysSameVis supplied_argf ty -- | Like 'tcSplitForAllTys', but splits off only named binders. tcSplitForAllVarBndrs :: Type -> ([TyVarBinder], Type) tcSplitForAllVarBndrs ty = ASSERT( all isTyVarBinder (fst sty)) sty where sty = splitForAllVarBndrs ty -- | Is this a ForAllTy with a named binder? tcIsForAllTy :: Type -> Bool tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' tcIsForAllTy (ForAllTy {}) = True tcIsForAllTy _ = False tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) -- Split off the first predicate argument from a type tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty' tcSplitPredFunTy_maybe (FunTy { ft_af = InvisArg , ft_arg = arg, ft_res = res }) = Just (arg, res) tcSplitPredFunTy_maybe _ = Nothing tcSplitPhiTy :: Type -> (ThetaType, Type) tcSplitPhiTy ty = split ty [] where split ty ts = case tcSplitPredFunTy_maybe ty of Just (pred, ty) -> split ty (pred:ts) Nothing -> (reverse ts, ty) -- | Split a sigma type into its parts. tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type) tcSplitSigmaTy ty = case tcSplitForAllTys ty of (tvs, rho) -> case tcSplitPhiTy rho of (theta, tau) -> (tvs, theta, tau) -- | Split a sigma type into its parts, going underneath as many @ForAllTy@s -- as possible. For example, given this type synonym: -- -- @ -- type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t -- @ -- -- if you called @tcSplitSigmaTy@ on this type: -- -- @ -- forall s t a b. Each s t a b => Traversal s t a b -- @ -- -- then it would return @([s,t,a,b], [Each s t a b], Traversal s t a b)@. But -- if you instead called @tcSplitNestedSigmaTys@ on the type, it would return -- @([s,t,a,b,f], [Each s t a b, Applicative f], (a -> f b) -> s -> f t)@. tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type) -- NB: This is basically a pure version of deeplyInstantiate (from Inst) that -- doesn't compute an HsWrapper. tcSplitNestedSigmaTys ty -- If there's a forall, split it apart and try splitting the rho type -- underneath it. | Just (arg_tys, tvs1, theta1, rho1) <- tcDeepSplitSigmaTy_maybe ty = let (tvs2, theta2, rho2) = tcSplitNestedSigmaTys rho1 in (tvs1 ++ tvs2, theta1 ++ theta2, mkVisFunTys arg_tys rho2) -- If there's no forall, we're done. | otherwise = ([], [], ty) ----------------------- tcDeepSplitSigmaTy_maybe :: TcSigmaType -> Maybe ([TcType], [TyVar], ThetaType, TcSigmaType) -- Looks for a *non-trivial* quantified type, under zero or more function arrows -- By "non-trivial" we mean either tyvars or constraints are non-empty tcDeepSplitSigmaTy_maybe ty | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty = Just (arg_ty:arg_tys, tvs, theta, rho) | (tvs, theta, rho) <- tcSplitSigmaTy ty , not (null tvs && null theta) = Just ([], tvs, theta, rho) | otherwise = Nothing ----------------------- tcTyConAppTyCon :: Type -> TyCon tcTyConAppTyCon ty = case tcTyConAppTyCon_maybe ty of Just tc -> tc Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty) -- | Like 'tcRepSplitTyConApp_maybe', but only returns the 'TyCon'. tcTyConAppTyCon_maybe :: Type -> Maybe TyCon tcTyConAppTyCon_maybe ty | Just ty' <- tcView ty = tcTyConAppTyCon_maybe ty' tcTyConAppTyCon_maybe (TyConApp tc _) = Just tc tcTyConAppTyCon_maybe (FunTy { ft_af = VisArg }) = Just funTyCon -- (=>) is /not/ a TyCon in its own right -- C.f. tcRepSplitAppTy_maybe tcTyConAppTyCon_maybe _ = Nothing tcTyConAppArgs :: Type -> [Type] tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of Just (_, args) -> args Nothing -> pprPanic "tcTyConAppArgs" (pprType ty) tcSplitTyConApp :: Type -> (TyCon, [Type]) tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of Just stuff -> stuff Nothing -> pprPanic "tcSplitTyConApp" (pprType ty) ----------------------- tcSplitFunTys :: Type -> ([Type], Type) tcSplitFunTys ty = case tcSplitFunTy_maybe ty of Nothing -> ([], ty) Just (arg,res) -> (arg:args, res') where (args,res') = tcSplitFunTys res tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) tcSplitFunTy_maybe ty | Just ty' <- tcView ty = tcSplitFunTy_maybe ty' tcSplitFunTy_maybe (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) | VisArg <- af = Just (arg, res) tcSplitFunTy_maybe _ = Nothing -- Note the VisArg guard -- Consider (?x::Int) => Bool -- We don't want to treat this as a function type! -- A concrete example is test tc230: -- f :: () -> (?p :: ()) => () -> () -- -- g = f () () tcSplitFunTysN :: Arity -- n: Number of desired args -> TcRhoType -> Either Arity -- Number of missing arrows ([TcSigmaType], -- Arg types (always N types) TcSigmaType) -- The rest of the type -- ^ Split off exactly the specified number argument types -- Returns -- (Left m) if there are 'm' missing arrows in the type -- (Right (tys,res)) if the type looks like t1 -> ... -> tn -> res tcSplitFunTysN n ty | n == 0 = Right ([], ty) | Just (arg,res) <- tcSplitFunTy_maybe ty = case tcSplitFunTysN (n-1) res of Left m -> Left m Right (args,body) -> Right (arg:args, body) | otherwise = Left n tcSplitFunTy :: Type -> (Type, Type) tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty) tcFunArgTy :: Type -> Type tcFunArgTy ty = fst (tcSplitFunTy ty) tcFunResultTy :: Type -> Type tcFunResultTy ty = snd (tcSplitFunTy ty) -- | Strips off n *visible* arguments and returns the resulting type tcFunResultTyN :: HasDebugCallStack => Arity -> Type -> Type tcFunResultTyN n ty | Right (_, res_ty) <- tcSplitFunTysN n ty = res_ty | otherwise = pprPanic "tcFunResultTyN" (ppr n <+> ppr ty) ----------------------- tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty' tcSplitAppTy_maybe ty = tcRepSplitAppTy_maybe ty tcSplitAppTy :: Type -> (Type, Type) tcSplitAppTy ty = case tcSplitAppTy_maybe ty of Just stuff -> stuff Nothing -> pprPanic "tcSplitAppTy" (pprType ty) tcSplitAppTys :: Type -> (Type, [Type]) tcSplitAppTys ty = go ty [] where go ty args = case tcSplitAppTy_maybe ty of Just (ty', arg) -> go ty' (arg:args) Nothing -> (ty,args) -- | Returns the number of arguments in the given type, without -- looking through synonyms. This is used only for error reporting. -- We don't look through synonyms because of #11313. tcRepGetNumAppTys :: Type -> Arity tcRepGetNumAppTys = length . snd . repSplitAppTys ----------------------- -- | If the type is a tyvar, possibly under a cast, returns it, along -- with the coercion. Thus, the co is :: kind tv ~N kind type tcGetCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) tcGetCastedTyVar_maybe ty | Just ty' <- tcView ty = tcGetCastedTyVar_maybe ty' tcGetCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) tcGetCastedTyVar_maybe (TyVarTy tv) = Just (tv, mkNomReflCo (tyVarKind tv)) tcGetCastedTyVar_maybe _ = Nothing tcGetTyVar_maybe :: Type -> Maybe TyVar tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty' tcGetTyVar_maybe (TyVarTy tv) = Just tv tcGetTyVar_maybe _ = Nothing tcGetTyVar :: String -> Type -> TyVar tcGetTyVar msg ty = case tcGetTyVar_maybe ty of Just tv -> tv Nothing -> pprPanic msg (ppr ty) tcIsTyVarTy :: Type -> Bool tcIsTyVarTy ty | Just ty' <- tcView ty = tcIsTyVarTy ty' tcIsTyVarTy (CastTy ty _) = tcIsTyVarTy ty -- look through casts, as -- this is only used for -- e.g., FlexibleContexts tcIsTyVarTy (TyVarTy _) = True tcIsTyVarTy _ = False ----------------------- tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type]) -- Split the type of a dictionary function -- We don't use tcSplitSigmaTy, because a DFun may (with NDP) -- have non-Pred arguments, such as -- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m -- -- Also NB splitFunTys, not tcSplitFunTys; -- the latter specifically stops at PredTy arguments, -- and we don't want to do that here tcSplitDFunTy ty = case tcSplitForAllTys ty of { (tvs, rho) -> case splitFunTys rho of { (theta, tau) -> case tcSplitDFunHead tau of { (clas, tys) -> (tvs, theta, clas, tys) }}} tcSplitDFunHead :: Type -> (Class, [Type]) tcSplitDFunHead = getClassPredTys tcSplitMethodTy :: Type -> ([TyVar], PredType, Type) -- A class method (selector) always has a type like -- forall as. C as => blah -- So if the class looks like -- class C a where -- op :: forall b. (Eq a, Ix b) => a -> b -- the class method type looks like -- op :: forall a. C a => forall b. (Eq a, Ix b) => a -> b -- -- tcSplitMethodTy just peels off the outer forall and -- that first predicate tcSplitMethodTy ty | (sel_tyvars,sel_rho) <- tcSplitForAllTys ty , Just (first_pred, local_meth_ty) <- tcSplitPredFunTy_maybe sel_rho = (sel_tyvars, first_pred, local_meth_ty) | otherwise = pprPanic "tcSplitMethodTy" (ppr ty) {- ********************************************************************* * * Type equalities * * ********************************************************************* -} tcEqKind :: HasDebugCallStack => TcKind -> TcKind -> Bool tcEqKind = tcEqType tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool -- tcEqType is a proper implements the same Note [Non-trivial definitional -- equality] (in TyCoRep) as `eqType`, but Type.eqType believes (* == -- Constraint), and that is NOT what we want in the type checker! tcEqType ty1 ty2 = tc_eq_type False False ki1 ki2 && tc_eq_type False False ty1 ty2 where ki1 = tcTypeKind ty1 ki2 = tcTypeKind ty2 -- | Just like 'tcEqType', but will return True for types of different kinds -- as long as their non-coercion structure is identical. tcEqTypeNoKindCheck :: TcType -> TcType -> Bool tcEqTypeNoKindCheck ty1 ty2 = tc_eq_type False False ty1 ty2 -- | Like 'tcEqType', but returns True if the /visible/ part of the types -- are equal, even if they are really unequal (in the invisible bits) tcEqTypeVis :: TcType -> TcType -> Bool tcEqTypeVis ty1 ty2 = tc_eq_type False True ty1 ty2 -- | Like 'pickyEqTypeVis', but returns a Bool for convenience pickyEqType :: TcType -> TcType -> Bool -- Check when two types _look_ the same, _including_ synonyms. -- So (pickyEqType String [Char]) returns False -- This ignores kinds and coercions, because this is used only for printing. pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2 -- | Real worker for 'tcEqType'. No kind check! tc_eq_type :: Bool -- ^ True <=> do not expand type synonyms -> Bool -- ^ True <=> compare visible args only -> Type -> Type -> Bool -- Flags False, False is the usual setting for tc_eq_type tc_eq_type keep_syns vis_only orig_ty1 orig_ty2 = go orig_env orig_ty1 orig_ty2 where go :: RnEnv2 -> Type -> Type -> Bool go env t1 t2 | not keep_syns, Just t1' <- tcView t1 = go env t1' t2 go env t1 t2 | not keep_syns, Just t2' <- tcView t2 = go env t1 t2' go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2 go env (ForAllTy (Bndr tv1 vis1) ty1) (ForAllTy (Bndr tv2 vis2) ty2) = vis1 == vis2 && (vis_only || go env (varType tv1) (varType tv2)) && go (rnBndr2 env tv1 tv2) ty1 ty2 -- Make sure we handle all FunTy cases since falling through to the -- AppTy case means that tcRepSplitAppTy_maybe may see an unzonked -- kind variable, which causes things to blow up. go env (FunTy _ arg1 res1) (FunTy _ arg2 res2) = go env arg1 arg2 && go env res1 res2 go env ty (FunTy _ arg res) = eqFunTy env arg res ty go env (FunTy _ arg res) ty = eqFunTy env arg res ty -- See Note [Equality on AppTys] in Type go env (AppTy s1 t1) ty2 | Just (s2, t2) <- tcRepSplitAppTy_maybe ty2 = go env s1 s2 && go env t1 t2 go env ty1 (AppTy s2 t2) | Just (s1, t1) <- tcRepSplitAppTy_maybe ty1 = go env s1 s2 && go env t1 t2 go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) = tc1 == tc2 && gos env (tc_vis tc1) ts1 ts2 go env (CastTy t1 _) t2 = go env t1 t2 go env t1 (CastTy t2 _) = go env t1 t2 go _ (CoercionTy {}) (CoercionTy {}) = True go _ _ _ = False gos _ _ [] [] = True gos env (ig:igs) (t1:ts1) (t2:ts2) = (ig || go env t1 t2) && gos env igs ts1 ts2 gos _ _ _ _ = False tc_vis :: TyCon -> [Bool] -- True for the fields we should ignore tc_vis tc | vis_only = inviss ++ repeat False -- Ignore invisibles | otherwise = repeat False -- Ignore nothing -- The repeat False is necessary because tycons -- can legitimately be oversaturated where bndrs = tyConBinders tc inviss = map isInvisibleTyConBinder bndrs orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] -- @eqFunTy arg res ty@ is True when @ty@ equals @FunTy arg res@. This is -- sometimes hard to know directly because @ty@ might have some casts -- obscuring the FunTy. And 'splitAppTy' is difficult because we can't -- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or -- res is unzonked/unflattened. Thus this function, which handles this -- corner case. eqFunTy :: RnEnv2 -> Type -> Type -> Type -> Bool -- Last arg is /not/ FunTy eqFunTy env arg res ty@(AppTy{}) = get_args ty [] where get_args :: Type -> [Type] -> Bool get_args (AppTy f x) args = get_args f (x:args) get_args (CastTy t _) args = get_args t args get_args (TyConApp tc tys) args | tc == funTyCon , [_, _, arg', res'] <- tys ++ args = go env arg arg' && go env res res' get_args _ _ = False eqFunTy _ _ _ _ = False {- ********************************************************************* * * Predicate types * * ************************************************************************ Deconstructors and tests on predicate types Note [Kind polymorphic type classes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ class C f where... -- C :: forall k. k -> Constraint g :: forall (f::*). C f => f -> f Here the (C f) in the signature is really (C * f), and we don't want to complain that the * isn't a type variable! -} isTyVarClassPred :: PredType -> Bool isTyVarClassPred ty = case getClassPredTys_maybe ty of Just (_, tys) -> all isTyVarTy tys _ -> False ------------------------- checkValidClsArgs :: Bool -> Class -> [KindOrType] -> Bool -- If the Bool is True (flexible contexts), return True (i.e. ok) -- Otherwise, check that the type (not kind) args are all headed by a tyvar -- E.g. (Eq a) accepted, (Eq (f a)) accepted, but (Eq Int) rejected -- This function is here rather than in TcValidity because it is -- called from TcSimplify, which itself is imported by TcValidity checkValidClsArgs flexible_contexts cls kts | flexible_contexts = True | otherwise = all hasTyVarHead tys where tys = filterOutInvisibleTypes (classTyCon cls) kts hasTyVarHead :: Type -> Bool -- Returns true of (a t1 .. tn), where 'a' is a type variable hasTyVarHead ty -- Haskell 98 allows predicates of form | tcIsTyVarTy ty = True -- C (a ty1 .. tyn) | otherwise -- where a is a type variable = case tcSplitAppTy_maybe ty of Just (ty, _) -> hasTyVarHead ty Nothing -> False evVarPred :: EvVar -> PredType evVarPred var = varType var -- Historical note: I used to have an ASSERT here, -- checking (isEvVarType (varType var)). But with something like -- f :: c => _ -> _ -- we end up with (c :: kappa), and (kappa ~ Constraint). Until -- we solve and zonk (which there is no particular reason to do for -- partial signatures, (isEvVarType kappa) will return False. But -- nothing is wrong. So I just removed the ASSERT. ------------------ -- | When inferring types, should we quantify over a given predicate? -- Generally true of classes; generally false of equality constraints. -- Equality constraints that mention quantified type variables and -- implicit variables complicate the story. See Notes -- [Inheriting implicit parameters] and [Quantifying over equality constraints] pickQuantifiablePreds :: TyVarSet -- Quantifying over these -> TcThetaType -- Proposed constraints to quantify -> TcThetaType -- A subset that we can actually quantify -- This function decides whether a particular constraint should be -- quantified over, given the type variables that are being quantified pickQuantifiablePreds qtvs theta = let flex_ctxt = True in -- Quantify over non-tyvar constraints, even without -- -XFlexibleContexts: see #10608, #10351 -- flex_ctxt <- xoptM Opt_FlexibleContexts mapMaybe (pick_me flex_ctxt) theta where pick_me flex_ctxt pred = case classifyPredType pred of ClassPred cls tys | Just {} <- isCallStackPred cls tys -- NEVER infer a CallStack constraint. Otherwise we let -- the constraints bubble up to be solved from the outer -- context, or be defaulted when we reach the top-level. -- See Note [Overview of implicit CallStacks] -> Nothing | isIPClass cls -> Just pred -- See note [Inheriting implicit parameters] | pick_cls_pred flex_ctxt cls tys -> Just pred EqPred eq_rel ty1 ty2 | quantify_equality eq_rel ty1 ty2 , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2 -- boxEqPred: See Note [Lift equality constaints when quantifying] , pick_cls_pred flex_ctxt cls tys -> Just (mkClassPred cls tys) IrredPred ty | tyCoVarsOfType ty `intersectsVarSet` qtvs -> Just pred _ -> Nothing pick_cls_pred flex_ctxt cls tys = tyCoVarsOfTypes tys `intersectsVarSet` qtvs && (checkValidClsArgs flex_ctxt cls tys) -- Only quantify over predicates that checkValidType -- will pass! See #10351. -- See Note [Quantifying over equality constraints] quantify_equality NomEq ty1 ty2 = quant_fun ty1 || quant_fun ty2 quantify_equality ReprEq _ _ = True quant_fun ty = case tcSplitTyConApp_maybe ty of Just (tc, tys) | isTypeFamilyTyCon tc -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs _ -> False boxEqPred :: EqRel -> Type -> Type -> Maybe (Class, [Type]) -- Given (t1 ~# t2) or (t1 ~R# t2) return the boxed version -- (t1 ~ t2) or (t1 `Coercible` t2) boxEqPred eq_rel ty1 ty2 = case eq_rel of NomEq | homo_kind -> Just (eqClass, [k1, ty1, ty2]) | otherwise -> Just (heqClass, [k1, k2, ty1, ty2]) ReprEq | homo_kind -> Just (coercibleClass, [k1, ty1, ty2]) | otherwise -> Nothing -- Sigh: we do not have hererogeneous Coercible -- so we can't abstract over it -- Nothing fundamental: we could add it where k1 = tcTypeKind ty1 k2 = tcTypeKind ty2 homo_kind = k1 `tcEqType` k2 pickCapturedPreds :: TyVarSet -- Quantifying over these -> TcThetaType -- Proposed constraints to quantify -> TcThetaType -- A subset that we can actually quantify -- A simpler version of pickQuantifiablePreds, used to winnow down -- the inferred constraints of a group of bindings, into those for -- one particular identifier pickCapturedPreds qtvs theta = filter captured theta where captured pred = isIPPred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs) -- Superclasses type PredWithSCs a = (PredType, [PredType], a) mkMinimalBySCs :: forall a. (a -> PredType) -> [a] -> [a] -- Remove predicates that -- -- - are the same as another predicate -- -- - can be deduced from another by superclasses, -- -- - are a reflexive equality (e.g * ~ *) -- (see Note [Remove redundant provided dicts] in TcPatSyn) -- -- The result is a subset of the input. -- The 'a' is just paired up with the PredType; -- typically it might be a dictionary Id mkMinimalBySCs get_pred xs = go preds_with_scs [] where preds_with_scs :: [PredWithSCs a] preds_with_scs = [ (pred, pred : transSuperClasses pred, x) | x <- xs , let pred = get_pred x ] go :: [PredWithSCs a] -- Work list -> [PredWithSCs a] -- Accumulating result -> [a] go [] min_preds = reverse (map thdOf3 min_preds) -- The 'reverse' isn't strictly necessary, but it -- means that the results are returned in the same -- order as the input, which is generally saner go (work_item@(p,_,_) : work_list) min_preds | EqPred _ t1 t2 <- classifyPredType p , t1 `tcEqType` t2 -- See TcPatSyn -- Note [Remove redundant provided dicts] = go work_list min_preds | p `in_cloud` work_list || p `in_cloud` min_preds = go work_list min_preds | otherwise = go work_list (work_item : min_preds) in_cloud :: PredType -> [PredWithSCs a] -> Bool in_cloud p ps = or [ p `tcEqType` p' | (_, scs, _) <- ps, p' <- scs ] transSuperClasses :: PredType -> [PredType] -- (transSuperClasses p) returns (p's superclasses) not including p -- Stop if you encounter the same class again -- See Note [Expanding superclasses] transSuperClasses p = go emptyNameSet p where go :: NameSet -> PredType -> [PredType] go rec_clss p | ClassPred cls tys <- classifyPredType p , let cls_nm = className cls , not (cls_nm `elemNameSet` rec_clss) , let rec_clss' | isCTupleClass cls = rec_clss | otherwise = rec_clss `extendNameSet` cls_nm = [ p' | sc <- immSuperClasses cls tys , p' <- sc : go rec_clss' sc ] | otherwise = [] immSuperClasses :: Class -> [Type] -> [PredType] immSuperClasses cls tys = substTheta (zipTvSubst tyvars tys) sc_theta where (tyvars,sc_theta,_,_) = classBigSig cls isImprovementPred :: PredType -> Bool -- Either it's an equality, or has some functional dependency isImprovementPred ty = case classifyPredType ty of EqPred NomEq t1 t2 -> not (t1 `tcEqType` t2) EqPred ReprEq _ _ -> False ClassPred cls _ -> classHasFds cls IrredPred {} -> True -- Might have equalities after reduction? ForAllPred {} -> False -- | Is the equality -- a ~r ...a.... -- definitely insoluble or not? -- a ~r Maybe a -- Definitely insoluble -- a ~N ...(F a)... -- Not definitely insoluble -- -- Perhaps (F a) reduces to Int -- a ~R ...(N a)... -- Not definitely insoluble -- -- Perhaps newtype N a = MkN Int -- See Note [Occurs check error] in -- TcCanonical for the motivation for this function. isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool isInsolubleOccursCheck eq_rel tv ty = go ty where go ty | Just ty' <- tcView ty = go ty' go (TyVarTy tv') = tv == tv' || go (tyVarKind tv') go (LitTy {}) = False go (AppTy t1 t2) = case eq_rel of -- See Note [AppTy and ReprEq] NomEq -> go t1 || go t2 ReprEq -> go t1 go (FunTy _ t1 t2) = go t1 || go t2 go (ForAllTy (Bndr tv' _) inner_ty) | tv' == tv = False | otherwise = go (varType tv') || go inner_ty go (CastTy ty _) = go ty -- ToDo: what about the coercion go (CoercionTy _) = False -- ToDo: what about the coercion go (TyConApp tc tys) | isGenerativeTyCon tc role = any go tys | otherwise = any go (drop (tyConArity tc) tys) -- (a ~ F b a), where F has arity 1, -- has an insoluble occurs check role = eqRelRole eq_rel {- Note [Expanding superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we expand superclasses, we use the following algorithm: transSuperClasses( C tys ) returns the transitive superclasses of (C tys), not including C itself For example class C a b => D a b class D b a => C a b Then transSuperClasses( Ord ty ) = [Eq ty] transSuperClasses( C ta tb ) = [D tb ta, C tb ta] Notice that in the recursive-superclass case we include C again at the end of the chain. One could exclude C in this case, but the code is more awkward and there seems no good reason to do so. (However C.f. TcCanonical.mk_strict_superclasses, which /does/ appear to do so.) The algorithm is expand( so_far, pred ): 1. If pred is not a class constraint, return empty set Otherwise pred = C ts 2. If C is in so_far, return empty set (breaks loops) 3. Find the immediate superclasses constraints of (C ts) 4. For each such sc_pred, return (sc_pred : expand( so_far+C, D ss ) Notice that * With normal Haskell-98 classes, the loop-detector will never bite, so we'll get all the superclasses. * We need the loop-breaker in case we have UndecidableSuperClasses on * Since there is only a finite number of distinct classes, expansion must terminate. * The loop breaking is a bit conservative. Notably, a tuple class could contain many times without threatening termination: (Eq a, (Ord a, Ix a)) And this is try of any class that we can statically guarantee as non-recursive (in some sense). For now, we just make a special case for tuples. Something better would be cool. See also TcTyDecls.checkClassCycles. Note [Lift equality constaints when quantifying] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We can't quantify over a constraint (t1 ~# t2) because that isn't a predicate type; see Note [Types for coercions, predicates, and evidence] in TyCoRep. So we have to 'lift' it to (t1 ~ t2). Similarly (~R#) must be lifted to Coercible. This tiresome lifting is the reason that pick_me (in pickQuantifiablePreds) returns a Maybe rather than a Bool. Note [Quantifying over equality constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Should we quantify over an equality constraint (s ~ t)? In general, we don't. Doing so may simply postpone a type error from the function definition site to its call site. (At worst, imagine (Int ~ Bool)). However, consider this forall a. (F [a] ~ Int) => blah Should we quantify over the (F [a] ~ Int)? Perhaps yes, because at the call site we will know 'a', and perhaps we have instance F [Bool] = Int. So we *do* quantify over a type-family equality where the arguments mention the quantified variables. Note [Inheriting implicit parameters] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this: f x = (x::Int) + ?y where f is *not* a top-level binding. From the RHS of f we'll get the constraint (?y::Int). There are two types we might infer for f: f :: Int -> Int (so we get ?y from the context of f's definition), or f :: (?y::Int) => Int -> Int At first you might think the first was better, because then ?y behaves like a free variable of the definition, rather than having to be passed at each call site. But of course, the WHOLE IDEA is that ?y should be passed at each call site (that's what dynamic binding means) so we'd better infer the second. BOTTOM LINE: when *inferring types* you must quantify over implicit parameters, *even if* they don't mention the bound type variables. Reason: because implicit parameters, uniquely, have local instance declarations. See pickQuantifiablePreds. Note [Quantifying over equality constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Should we quantify over an equality constraint (s ~ t)? In general, we don't. Doing so may simply postpone a type error from the function definition site to its call site. (At worst, imagine (Int ~ Bool)). However, consider this forall a. (F [a] ~ Int) => blah Should we quantify over the (F [a] ~ Int). Perhaps yes, because at the call site we will know 'a', and perhaps we have instance F [Bool] = Int. So we *do* quantify over a type-family equality where the arguments mention the quantified variables. ************************************************************************ * * Classifying types * * ************************************************************************ -} isSigmaTy :: TcType -> Bool -- isSigmaTy returns true of any qualified type. It doesn't -- *necessarily* have any foralls. E.g -- f :: (?x::Int) => Int -> Int isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty' isSigmaTy (ForAllTy {}) = True isSigmaTy (FunTy { ft_af = InvisArg }) = True isSigmaTy _ = False isRhoTy :: TcType -> Bool -- True of TcRhoTypes; see Note [TcRhoType] isRhoTy ty | Just ty' <- tcView ty = isRhoTy ty' isRhoTy (ForAllTy {}) = False isRhoTy (FunTy { ft_af = VisArg, ft_res = r }) = isRhoTy r isRhoTy _ = True -- | Like 'isRhoTy', but also says 'True' for 'Infer' types isRhoExpTy :: ExpType -> Bool isRhoExpTy (Check ty) = isRhoTy ty isRhoExpTy (Infer {}) = True isOverloadedTy :: Type -> Bool -- Yes for a type of a function that might require evidence-passing -- Used only by bindLocalMethods isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty' isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty isOverloadedTy (FunTy { ft_af = InvisArg }) = True isOverloadedTy _ = False isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy, isUnitTy, isCharTy, isAnyTy :: Type -> Bool isFloatTy = is_tc floatTyConKey isDoubleTy = is_tc doubleTyConKey isIntegerTy = is_tc integerTyConKey isIntTy = is_tc intTyConKey isWordTy = is_tc wordTyConKey isBoolTy = is_tc boolTyConKey isUnitTy = is_tc unitTyConKey isCharTy = is_tc charTyConKey isAnyTy = is_tc anyTyConKey -- | Does a type represent a floating-point number? isFloatingTy :: Type -> Bool isFloatingTy ty = isFloatTy ty || isDoubleTy ty -- | Is a type 'String'? isStringTy :: Type -> Bool isStringTy ty = case tcSplitTyConApp_maybe ty of Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty _ -> False -- | Is a type a 'CallStack'? isCallStackTy :: Type -> Bool isCallStackTy ty | Just tc <- tyConAppTyCon_maybe ty = tc `hasKey` callStackTyConKey | otherwise = False -- | Is a 'PredType' a 'CallStack' implicit parameter? -- -- If so, return the name of the parameter. isCallStackPred :: Class -> [Type] -> Maybe FastString isCallStackPred cls tys | [ty1, ty2] <- tys , isIPClass cls , isCallStackTy ty2 = isStrLitTy ty1 | otherwise = Nothing is_tc :: Unique -> Type -> Bool -- Newtypes are opaque to this is_tc uniq ty = case tcSplitTyConApp_maybe ty of Just (tc, _) -> uniq == getUnique tc Nothing -> False -- | Does the given tyvar appear at the head of a chain of applications -- (a t1 ... tn) isTyVarHead :: TcTyVar -> TcType -> Bool isTyVarHead tv (TyVarTy tv') = tv == tv' isTyVarHead tv (AppTy fun _) = isTyVarHead tv fun isTyVarHead tv (CastTy ty _) = isTyVarHead tv ty isTyVarHead _ (TyConApp {}) = False isTyVarHead _ (LitTy {}) = False isTyVarHead _ (ForAllTy {}) = False isTyVarHead _ (FunTy {}) = False isTyVarHead _ (CoercionTy {}) = False {- Note [AppTy and ReprEq] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a ~R# b a a ~R# a b The former is /not/ a definite error; we might instantiate 'b' with Id newtype Id a = MkId a but the latter /is/ a definite error. On the other hand, with nominal equality, both are definite errors -} isRigidTy :: TcType -> Bool isRigidTy ty | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal | Just {} <- tcSplitAppTy_maybe ty = True | isForAllTy ty = True | otherwise = False -- | Is this type *almost function-free*? See Note [Almost function-free] -- in TcRnTypes isAlmostFunctionFree :: TcType -> Bool isAlmostFunctionFree ty | Just ty' <- tcView ty = isAlmostFunctionFree ty' isAlmostFunctionFree (TyVarTy {}) = True isAlmostFunctionFree (AppTy ty1 ty2) = isAlmostFunctionFree ty1 && isAlmostFunctionFree ty2 isAlmostFunctionFree (TyConApp tc args) | isTypeFamilyTyCon tc = False | otherwise = all isAlmostFunctionFree args isAlmostFunctionFree (ForAllTy bndr _) = isAlmostFunctionFree (binderType bndr) isAlmostFunctionFree (FunTy _ ty1 ty2) = isAlmostFunctionFree ty1 && isAlmostFunctionFree ty2 isAlmostFunctionFree (LitTy {}) = True isAlmostFunctionFree (CastTy ty _) = isAlmostFunctionFree ty isAlmostFunctionFree (CoercionTy {}) = True {- ************************************************************************ * * \subsection{Misc} * * ************************************************************************ Note [Visible type application] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC implements a generalisation of the algorithm described in the "Visible Type Application" paper (available from http://www.cis.upenn.edu/~sweirich/publications.html). A key part of that algorithm is to distinguish user-specified variables from inferred variables. For example, the following should typecheck: f :: forall a b. a -> b -> b f = const id g = const id x = f @Int @Bool 5 False y = g 5 @Bool False The idea is that we wish to allow visible type application when we are instantiating a specified, fixed variable. In practice, specified, fixed variables are either written in a type signature (or annotation), OR are imported from another module. (We could do better here, for example by doing SCC analysis on parts of a module and considering any type from outside one's SCC to be fully specified, but this is very confusing to users. The simple rule above is much more straightforward and predictable.) So, both of f's quantified variables are specified and may be instantiated. But g has no type signature, so only id's variable is specified (because id is imported). We write the type of g as forall {a}. a -> forall b. b -> b. Note that the a is in braces, meaning it cannot be instantiated with visible type application. Tracking specified vs. inferred variables is done conveniently by a field in TyBinder. -} deNoteType :: Type -> Type -- Remove all *outermost* type synonyms and other notes deNoteType ty | Just ty' <- coreView ty = deNoteType ty' deNoteType ty = ty {- Find the free tycons and classes of a type. This is used in the front end of the compiler. -} {- ************************************************************************ * * \subsection[TysWiredIn-ext-type]{External types} * * ************************************************************************ The compiler's foreign function interface supports the passing of a restricted set of types as arguments and results (the restricting factor being the ) -} tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type) -- (tcSplitIOType_maybe t) returns Just (IO,t',co) -- if co : t ~ IO t' -- returns Nothing otherwise tcSplitIOType_maybe ty = case tcSplitTyConApp_maybe ty of Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey -> Just (io_tycon, io_res_ty) _ -> Nothing isFFITy :: Type -> Bool -- True for any TyCon that can possibly be an arg or result of an FFI call isFFITy ty = isValid (checkRepTyCon legalFFITyCon ty) isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity -- Checks for valid argument type for a 'foreign import' isFFIArgumentTy dflags safety ty = checkRepTyCon (legalOutgoingTyCon dflags safety) ty isFFIExternalTy :: Type -> Validity -- Types that are allowed as arguments of a 'foreign export' isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty isFFIImportResultTy :: DynFlags -> Type -> Validity isFFIImportResultTy dflags ty = checkRepTyCon (legalFIResultTyCon dflags) ty isFFIExportResultTy :: Type -> Validity isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty isFFIDynTy :: Type -> Type -> Validity -- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of -- either, and the wrapped function type must be equal to the given type. -- We assume that all types have been run through normaliseFfiType, so we don't -- need to worry about expanding newtypes here. isFFIDynTy expected ty -- Note [Foreign import dynamic] -- In the example below, expected would be 'CInt -> IO ()', while ty would -- be 'FunPtr (CDouble -> IO ())'. | Just (tc, [ty']) <- splitTyConApp_maybe ty , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey] , eqType ty' expected = IsValid | otherwise = NotValid (vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma , text " Actual:" <+> ppr ty ]) isFFILabelTy :: Type -> Validity -- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. isFFILabelTy ty = checkRepTyCon ok ty where ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey = IsValid | otherwise = NotValid (text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") isFFIPrimArgumentTy :: DynFlags -> Type -> Validity -- Checks for valid argument type for a 'foreign import prim' -- Currently they must all be simple unlifted types, or the well-known type -- Any, which can be used to pass the address to a Haskell object on the heap to -- the foreign function. isFFIPrimArgumentTy dflags ty | isAnyTy ty = IsValid | otherwise = checkRepTyCon (legalFIPrimArgTyCon dflags) ty isFFIPrimResultTy :: DynFlags -> Type -> Validity -- Checks for valid result type for a 'foreign import prim' Currently -- it must be an unlifted type, including unboxed tuples, unboxed -- sums, or the well-known type Any. isFFIPrimResultTy dflags ty | isAnyTy ty = IsValid | otherwise = checkRepTyCon (legalFIPrimResultTyCon dflags) ty isFunPtrTy :: Type -> Bool isFunPtrTy ty | Just (tc, [_]) <- splitTyConApp_maybe ty = tc `hasKey` funPtrTyConKey | otherwise = False -- normaliseFfiType gets run before checkRepTyCon, so we don't -- need to worry about looking through newtypes or type functions -- here; that's already been taken care of. checkRepTyCon :: (TyCon -> Validity) -> Type -> Validity checkRepTyCon check_tc ty = case splitTyConApp_maybe ty of Just (tc, tys) | isNewTyCon tc -> NotValid (hang msg 2 (mk_nt_reason tc tys $$ nt_fix)) | otherwise -> case check_tc tc of IsValid -> IsValid NotValid extra -> NotValid (msg $$ extra) Nothing -> NotValid (quotes (ppr ty) <+> text "is not a data type") where msg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call" mk_nt_reason tc tys | null tys = text "because its data constructor is not in scope" | otherwise = text "because the data constructor for" <+> quotes (ppr tc) <+> text "is not in scope" nt_fix = text "Possible fix: import the data constructor to bring it into scope" {- Note [Foreign import dynamic] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'. We use isFFIDynTy to check whether a signature is well-formed. For example, given a (illegal) declaration like: foreign import ccall "dynamic" foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO () isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried result type 'CInt -> IO ()', and return False, as they are not equal. ---------------------------------------------- These chaps do the work; they are not exported ---------------------------------------------- -} legalFEArgTyCon :: TyCon -> Validity legalFEArgTyCon tc -- It's illegal to make foreign exports that take unboxed -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000 = boxedMarshalableTyCon tc legalFIResultTyCon :: DynFlags -> TyCon -> Validity legalFIResultTyCon dflags tc | tc == unitTyCon = IsValid | otherwise = marshalableTyCon dflags tc legalFEResultTyCon :: TyCon -> Validity legalFEResultTyCon tc | tc == unitTyCon = IsValid | otherwise = boxedMarshalableTyCon tc legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity -- Checks validity of types going from Haskell -> external world legalOutgoingTyCon dflags _ tc = marshalableTyCon dflags tc legalFFITyCon :: TyCon -> Validity -- True for any TyCon that can possibly be an arg or result of an FFI call legalFFITyCon tc | isUnliftedTyCon tc = IsValid | tc == unitTyCon = IsValid | otherwise = boxedMarshalableTyCon tc marshalableTyCon :: DynFlags -> TyCon -> Validity marshalableTyCon dflags tc | isUnliftedTyCon tc , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) , not (null (tyConPrimRep tc)) -- Note [Marshalling void] = validIfUnliftedFFITypes dflags | otherwise = boxedMarshalableTyCon tc boxedMarshalableTyCon :: TyCon -> Validity boxedMarshalableTyCon tc | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey , int32TyConKey, int64TyConKey , wordTyConKey, word8TyConKey, word16TyConKey , word32TyConKey, word64TyConKey , floatTyConKey, doubleTyConKey , ptrTyConKey, funPtrTyConKey , charTyConKey , stablePtrTyConKey , boolTyConKey ] = IsValid | otherwise = NotValid empty legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity -- Check args of 'foreign import prim', only allow simple unlifted types. -- Strictly speaking it is unnecessary to ban unboxed tuples and sums here since -- currently they're of the wrong kind to use in function args anyway. legalFIPrimArgTyCon dflags tc | isUnliftedTyCon tc , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) = validIfUnliftedFFITypes dflags | otherwise = NotValid unlifted_only legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity -- Check result type of 'foreign import prim'. Allow simple unlifted -- types and also unboxed tuple and sum result types. legalFIPrimResultTyCon dflags tc | isUnliftedTyCon tc , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc || not (null (tyConPrimRep tc)) -- Note [Marshalling void] = validIfUnliftedFFITypes dflags | otherwise = NotValid unlifted_only unlifted_only :: MsgDoc unlifted_only = text "foreign import prim only accepts simple unlifted types" validIfUnliftedFFITypes :: DynFlags -> Validity validIfUnliftedFFITypes dflags | xopt LangExt.UnliftedFFITypes dflags = IsValid | otherwise = NotValid (text "To marshal unlifted types, use UnliftedFFITypes") {- Note [Marshalling void] ~~~~~~~~~~~~~~~~~~~~~~~ We don't treat State# (whose PrimRep is VoidRep) as marshalable. In turn that means you can't write foreign import foo :: Int -> State# RealWorld Reason: the back end falls over with panic "primRepHint:VoidRep"; and there is no compelling reason to permit it -} {- ************************************************************************ * * The "Paterson size" of a type * * ************************************************************************ -} {- Note [Paterson conditions on PredTypes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We are considering whether *class* constraints terminate (see Note [Paterson conditions]). Precisely, the Paterson conditions would have us check that "the constraint has fewer constructors and variables (taken together and counting repetitions) than the head.". However, we can be a bit more refined by looking at which kind of constraint this actually is. There are two main tricks: 1. It seems like it should be OK not to count the tuple type constructor for a PredType like (Show a, Eq a) :: Constraint, since we don't count the "implicit" tuple in the ThetaType itself. In fact, the Paterson test just checks *each component* of the top level ThetaType against the size bound, one at a time. By analogy, it should be OK to return the size of the *largest* tuple component as the size of the whole tuple. 2. Once we get into an implicit parameter or equality we can't get back to a class constraint, so it's safe to say "size 0". See #4200. NB: we don't want to detect PredTypes in sizeType (and then call sizePred on them), or we might get an infinite loop if that PredType is irreducible. See #5581. -} type TypeSize = IntWithInf sizeType :: Type -> TypeSize -- Size of a type: the number of variables and constructors -- Ignore kinds altogether sizeType = go where go ty | Just exp_ty <- tcView ty = go exp_ty go (TyVarTy {}) = 1 go (TyConApp tc tys) | isTypeFamilyTyCon tc = infinity -- Type-family applications can -- expand to any arbitrary size | otherwise = sizeTypes (filterOutInvisibleTypes tc tys) + 1 -- Why filter out invisible args? I suppose any -- size ordering is sound, but why is this better? -- I came across this when investigating #14010. go (LitTy {}) = 1 go (FunTy _ arg res) = go arg + go res + 1 go (AppTy fun arg) = go fun + go arg go (ForAllTy (Bndr tv vis) ty) | isVisibleArgFlag vis = go (tyVarKind tv) + go ty + 1 | otherwise = go ty + 1 go (CastTy ty _) = go ty go (CoercionTy {}) = 0 sizeTypes :: [Type] -> TypeSize sizeTypes tys = sum (map sizeType tys) ----------------------------------------------------------------------------------- ----------------------------------------------------------------------------------- ----------------------- -- | For every arg a tycon can take, the returned list says True if the argument -- is taken visibly, and False otherwise. Ends with an infinite tail of Trues to -- allow for oversaturation. tcTyConVisibilities :: TyCon -> [Bool] tcTyConVisibilities tc = tc_binder_viss ++ tc_return_kind_viss ++ repeat True where tc_binder_viss = map isVisibleTyConBinder (tyConBinders tc) tc_return_kind_viss = map isVisibleBinder (fst $ tcSplitPiTys (tyConResKind tc)) -- | If the tycon is applied to the types, is the next argument visible? isNextTyConArgVisible :: TyCon -> [Type] -> Bool isNextTyConArgVisible tc tys = tcTyConVisibilities tc `getNth` length tys -- | Should this type be applied to a visible argument? isNextArgVisible :: TcType -> Bool isNextArgVisible ty | Just (bndr, _) <- tcSplitPiTy_maybe ty = isVisibleBinder bndr | otherwise = True -- this second case might happen if, say, we have an unzonked TauTv. -- But TauTvs can't range over types that take invisible arguments ghc-lib-parser-8.10.2.20200808/compiler/iface/ToIface.hs0000644000000000000000000006260513713635745020247 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*] -- | Functions for converting Core things to interface file things. module ToIface ( -- * Binders toIfaceTvBndr , toIfaceTvBndrs , toIfaceIdBndr , toIfaceBndr , toIfaceForAllBndr , toIfaceTyCoVarBinders , toIfaceTyVar -- * Types , toIfaceType, toIfaceTypeX , toIfaceKind , toIfaceTcArgs , toIfaceTyCon , toIfaceTyCon_name , toIfaceTyLit -- * Tidying types , tidyToIfaceType , tidyToIfaceContext , tidyToIfaceTcArgs -- * Coercions , toIfaceCoercion, toIfaceCoercionX -- * Pattern synonyms , patSynToIfaceDecl -- * Expressions , toIfaceExpr , toIfaceBang , toIfaceSrcBang , toIfaceLetBndr , toIfaceIdDetails , toIfaceIdInfo , toIfUnfolding , toIfaceOneShot , toIfaceTickish , toIfaceBind , toIfaceAlt , toIfaceCon , toIfaceApp , toIfaceVar ) where #include "GhclibHsVersions.h" import GhcPrelude import IfaceSyn import DataCon import Id import IdInfo import CoreSyn import TyCon hiding ( pprPromotionQuote ) import CoAxiom import TysPrim ( eqPrimTyCon, eqReprPrimTyCon ) import TysWiredIn ( heqTyCon ) import MkId ( noinlineIdName ) import PrelNames import Name import BasicTypes import Type import PatSyn import Outputable import FastString import Util import Var import VarEnv import VarSet import TyCoRep import TyCoTidy ( tidyCo ) import Demand ( isTopSig ) import Data.Maybe ( catMaybes ) {- Note [Avoiding space leaks in toIface*] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Building a interface file depends on the output of the simplifier. If we build these lazily this would mean keeping the Core AST alive much longer than necessary causing a space "leak". This happens for example when we only write the interface file to disk after code gen has run, in which case we might carry megabytes of core AST in the heap which is no longer needed. We avoid this in two ways. * First we use -XStrict in ToIface which avoids many thunks to begin with. * Second we define NFData instance for IFaceSyn and use them to force any remaining thunks. -XStrict is not sufficient as patterns of the form `f (g x)` would still result in a thunk being allocated for `g x`. NFData is sufficient for the space leak, but using -XStrict reduces allocation by ~0.1% when compiling with -O. (nofib/spectral/simple, T10370). It's essentially free performance hence we use -XStrict on top of NFData. MR !1633 on gitlab, has more discussion on the topic. -} ---------------- toIfaceTvBndr :: TyVar -> IfaceTvBndr toIfaceTvBndr = toIfaceTvBndrX emptyVarSet toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar) , toIfaceTypeX fr (tyVarKind tyvar) ) toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr] toIfaceTvBndrs = map toIfaceTvBndr toIfaceIdBndr :: Id -> IfaceIdBndr toIfaceIdBndr = toIfaceIdBndrX emptyVarSet toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr toIfaceIdBndrX fr covar = ( occNameFS (getOccName covar) , toIfaceTypeX fr (varType covar) ) toIfaceBndr :: Var -> IfaceBndr toIfaceBndr var | isId var = IfaceIdBndr (toIfaceIdBndr var) | otherwise = IfaceTvBndr (toIfaceTvBndr var) toIfaceBndrX :: VarSet -> Var -> IfaceBndr toIfaceBndrX fr var | isId var = IfaceIdBndr (toIfaceIdBndrX fr var) | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var) toIfaceTyCoVarBinder :: VarBndr Var vis -> VarBndr IfaceBndr vis toIfaceTyCoVarBinder (Bndr tv vis) = Bndr (toIfaceBndr tv) vis toIfaceTyCoVarBinders :: [VarBndr Var vis] -> [VarBndr IfaceBndr vis] toIfaceTyCoVarBinders = map toIfaceTyCoVarBinder {- ************************************************************************ * * Conversion from Type to IfaceType * * ************************************************************************ -} toIfaceKind :: Type -> IfaceType toIfaceKind = toIfaceType --------------------- toIfaceType :: Type -> IfaceType toIfaceType = toIfaceTypeX emptyVarSet toIfaceTypeX :: VarSet -> Type -> IfaceType -- (toIfaceTypeX free ty) -- translates the tyvars in 'free' as IfaceFreeTyVars -- -- Synonyms are retained in the interface type toIfaceTypeX fr (TyVarTy tv) -- See Note [TcTyVars in IfaceType] in IfaceType | tv `elemVarSet` fr = IfaceFreeTyVar tv | otherwise = IfaceTyVar (toIfaceTyVar tv) toIfaceTypeX fr ty@(AppTy {}) = -- Flatten as many argument AppTys as possible, then turn them into an -- IfaceAppArgs list. -- See Note [Suppressing invisible arguments] in IfaceType. let (head, args) = splitAppTys ty in IfaceAppTy (toIfaceTypeX fr head) (toIfaceAppTyArgsX fr head args) toIfaceTypeX _ (LitTy n) = IfaceLitTy (toIfaceTyLit n) toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b) (toIfaceTypeX (fr `delVarSet` binderVar b) t) toIfaceTypeX fr (FunTy { ft_arg = t1, ft_res = t2, ft_af = af }) = IfaceFunTy af (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) toIfaceTypeX fr (CastTy ty co) = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCoercionX fr co) toIfaceTypeX fr (CoercionTy co) = IfaceCoercionTy (toIfaceCoercionX fr co) toIfaceTypeX fr (TyConApp tc tys) -- tuples | Just sort <- tyConTuple_maybe tc , n_tys == arity = IfaceTupleTy sort NotPromoted (toIfaceTcArgsX fr tc tys) | Just dc <- isPromotedDataCon_maybe tc , isTupleDataCon dc , n_tys == 2*arity = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys)) | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ] , (k1:k2:_) <- tys = let info = IfaceTyConInfo NotPromoted sort sort | k1 `eqType` k2 = IfaceEqualityTyCon | otherwise = IfaceNormalTyCon in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys) -- other applications | otherwise = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgsX fr tc tys) where arity = tyConArity tc n_tys = length tys toIfaceTyVar :: TyVar -> FastString toIfaceTyVar = occNameFS . getOccName toIfaceCoVar :: CoVar -> FastString toIfaceCoVar = occNameFS . getOccName toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet toIfaceForAllBndrX :: VarSet -> TyCoVarBinder -> IfaceForAllBndr toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTyCon tc = IfaceTyCon tc_name info where tc_name = tyConName tc info = IfaceTyConInfo promoted sort promoted | isPromotedDataCon tc = IsPromoted | otherwise = NotPromoted tupleSort :: TyCon -> Maybe IfaceTyConSort tupleSort tc' = case tyConTuple_maybe tc' of Just UnboxedTuple -> let arity = tyConArity tc' `div` 2 in Just $ IfaceTupleTyCon arity UnboxedTuple Just sort -> let arity = tyConArity tc' in Just $ IfaceTupleTyCon arity sort Nothing -> Nothing sort | Just tsort <- tupleSort tc = tsort | Just dcon <- isPromotedDataCon_maybe tc , let tc' = dataConTyCon dcon , Just tsort <- tupleSort tc' = tsort | isUnboxedSumTyCon tc , Just cons <- isDataSumTyCon_maybe tc = IfaceSumTyCon (length cons) | otherwise = IfaceNormalTyCon toIfaceTyCon_name :: Name -> IfaceTyCon toIfaceTyCon_name n = IfaceTyCon n info where info = IfaceTyConInfo NotPromoted IfaceNormalTyCon -- Used for the "rough-match" tycon stuff, -- where pretty-printing is not an issue toIfaceTyLit :: TyLit -> IfaceTyLit toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x ---------------- toIfaceCoercion :: Coercion -> IfaceCoercion toIfaceCoercion = toIfaceCoercionX emptyVarSet toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion -- (toIfaceCoercionX free ty) -- translates the tyvars in 'free' as IfaceFreeTyVars toIfaceCoercionX fr co = go co where go_mco MRefl = IfaceMRefl go_mco (MCo co) = IfaceMCo $ go co go (Refl ty) = IfaceReflCo (toIfaceTypeX fr ty) go (GRefl r ty mco) = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco) go (CoVarCo cv) -- See [TcTyVars in IfaceType] in IfaceType | cv `elemVarSet` fr = IfaceFreeCoVar cv | otherwise = IfaceCoVarCo (toIfaceCoVar cv) go (HoleCo h) = IfaceHoleCo (coHoleCoVar h) go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2) go (SymCo co) = IfaceSymCo (go co) go (TransCo co1 co2) = IfaceTransCo (go co1) (go co2) go (NthCo _r d co) = IfaceNthCo d (go co) go (LRCo lr co) = IfaceLRCo lr (go co) go (InstCo co arg) = IfaceInstCo (go co) (go arg) go (KindCo c) = IfaceKindCo (go c) go (SubCo co) = IfaceSubCo (go co) go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map go cs) go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs) go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov p) r (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) go (TyConAppCo r tc cos) | tc `hasKey` funTyConKey , [_,_,_,_] <- cos = pprPanic "toIfaceCoercion" (ppr co) | otherwise = IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos) go (FunCo r co1 co2) = IfaceFunCo r (go co1) (go co2) go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv) (toIfaceCoercionX fr' k) (toIfaceCoercionX fr' co) where fr' = fr `delVarSet` tv go_prov :: UnivCoProvenance -> IfaceUnivCoProv go_prov UnsafeCoerceProv = IfaceUnsafeCoerceProv go_prov (PhantomProv co) = IfacePhantomProv (go co) go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co) go_prov (PluginProv str) = IfacePluginProv str toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceTcArgs = toIfaceTcArgsX emptyVarSet toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceAppArgs toIfaceTcArgsX fr tc ty_args = toIfaceAppArgsX fr (tyConKind tc) ty_args toIfaceAppTyArgsX :: VarSet -> Type -> [Type] -> IfaceAppArgs toIfaceAppTyArgsX fr ty ty_args = toIfaceAppArgsX fr (typeKind ty) ty_args toIfaceAppArgsX :: VarSet -> Kind -> [Type] -> IfaceAppArgs -- See Note [Suppressing invisible arguments] in IfaceType -- We produce a result list of args describing visibility -- The awkward case is -- T :: forall k. * -> k -- And consider -- T (forall j. blah) * blib -- Is 'blib' visible? It depends on the visibility flag on j, -- so we have to substitute for k. Annoying! toIfaceAppArgsX fr kind ty_args = go (mkEmptyTCvSubst in_scope) kind ty_args where in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) go _ _ [] = IA_Nil go env ty ts | Just ty' <- coreView ty = go env ty' ts go env (ForAllTy (Bndr tv vis) res) (t:ts) = IA_Arg t' vis ts' where t' = toIfaceTypeX fr t ts' = go (extendTCvSubst env tv t) res ts go env (FunTy { ft_af = af, ft_res = res }) (t:ts) = IA_Arg (toIfaceTypeX fr t) argf (go env res ts) where argf = case af of VisArg -> Required InvisArg -> Inferred -- It's rare for a kind to have a constraint argument, but -- it can happen. See Note [AnonTCB InvisArg] in TyCon. go env ty ts@(t1:ts1) | not (isEmptyTCvSubst env) = go (zapTCvSubst env) (substTy env ty) ts -- See Note [Care with kind instantiation] in Type.hs | otherwise = -- There's a kind error in the type we are trying to print -- e.g. kind = k, ty_args = [Int] -- This is probably a compiler bug, so we print a trace and -- carry on as if it were FunTy. Without the test for -- isEmptyTCvSubst we'd get an infinite loop (#15473) WARN( True, ppr kind $$ ppr ty_args ) IA_Arg (toIfaceTypeX fr t1) Required (go env ty ts1) tidyToIfaceType :: TidyEnv -> Type -> IfaceType tidyToIfaceType env ty = toIfaceType (tidyType env ty) tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys) tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext tidyToIfaceContext env theta = map (tidyToIfaceType env) theta {- ************************************************************************ * * Conversion of pattern synonyms * * ************************************************************************ -} patSynToIfaceDecl :: PatSyn -> IfaceDecl patSynToIfaceDecl ps = IfacePatSyn { ifName = getName $ ps , ifPatMatcher = to_if_pr (patSynMatcher ps) , ifPatBuilder = fmap to_if_pr (patSynBuilder ps) , ifPatIsInfix = patSynIsInfix ps , ifPatUnivBndrs = map toIfaceForAllBndr univ_bndrs' , ifPatExBndrs = map toIfaceForAllBndr ex_bndrs' , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta , ifPatReqCtxt = tidyToIfaceContext env2 req_theta , ifPatArgs = map (tidyToIfaceType env2) args , ifPatTy = tidyToIfaceType env2 rhs_ty , ifFieldLabels = (patSynFieldLabels ps) } where (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps univ_bndrs = patSynUnivTyVarBinders ps ex_bndrs = patSynExTyVarBinders ps (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs (env2, ex_bndrs') = tidyTyCoVarBinders env1 ex_bndrs to_if_pr (id, needs_dummy) = (idName id, needs_dummy) {- ************************************************************************ * * Conversion of other things * * ************************************************************************ -} toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang toIfaceBang _ HsLazy = IfNoBang toIfaceBang _ (HsUnpack Nothing) = IfUnpack toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co)) toIfaceBang _ HsStrict = IfStrict toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang toIfaceLetBndr :: Id -> IfaceLetBndr toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) (toIfaceType (idType id)) (toIfaceIdInfo (idInfo id)) (toIfaceJoinInfo (isJoinId_maybe id)) -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr -- has left on the Id. See Note [IdInfo on nested let-bindings] in IfaceSyn toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId toIfaceIdDetails (DFunId {}) = IfDFunId toIfaceIdDetails (RecSelId { sel_naughty = n , sel_tycon = tc }) = let iface = case tc of RecSelData ty_con -> Left (toIfaceTyCon ty_con) RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn) in IfRecSelId iface n -- The remaining cases are all "implicit Ids" which don't -- appear in interface files at all toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) IfVanillaId -- Unexpected; the other toIfaceIdInfo :: IdInfo -> IfaceIdInfo toIfaceIdInfo id_info = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, inline_hsinfo, unfold_hsinfo, levity_hsinfo] of [] -> NoInfo infos -> HasInfo infos -- NB: strictness and arity must appear in the list before unfolding -- See TcIface.tcUnfolding where ------------ Arity -------------- arity_info = arityInfo id_info arity_hsinfo | arity_info == 0 = Nothing | otherwise = Just (HsArity arity_info) ------------ Caf Info -------------- caf_info = cafInfo id_info caf_hsinfo = case caf_info of NoCafRefs -> Just HsNoCafRefs _other -> Nothing ------------ Strictness -------------- -- No point in explicitly exporting TopSig sig_info = strictnessInfo id_info strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info) | otherwise = Nothing ------------ Unfolding -------------- unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) loop_breaker = isStrongLoopBreaker (occInfo id_info) ------------ Inline prag -------------- inline_prag = inlinePragInfo id_info inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing | otherwise = Just (HsInline inline_prag) ------------ Levity polymorphism ---------- levity_hsinfo | isNeverLevPolyIdInfo id_info = Just HsLevity | otherwise = Nothing toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar toIfaceJoinInfo Nothing = IfaceNotJoinPoint -------------------------- toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs , uf_src = src , uf_guidance = guidance }) = Just $ HsUnfold lb $ case src of InlineStable -> case guidance of UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } -> IfInlineRule arity unsat_ok boring_ok if_rhs _other -> IfCoreUnfold True if_rhs InlineCompulsory -> IfCompulsory if_rhs InlineRhs -> IfCoreUnfold False if_rhs -- Yes, even if guidance is UnfNever, expose the unfolding -- If we didn't want to expose the unfolding, TidyPgm would -- have stuck in NoUnfolding. For supercompilation we want -- to see that unfolding! where if_rhs = toIfaceExpr rhs toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args }) = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args))) -- No need to serialise the data constructor; -- we can recover it from the type of the dfun toIfUnfolding _ (OtherCon {}) = Nothing -- The binding site of an Id doesn't have OtherCon, except perhaps -- where we have called zapUnfolding; and that evald'ness info is -- not needed by importing modules toIfUnfolding _ BootUnfolding = Nothing -- Can't happen; we only have BootUnfolding for imported binders toIfUnfolding _ NoUnfolding = Nothing {- ************************************************************************ * * Conversion of expressions * * ************************************************************************ -} toIfaceExpr :: CoreExpr -> IfaceExpr toIfaceExpr (Var v) = toIfaceVar v toIfaceExpr (Lit l) = IfaceLit l toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co) toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b) toIfaceExpr (App f a) = toIfaceApp f [a] toIfaceExpr (Case s x ty as) | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty) | otherwise = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as) toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co) toIfaceExpr (Tick t e) | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e) | otherwise = toIfaceExpr e toIfaceOneShot :: Id -> IfaceOneShot toIfaceOneShot id | isId id , OneShotLam <- oneShotInfo (idInfo id) = IfaceOneShot | otherwise = IfaceNoOneShot --------------------- toIfaceTickish :: Tickish Id -> Maybe IfaceTickish toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push) toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix) toIfaceTickish (SourceNote src names) = Just (IfaceSource src names) toIfaceTickish (Breakpoint {}) = Nothing -- Ignore breakpoints, since they are relevant only to GHCi, and -- should not be serialised (#8333) --------------------- toIfaceBind :: Bind Id -> IfaceBinding toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] --------------------- toIfaceAlt :: (AltCon, [Var], CoreExpr) -> (IfaceConAlt, [FastString], IfaceExpr) toIfaceAlt (c,bs,r) = (toIfaceCon c, map getOccFS bs, toIfaceExpr r) --------------------- toIfaceCon :: AltCon -> IfaceConAlt toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc) toIfaceCon (LitAlt l) = IfaceLitAlt l toIfaceCon DEFAULT = IfaceDefault --------------------- toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr toIfaceApp (App f a) as = toIfaceApp f (a:as) toIfaceApp (Var v) as = case isDataConWorkId_maybe v of -- We convert the *worker* for tuples into IfaceTuples Just dc | saturated , Just tup_sort <- tyConTuple_maybe tc -> IfaceTuple tup_sort tup_args where val_args = dropWhile isTypeArg as saturated = val_args `lengthIs` idArity v tup_args = map toIfaceExpr val_args tc = dataConTyCon dc _ -> mkIfaceApps (toIfaceVar v) as toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as --------------------- toIfaceVar :: Id -> IfaceExpr toIfaceVar v | isBootUnfolding (idUnfolding v) = -- See Note [Inlining and hs-boot files] IfaceApp (IfaceApp (IfaceExt noinlineIdName) (IfaceType (toIfaceType (idType v)))) (IfaceExt name) -- don't use mkIfaceApps, or infinite loop | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) -- Foreign calls have special syntax | isExternalName name = IfaceExt name | otherwise = IfaceLcl (getOccFS name) where name = idName v {- Note [Inlining and hs-boot files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this example (#10083, #12789): ---------- RSR.hs-boot ------------ module RSR where data RSR eqRSR :: RSR -> RSR -> Bool ---------- SR.hs ------------ module SR where import {-# SOURCE #-} RSR data SR = MkSR RSR eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2 ---------- RSR.hs ------------ module RSR where import SR data RSR = MkRSR SR -- deriving( Eq ) eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2) foo x y = not (eqRSR x y) When compiling RSR we get this code RSR.eqRSR :: RSR -> RSR -> Bool RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) -> case ds1 of _ { RSR.MkRSR s1 -> case ds2 of _ { RSR.MkRSR s2 -> SR.eqSR s1 s2 }} RSR.foo :: RSR -> RSR -> Bool RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y) Now, when optimising foo: Inline eqRSR (small, non-rec) Inline eqSR (small, non-rec) but the result of inlining eqSR from SR is another call to eqRSR, so everything repeats. Neither eqSR nor eqRSR are (apparently) loop breakers. Solution: in the unfolding of eqSR in SR.hi, replace `eqRSR` in SR with `noinline eqRSR`, so that eqRSR doesn't get inlined. This means that when GHC inlines `eqSR`, it will not also inline `eqRSR`, exactly as would have been the case if `foo` had been defined in SR.hs (and marked as a loop-breaker). But how do we arrange for this to happen? There are two ingredients: 1. When we serialize out unfoldings to IfaceExprs (toIfaceVar), for every variable reference we see if we are referring to an 'Id' that came from an hs-boot file. If so, we add a `noinline` to the reference. 2. But how do we know if a reference came from an hs-boot file or not? We could record this directly in the 'IdInfo', but actually we deduce this by looking at the unfolding: 'Id's that come from boot files are given a special unfolding (upon typechecking) 'BootUnfolding' which say that there is no unfolding, and the reason is because the 'Id' came from a boot file. Here is a solution that doesn't work: when compiling RSR, add a NOINLINE pragma to every function exported by the boot-file for RSR (if it exists). Doing so makes the bootstrapped GHC itself slower by 8% overall (on #9872a-d, and T1969: the reason is that these NOINLINE'd functions now can't be profitably inlined outside of the hs-boot loop. -} ghc-lib-parser-8.10.2.20200808/compiler/main/ToolSettings.hs0000644000000000000000000000451213713635745021241 0ustar0000000000000000module ToolSettings ( ToolSettings (..) ) where import GhcPrelude import CliOption import Fingerprint -- | Settings for other executables GHC calls. -- -- Probably should futher split down by phase, or split between -- platform-specific and platform-agnostic. data ToolSettings = ToolSettings { toolSettings_ldSupportsCompactUnwind :: Bool , toolSettings_ldSupportsBuildId :: Bool , toolSettings_ldSupportsFilelist :: Bool , toolSettings_ldIsGnuLd :: Bool , toolSettings_ccSupportsNoPie :: Bool -- commands for particular phases , toolSettings_pgm_L :: String , toolSettings_pgm_P :: (String, [Option]) , toolSettings_pgm_F :: String , toolSettings_pgm_c :: String , toolSettings_pgm_a :: (String, [Option]) , toolSettings_pgm_l :: (String, [Option]) , toolSettings_pgm_lm :: (String, [Option]) , toolSettings_pgm_dll :: (String, [Option]) , toolSettings_pgm_T :: String , toolSettings_pgm_windres :: String , toolSettings_pgm_libtool :: String , toolSettings_pgm_ar :: String , toolSettings_pgm_ranlib :: String , -- | LLVM: opt llvm optimiser toolSettings_pgm_lo :: (String, [Option]) , -- | LLVM: llc static compiler toolSettings_pgm_lc :: (String, [Option]) , -- | LLVM: c compiler toolSettings_pgm_lcc :: (String, [Option]) , toolSettings_pgm_i :: String -- options for particular phases , toolSettings_opt_L :: [String] , toolSettings_opt_P :: [String] , -- | cached Fingerprint of sOpt_P -- See Note [Repeated -optP hashing] toolSettings_opt_P_fingerprint :: Fingerprint , toolSettings_opt_F :: [String] , toolSettings_opt_c :: [String] , toolSettings_opt_cxx :: [String] , toolSettings_opt_a :: [String] , toolSettings_opt_l :: [String] , toolSettings_opt_lm :: [String] , toolSettings_opt_windres :: [String] , -- | LLVM: llvm optimiser toolSettings_opt_lo :: [String] , -- | LLVM: llc static compiler toolSettings_opt_lc :: [String] , -- | LLVM: c compiler toolSettings_opt_lcc :: [String] , -- | iserv options toolSettings_opt_i :: [String] , toolSettings_extraGccViaCFlags :: [String] } ghc-lib-parser-8.10.2.20200808/compiler/utils/TrieMap.hs0000644000000000000000000003234013713635745020360 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} module TrieMap( -- * Maps over 'Maybe' values MaybeMap, -- * Maps over 'List' values ListMap, -- * Maps over 'Literal's LiteralMap, -- * 'TrieMap' class TrieMap(..), insertTM, deleteTM, -- * Things helpful for adding additional Instances. (>.>), (|>), (|>>), XT, foldMaybe, -- * Map for leaf compression GenMap, lkG, xtG, mapG, fdG, xtList, lkList ) where import GhcPrelude import Literal import UniqDFM import Unique( Unique ) import qualified Data.Map as Map import qualified Data.IntMap as IntMap import Outputable import Control.Monad( (>=>) ) {- This module implements TrieMaps, which are finite mappings whose key is a structured value like a CoreExpr or Type. This file implements tries over general data structures. Implementation for tries over Core Expressions/Types are available in coreSyn/TrieMap. The regular pattern for handling TrieMaps on data structures was first described (to my knowledge) in Connelly and Morris's 1995 paper "A generalization of the Trie Data Structure"; there is also an accessible description of the idea in Okasaki's book "Purely Functional Data Structures", Section 10.3.2 ************************************************************************ * * The TrieMap class * * ************************************************************************ -} type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing) -- or an existing elt (Just) class TrieMap m where type Key m :: * emptyTM :: m a lookupTM :: forall b. Key m -> m b -> Maybe b alterTM :: forall b. Key m -> XT b -> m b -> m b mapTM :: (a->b) -> m a -> m b foldTM :: (a -> b -> b) -> m a -> b -> b -- The unusual argument order here makes -- it easy to compose calls to foldTM; -- see for example fdE below insertTM :: TrieMap m => Key m -> a -> m a -> m a insertTM k v m = alterTM k (\_ -> Just v) m deleteTM :: TrieMap m => Key m -> m a -> m a deleteTM k m = alterTM k (\_ -> Nothing) m ---------------------- -- Recall that -- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c (>.>) :: (a -> b) -> (b -> c) -> a -> c -- Reverse function composition (do f first, then g) infixr 1 >.> (f >.> g) x = g (f x) infixr 1 |>, |>> (|>) :: a -> (a->b) -> b -- Reverse application x |> f = f x ---------------------- (|>>) :: TrieMap m2 => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a)) -> (m2 a -> m2 a) -> m1 (m2 a) -> m1 (m2 a) (|>>) f g = f (Just . g . deMaybe) deMaybe :: TrieMap m => Maybe (m a) -> m a deMaybe Nothing = emptyTM deMaybe (Just m) = m {- ************************************************************************ * * IntMaps * * ************************************************************************ -} instance TrieMap IntMap.IntMap where type Key IntMap.IntMap = Int emptyTM = IntMap.empty lookupTM k m = IntMap.lookup k m alterTM = xtInt foldTM k m z = IntMap.foldr k z m mapTM f m = IntMap.map f m xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a xtInt k f m = IntMap.alter f k m instance Ord k => TrieMap (Map.Map k) where type Key (Map.Map k) = k emptyTM = Map.empty lookupTM = Map.lookup alterTM k f m = Map.alter f k m foldTM k m z = Map.foldr k z m mapTM f m = Map.map f m {- Note [foldTM determinism] ~~~~~~~~~~~~~~~~~~~~~~~~~ We want foldTM to be deterministic, which is why we have an instance of TrieMap for UniqDFM, but not for UniqFM. Here's an example of some things that go wrong if foldTM is nondeterministic. Consider: f a b = return (a <> b) Depending on the order that the typechecker generates constraints you get either: f :: (Monad m, Monoid a) => a -> a -> m a or: f :: (Monoid a, Monad m) => a -> a -> m a The generated code will be different after desugaring as the dictionaries will be bound in different orders, leading to potential ABI incompatibility. One way to solve this would be to notice that the typeclasses could be sorted alphabetically. Unfortunately that doesn't quite work with this example: f a b = let x = a <> a; y = b <> b in x where you infer: f :: (Monoid m, Monoid m1) => m1 -> m -> m1 or: f :: (Monoid m1, Monoid m) => m1 -> m -> m1 Here you could decide to take the order of the type variables in the type according to depth first traversal and use it to order the constraints. The real trouble starts when the user enables incoherent instances and the compiler has to make an arbitrary choice. Consider: class T a b where go :: a -> b -> String instance (Show b) => T Int b where go a b = show a ++ show b instance (Show a) => T a Bool where go a b = show a ++ show b f = go 10 True GHC is free to choose either dictionary to implement f, but for the sake of determinism we'd like it to be consistent when compiling the same sources with the same flags. inert_dicts :: DictMap is implemented with a TrieMap. In getUnsolvedInerts it gets converted to a bag of (Wanted) Cts using a fold. Then in solve_simple_wanteds it's merged with other WantedConstraints. We want the conversion to a bag to be deterministic. For that purpose we use UniqDFM instead of UniqFM to implement the TrieMap. See Note [Deterministic UniqFM] in UniqDFM for more details on how it's made deterministic. -} instance TrieMap UniqDFM where type Key UniqDFM = Unique emptyTM = emptyUDFM lookupTM k m = lookupUDFM m k alterTM k f m = alterUDFM f m k foldTM k m z = foldUDFM k z m mapTM f m = mapUDFM f m {- ************************************************************************ * * Maybes * * ************************************************************************ If m is a map from k -> val then (MaybeMap m) is a map from (Maybe k) -> val -} data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a } instance TrieMap m => TrieMap (MaybeMap m) where type Key (MaybeMap m) = Maybe (Key m) emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM } lookupTM = lkMaybe lookupTM alterTM = xtMaybe alterTM foldTM = fdMaybe mapTM = mapMb mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b mapMb f (MM { mm_nothing = mn, mm_just = mj }) = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj } lkMaybe :: (forall b. k -> m b -> Maybe b) -> Maybe k -> MaybeMap m a -> Maybe a lkMaybe _ Nothing = mm_nothing lkMaybe lk (Just x) = mm_just >.> lk x xtMaybe :: (forall b. k -> XT b -> m b -> m b) -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a xtMaybe _ Nothing f m = m { mm_nothing = f (mm_nothing m) } xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f } fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b fdMaybe k m = foldMaybe k (mm_nothing m) . foldTM k (mm_just m) {- ************************************************************************ * * Lists * * ************************************************************************ -} data ListMap m a = LM { lm_nil :: Maybe a , lm_cons :: m (ListMap m a) } instance TrieMap m => TrieMap (ListMap m) where type Key (ListMap m) = [Key m] emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM } lookupTM = lkList lookupTM alterTM = xtList alterTM foldTM = fdList mapTM = mapList instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where ppr m = text "List elts" <+> ppr (foldTM (:) m []) mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b mapList f (LM { lm_nil = mnil, lm_cons = mcons }) = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons } lkList :: TrieMap m => (forall b. k -> m b -> Maybe b) -> [k] -> ListMap m a -> Maybe a lkList _ [] = lm_nil lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b) -> [k] -> XT a -> ListMap m a -> ListMap m a xtList _ [] f m = m { lm_nil = f (lm_nil m) } xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f } fdList :: forall m a b. TrieMap m => (a -> b -> b) -> ListMap m a -> b -> b fdList k m = foldMaybe k (lm_nil m) . foldTM (fdList k) (lm_cons m) foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b foldMaybe _ Nothing b = b foldMaybe k (Just a) b = k a b {- ************************************************************************ * * Basic maps * * ************************************************************************ -} type LiteralMap a = Map.Map Literal a {- ************************************************************************ * * GenMap * * ************************************************************************ Note [Compressed TrieMap] ~~~~~~~~~~~~~~~~~~~~~~~~~ The GenMap constructor augments TrieMaps with leaf compression. This helps solve the performance problem detailed in #9960: suppose we have a handful H of entries in a TrieMap, each with a very large key, size K. If you fold over such a TrieMap you'd expect time O(H). That would certainly be true of an association list! But with TrieMap we actually have to navigate down a long singleton structure to get to the elements, so it takes time O(K*H). This can really hurt on many type-level computation benchmarks: see for example T9872d. The point of a TrieMap is that you need to navigate to the point where only one key remains, and then things should be fast. So the point of a SingletonMap is that, once we are down to a single (key,value) pair, we stop and just use SingletonMap. 'EmptyMap' provides an even more basic (but essential) optimization: if there is nothing in the map, don't bother building out the (possibly infinite) recursive TrieMap structure! Compressed triemaps are heavily used by CoreMap. So we have to mark some things as INLINEABLE to permit specialization. -} data GenMap m a = EmptyMap | SingletonMap (Key m) a | MultiMap (m a) instance (Outputable a, Outputable (m a)) => Outputable (GenMap m a) where ppr EmptyMap = text "Empty map" ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v ppr (MultiMap m) = ppr m -- TODO undecidable instance instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where type Key (GenMap m) = Key m emptyTM = EmptyMap lookupTM = lkG alterTM = xtG foldTM = fdG mapTM = mapG --We want to be able to specialize these functions when defining eg --tries over (GenMap CoreExpr) which requires INLINEABLE {-# INLINEABLE lkG #-} lkG :: (Eq (Key m), TrieMap m) => Key m -> GenMap m a -> Maybe a lkG _ EmptyMap = Nothing lkG k (SingletonMap k' v') | k == k' = Just v' | otherwise = Nothing lkG k (MultiMap m) = lookupTM k m {-# INLINEABLE xtG #-} xtG :: (Eq (Key m), TrieMap m) => Key m -> XT a -> GenMap m a -> GenMap m a xtG k f EmptyMap = case f Nothing of Just v -> SingletonMap k v Nothing -> EmptyMap xtG k f m@(SingletonMap k' v') | k' == k -- The new key matches the (single) key already in the tree. Hence, -- apply @f@ to @Just v'@ and build a singleton or empty map depending -- on the 'Just'/'Nothing' response respectively. = case f (Just v') of Just v'' -> SingletonMap k' v'' Nothing -> EmptyMap | otherwise -- We've hit a singleton tree for a different key than the one we are -- searching for. Hence apply @f@ to @Nothing@. If result is @Nothing@ then -- we can just return the old map. If not, we need a map with *two* -- entries. The easiest way to do that is to insert two items into an empty -- map of type @m a@. = case f Nothing of Nothing -> m Just v -> emptyTM |> alterTM k' (const (Just v')) >.> alterTM k (const (Just v)) >.> MultiMap xtG k f (MultiMap m) = MultiMap (alterTM k f m) {-# INLINEABLE mapG #-} mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b mapG _ EmptyMap = EmptyMap mapG f (SingletonMap k v) = SingletonMap k (f v) mapG f (MultiMap m) = MultiMap (mapTM f m) {-# INLINEABLE fdG #-} fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b fdG _ EmptyMap = \z -> z fdG k (SingletonMap _ v) = \z -> k v z fdG k (MultiMap m) = foldTM k m ghc-lib-parser-8.10.2.20200808/compiler/types/TyCoFVs.hs0000644000000000000000000011245013713635745020321 0ustar0000000000000000module TyCoFVs ( tyCoVarsOfType, tyCoVarsOfTypeDSet, tyCoVarsOfTypes, tyCoVarsOfTypesDSet, exactTyCoVarsOfType, exactTyCoVarsOfTypes, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, tyCoFVsOfType, tyCoVarsOfTypeList, tyCoFVsOfTypes, tyCoVarsOfTypesList, tyCoVarsOfTypesSet, tyCoVarsOfCosSet, coVarsOfType, coVarsOfTypes, coVarsOfCo, coVarsOfCos, tyCoVarsOfCo, tyCoVarsOfCos, tyCoVarsOfCoDSet, tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoList, tyCoVarsOfProv, almostDevoidCoVarOfCo, injectiveVarsOfType, injectiveVarsOfTypes, invisibleVarsOfType, invisibleVarsOfTypes, noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo, mkTyCoInScopeSet, -- * Welll-scoped free variables scopedSort, tyCoVarsOfTypeWellScoped, tyCoVarsOfTypesWellScoped, ) where import GhcPrelude import {-# SOURCE #-} Type (coreView, tcView, partitionInvisibleTypes) import TyCoRep import TyCon import Var import FV import UniqFM import VarSet import VarEnv import Util import Panic {- %************************************************************************ %* * Free variables of types and coercions %* * %************************************************************************ -} {- Note [Free variables of types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns a VarSet that is closed over the types of its variables. More precisely, if S = tyCoVarsOfType( t ) and (a:k) is in S then tyCoVarsOftype( k ) is a subset of S Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}. We could /not/ close over the kinds of the variable occurrences, and instead do so at call sites, but it seems that we always want to do so, so it's easiest to do it here. It turns out that getting the free variables of types is performance critical, so we profiled several versions, exploring different implementation strategies. 1. Baseline version: uses FV naively. Essentially: tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty This is not nice, because FV introduces some overhead to implement determinism, and throught its "interesting var" function, neither of which we need here, so they are a complete waste. 2. UnionVarSet version: instead of reusing the FV-based code, we simply used VarSets directly, trying to avoid the overhead of FV. E.g.: -- FV version: tyCoFVsOfType (AppTy fun arg) a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c -- UnionVarSet version: tyCoVarsOfType (AppTy fun arg) = (tyCoVarsOfType fun `unionVarSet` tyCoVarsOfType arg) This looks deceptively similar, but while FV internally builds a list- and set-generating function, the VarSet functions manipulate sets directly, and the latter peforms a lot worse than the naive FV version. 3. Accumulator-style VarSet version: this is what we use now. We do use VarSet as our data structure, but delegate the actual work to a new ty_co_vars_of_... family of functions, which use accumulator style and the "in-scope set" filter found in the internals of FV, but without the determinism overhead. See #14880. Note [Closing over free variable kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tyCoVarsOfType and tyCoFVsOfType, while traversing a type, will also close over free variable kinds. In previous GHC versions, this happened naively: whenever we would encounter an occurrence of a free type variable, we would close over its kind. This, however is wrong for two reasons (see #14880): 1. Efficiency. If we have Proxy (a::k) -> Proxy (a::k) -> Proxy (a::k), then we don't want to have to traverse k more than once. 2. Correctness. Imagine we have forall k. b -> k, where b has kind k, for some k bound in an outer scope. If we look at b's kind inside the forall, we'll collect that k is free and then remove k from the set of free variables. This is plain wrong. We must instead compute that b is free and then conclude that b's kind is free. An obvious first approach is to move the closing-over-kinds from the occurrences of a type variable to after finding the free vars - however, this turns out to introduce performance regressions, and isn't even entirely correct. In fact, it isn't even important *when* we close over kinds; what matters is that we handle each type var exactly once, and that we do it in the right context. So the next approach we tried was to use the "in-scope set" part of FV or the equivalent argument in the accumulator-style `ty_co_vars_of_type` function, to say "don't bother with variables we have already closed over". This should work fine in theory, but the code is complicated and doesn't perform well. But there is a simpler way, which is implemented here. Consider the two points above: 1. Efficiency: we now have an accumulator, so the second time we encounter 'a', we'll ignore it, certainly not looking at its kind - this is why pre-checking set membership before inserting ends up not only being faster, but also being correct. 2. Correctness: we have an "in-scope set" (I think we should call it it a "bound-var set"), specifying variables that are bound by a forall in the type we are traversing; we simply ignore these variables, certainly not looking at their kind. So now consider: forall k. b -> k where b :: k->Type is free; but of course, it's a different k! When looking at b -> k we'll have k in the bound-var set. So we'll ignore the k. But suppose this is our first encounter with b; we want the free vars of its kind. But we want to behave as if we took the free vars of its kind at the end; that is, with no bound vars in scope. So the solution is easy. The old code was this: ty_co_vars_of_type (TyVarTy v) is acc | v `elemVarSet` is = acc | v `elemVarSet` acc = acc | otherwise = ty_co_vars_of_type (tyVarKind v) is (extendVarSet acc v) Now all we need to do is take the free vars of tyVarKind v *with an empty bound-var set*, thus: ty_co_vars_of_type (TyVarTy v) is acc | v `elemVarSet` is = acc | v `elemVarSet` acc = acc | otherwise = ty_co_vars_of_type (tyVarKind v) emptyVarSet (extendVarSet acc v) ^^^^^^^^^^^ And that's it. This works because a variable is either bound or free. If it is bound, then we won't look at it at all. If it is free, then all the variables free in its kind are free -- regardless of whether some local variable has the same Unique. So if we're looking at a variable occurrence at all, then all variables in its kind are free. -} tyCoVarsOfType :: Type -> TyCoVarSet -- See Note [Free variables of types] tyCoVarsOfType ty = ty_co_vars_of_type ty emptyVarSet emptyVarSet tyCoVarsOfTypes :: [Type] -> TyCoVarSet tyCoVarsOfTypes tys = ty_co_vars_of_types tys emptyVarSet emptyVarSet ty_co_vars_of_type :: Type -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet ty_co_vars_of_type (TyVarTy v) is acc | v `elemVarSet` is = acc | v `elemVarSet` acc = acc | otherwise = ty_co_vars_of_type (tyVarKind v) emptyVarSet -- See Note [Closing over free variable kinds] (extendVarSet acc v) ty_co_vars_of_type (TyConApp _ tys) is acc = ty_co_vars_of_types tys is acc ty_co_vars_of_type (LitTy {}) _ acc = acc ty_co_vars_of_type (AppTy fun arg) is acc = ty_co_vars_of_type fun is (ty_co_vars_of_type arg is acc) ty_co_vars_of_type (FunTy _ arg res) is acc = ty_co_vars_of_type arg is (ty_co_vars_of_type res is acc) ty_co_vars_of_type (ForAllTy (Bndr tv _) ty) is acc = ty_co_vars_of_type (varType tv) is $ ty_co_vars_of_type ty (extendVarSet is tv) acc ty_co_vars_of_type (CastTy ty co) is acc = ty_co_vars_of_type ty is (ty_co_vars_of_co co is acc) ty_co_vars_of_type (CoercionTy co) is acc = ty_co_vars_of_co co is acc ty_co_vars_of_types :: [Type] -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet ty_co_vars_of_types [] _ acc = acc ty_co_vars_of_types (ty:tys) is acc = ty_co_vars_of_type ty is (ty_co_vars_of_types tys is acc) tyCoVarsOfCo :: Coercion -> TyCoVarSet -- See Note [Free variables of types] tyCoVarsOfCo co = ty_co_vars_of_co co emptyVarSet emptyVarSet tyCoVarsOfCos :: [Coercion] -> TyCoVarSet tyCoVarsOfCos cos = ty_co_vars_of_cos cos emptyVarSet emptyVarSet ty_co_vars_of_co :: Coercion -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet ty_co_vars_of_co (Refl ty) is acc = ty_co_vars_of_type ty is acc ty_co_vars_of_co (GRefl _ ty mco) is acc = ty_co_vars_of_type ty is $ ty_co_vars_of_mco mco is acc ty_co_vars_of_co (TyConAppCo _ _ cos) is acc = ty_co_vars_of_cos cos is acc ty_co_vars_of_co (AppCo co arg) is acc = ty_co_vars_of_co co is $ ty_co_vars_of_co arg is acc ty_co_vars_of_co (ForAllCo tv kind_co co) is acc = ty_co_vars_of_co kind_co is $ ty_co_vars_of_co co (extendVarSet is tv) acc ty_co_vars_of_co (FunCo _ co1 co2) is acc = ty_co_vars_of_co co1 is $ ty_co_vars_of_co co2 is acc ty_co_vars_of_co (CoVarCo v) is acc = ty_co_vars_of_co_var v is acc ty_co_vars_of_co (HoleCo h) is acc = ty_co_vars_of_co_var (coHoleCoVar h) is acc -- See Note [CoercionHoles and coercion free variables] ty_co_vars_of_co (AxiomInstCo _ _ cos) is acc = ty_co_vars_of_cos cos is acc ty_co_vars_of_co (UnivCo p _ t1 t2) is acc = ty_co_vars_of_prov p is $ ty_co_vars_of_type t1 is $ ty_co_vars_of_type t2 is acc ty_co_vars_of_co (SymCo co) is acc = ty_co_vars_of_co co is acc ty_co_vars_of_co (TransCo co1 co2) is acc = ty_co_vars_of_co co1 is $ ty_co_vars_of_co co2 is acc ty_co_vars_of_co (NthCo _ _ co) is acc = ty_co_vars_of_co co is acc ty_co_vars_of_co (LRCo _ co) is acc = ty_co_vars_of_co co is acc ty_co_vars_of_co (InstCo co arg) is acc = ty_co_vars_of_co co is $ ty_co_vars_of_co arg is acc ty_co_vars_of_co (KindCo co) is acc = ty_co_vars_of_co co is acc ty_co_vars_of_co (SubCo co) is acc = ty_co_vars_of_co co is acc ty_co_vars_of_co (AxiomRuleCo _ cs) is acc = ty_co_vars_of_cos cs is acc ty_co_vars_of_mco :: MCoercion -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet ty_co_vars_of_mco MRefl _is acc = acc ty_co_vars_of_mco (MCo co) is acc = ty_co_vars_of_co co is acc ty_co_vars_of_co_var :: CoVar -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet ty_co_vars_of_co_var v is acc | v `elemVarSet` is = acc | v `elemVarSet` acc = acc | otherwise = ty_co_vars_of_type (varType v) emptyVarSet -- See Note [Closing over free variable kinds] (extendVarSet acc v) ty_co_vars_of_cos :: [Coercion] -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet ty_co_vars_of_cos [] _ acc = acc ty_co_vars_of_cos (co:cos) is acc = ty_co_vars_of_co co is (ty_co_vars_of_cos cos is acc) tyCoVarsOfProv :: UnivCoProvenance -> TyCoVarSet tyCoVarsOfProv prov = ty_co_vars_of_prov prov emptyVarSet emptyVarSet ty_co_vars_of_prov :: UnivCoProvenance -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet ty_co_vars_of_prov (PhantomProv co) is acc = ty_co_vars_of_co co is acc ty_co_vars_of_prov (ProofIrrelProv co) is acc = ty_co_vars_of_co co is acc ty_co_vars_of_prov UnsafeCoerceProv _ acc = acc ty_co_vars_of_prov (PluginProv _) _ acc = acc -- | Generates an in-scope set from the free variables in a list of types -- and a list of coercions mkTyCoInScopeSet :: [Type] -> [Coercion] -> InScopeSet mkTyCoInScopeSet tys cos = mkInScopeSet (ty_co_vars_of_types tys emptyVarSet $ ty_co_vars_of_cos cos emptyVarSet emptyVarSet) -- | `tyCoFVsOfType` that returns free variables of a type in a deterministic -- set. For explanation of why using `VarSet` is not deterministic see -- Note [Deterministic FV] in FV. tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet -- See Note [Free variables of types] tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty -- | `tyCoFVsOfType` that returns free variables of a type in deterministic -- order. For explanation of why using `VarSet` is not deterministic see -- Note [Deterministic FV] in FV. tyCoVarsOfTypeList :: Type -> [TyCoVar] -- See Note [Free variables of types] tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty -- | Returns free variables of types, including kind variables as -- a non-deterministic set. For type synonyms it does /not/ expand the -- synonym. tyCoVarsOfTypesSet :: TyVarEnv Type -> TyCoVarSet -- See Note [Free variables of types] tyCoVarsOfTypesSet tys = tyCoVarsOfTypes $ nonDetEltsUFM tys -- It's OK to use nonDetEltsUFM here because we immediately forget the -- ordering by returning a set -- | Returns free variables of types, including kind variables as -- a deterministic set. For type synonyms it does /not/ expand the -- synonym. tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet -- See Note [Free variables of types] tyCoVarsOfTypesDSet tys = fvDVarSet $ tyCoFVsOfTypes tys -- | Returns free variables of types, including kind variables as -- a deterministically ordered list. For type synonyms it does /not/ expand the -- synonym. tyCoVarsOfTypesList :: [Type] -> [TyCoVar] -- See Note [Free variables of types] tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys {- ************************************************************************ * * The "exact" free variables of a type * * ************************************************************************ Note [Silly type synonym] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider type T a = Int What are the free tyvars of (T x)? Empty, of course! exactTyCoVarsOfType is used by the type checker to figure out exactly which type variables are mentioned in a type. It only matters occasionally -- see the calls to exactTyCoVarsOfType. -} exactTyCoVarsOfType :: Type -> TyCoVarSet -- Find the free type variables (of any kind) -- but *expand* type synonyms. See Note [Silly type synonym] above. exactTyCoVarsOfType ty = go ty where go ty | Just ty' <- tcView ty = go ty' -- This is the key line go (TyVarTy tv) = goVar tv go (TyConApp _ tys) = exactTyCoVarsOfTypes tys go (LitTy {}) = emptyVarSet go (AppTy fun arg) = go fun `unionVarSet` go arg go (FunTy _ arg res) = go arg `unionVarSet` go res go (ForAllTy bndr ty) = delBinderVar (go ty) bndr `unionVarSet` go (binderType bndr) go (CastTy ty co) = go ty `unionVarSet` goCo co go (CoercionTy co) = goCo co goMCo MRefl = emptyVarSet goMCo (MCo co) = goCo co goCo (Refl ty) = go ty goCo (GRefl _ ty mco) = go ty `unionVarSet` goMCo mco goCo (TyConAppCo _ _ args)= goCos args goCo (AppCo co arg) = goCo co `unionVarSet` goCo arg goCo (ForAllCo tv k_co co) = goCo co `delVarSet` tv `unionVarSet` goCo k_co goCo (FunCo _ co1 co2) = goCo co1 `unionVarSet` goCo co2 goCo (CoVarCo v) = goVar v goCo (HoleCo h) = goVar (coHoleCoVar h) goCo (AxiomInstCo _ _ args) = goCos args goCo (UnivCo p _ t1 t2) = goProv p `unionVarSet` go t1 `unionVarSet` go t2 goCo (SymCo co) = goCo co goCo (TransCo co1 co2) = goCo co1 `unionVarSet` goCo co2 goCo (NthCo _ _ co) = goCo co goCo (LRCo _ co) = goCo co goCo (InstCo co arg) = goCo co `unionVarSet` goCo arg goCo (KindCo co) = goCo co goCo (SubCo co) = goCo co goCo (AxiomRuleCo _ c) = goCos c goCos cos = foldr (unionVarSet . goCo) emptyVarSet cos goProv UnsafeCoerceProv = emptyVarSet goProv (PhantomProv kco) = goCo kco goProv (ProofIrrelProv kco) = goCo kco goProv (PluginProv _) = emptyVarSet goVar v = unitVarSet v `unionVarSet` go (varType v) exactTyCoVarsOfTypes :: [Type] -> TyVarSet exactTyCoVarsOfTypes tys = mapUnionVarSet exactTyCoVarsOfType tys -- | The worker for `tyCoFVsOfType` and `tyCoFVsOfTypeList`. -- The previous implementation used `unionVarSet` which is O(n+m) and can -- make the function quadratic. -- It's exported, so that it can be composed with -- other functions that compute free variables. -- See Note [FV naming conventions] in FV. -- -- Eta-expanded because that makes it run faster (apparently) -- See Note [FV eta expansion] in FV for explanation. tyCoFVsOfType :: Type -> FV -- See Note [Free variables of types] tyCoFVsOfType (TyVarTy v) f bound_vars (acc_list, acc_set) | not (f v) = (acc_list, acc_set) | v `elemVarSet` bound_vars = (acc_list, acc_set) | v `elemVarSet` acc_set = (acc_list, acc_set) | otherwise = tyCoFVsOfType (tyVarKind v) f emptyVarSet -- See Note [Closing over free variable kinds] (v:acc_list, extendVarSet acc_set v) tyCoFVsOfType (TyConApp _ tys) f bound_vars acc = tyCoFVsOfTypes tys f bound_vars acc tyCoFVsOfType (LitTy {}) f bound_vars acc = emptyFV f bound_vars acc tyCoFVsOfType (AppTy fun arg) f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc tyCoFVsOfType (FunTy _ arg res) f bound_vars acc = (tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty) f bound_vars acc tyCoFVsOfType (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc tyCoFVsBndr :: TyCoVarBinder -> FV -> FV -- Free vars of (forall b. ) tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs tyCoFVsVarBndrs :: [Var] -> FV -> FV tyCoFVsVarBndrs vars fvs = foldr tyCoFVsVarBndr fvs vars tyCoFVsVarBndr :: Var -> FV -> FV tyCoFVsVarBndr var fvs = tyCoFVsOfType (varType var) -- Free vars of its type/kind `unionFV` delFV var fvs -- Delete it from the thing-inside tyCoFVsOfTypes :: [Type] -> FV -- See Note [Free variables of types] tyCoFVsOfTypes (ty:tys) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfTypes tys) fv_cand in_scope acc tyCoFVsOfTypes [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc -- | Get a deterministic set of the vars free in a coercion tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet -- See Note [Free variables of types] tyCoVarsOfCoDSet co = fvDVarSet $ tyCoFVsOfCo co tyCoVarsOfCoList :: Coercion -> [TyCoVar] -- See Note [Free variables of types] tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co tyCoFVsOfMCo :: MCoercion -> FV tyCoFVsOfMCo MRefl = emptyFV tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co tyCoVarsOfCosSet :: CoVarEnv Coercion -> TyCoVarSet tyCoVarsOfCosSet cos = tyCoVarsOfCos $ nonDetEltsUFM cos -- It's OK to use nonDetEltsUFM here because we immediately forget the -- ordering by returning a set tyCoFVsOfCo :: Coercion -> FV -- Extracts type and coercion variables from a coercion -- See Note [Free variables of types] tyCoFVsOfCo (Refl ty) fv_cand in_scope acc = tyCoFVsOfType ty fv_cand in_scope acc tyCoFVsOfCo (GRefl _ ty mco) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfMCo mco) fv_cand in_scope acc tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc tyCoFVsOfCo (FunCo _ co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc = tyCoFVsOfCoVar v fv_cand in_scope acc tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc -- See Note [CoercionHoles and coercion free variables] tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1 `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc tyCoFVsOfCo (SymCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfCo (TransCo co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc tyCoFVsOfCo (NthCo _ _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfCo (LRCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfCo (InstCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc tyCoFVsOfCo (KindCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfCo (SubCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfCo (AxiomRuleCo _ cs) fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc tyCoFVsOfCoVar :: CoVar -> FV tyCoFVsOfCoVar v fv_cand in_scope acc = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc tyCoFVsOfProv :: UnivCoProvenance -> FV tyCoFVsOfProv UnsafeCoerceProv fv_cand in_scope acc = emptyFV fv_cand in_scope acc tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc tyCoFVsOfCos :: [Coercion] -> FV tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc ------------- Extracting the CoVars of a type or coercion ----------- {- Note [CoVarsOfX and the InterestingVarFun] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The coVarsOfType, coVarsOfTypes, coVarsOfCo, and coVarsOfCos functions are implemented in terms of the respective FV equivalents (tyCoFVsOf...), rather than the VarSet-based flavors (tyCoVarsOf...), despite the performance considerations outlined in Note [Free variables of types]. This is because FV includes the InterestingVarFun, which is useful here, because we can cleverly use it to restrict our calculations to CoVars - this is what getCoVarSet achieves. See #14880. -} getCoVarSet :: FV -> CoVarSet getCoVarSet fv = snd (fv isCoVar emptyVarSet ([], emptyVarSet)) coVarsOfType :: Type -> CoVarSet coVarsOfType ty = getCoVarSet (tyCoFVsOfType ty) coVarsOfTypes :: [Type] -> TyCoVarSet coVarsOfTypes tys = getCoVarSet (tyCoFVsOfTypes tys) coVarsOfCo :: Coercion -> CoVarSet coVarsOfCo co = getCoVarSet (tyCoFVsOfCo co) coVarsOfCos :: [Coercion] -> CoVarSet coVarsOfCos cos = getCoVarSet (tyCoFVsOfCos cos) ----- Whether a covar is /Almost Devoid/ in a type or coercion ---- -- | Given a covar and a coercion, returns True if covar is almost devoid in -- the coercion. That is, covar can only appear in Refl and GRefl. -- See last wrinkle in Note [Unused coercion variable in ForAllCo] in Coercion almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool almostDevoidCoVarOfCo cv co = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool almost_devoid_co_var_of_co (Refl {}) _ = True -- covar is allowed in Refl and almost_devoid_co_var_of_co (GRefl {}) _ = True -- GRefl, so we don't look into -- the coercions almost_devoid_co_var_of_co (TyConAppCo _ _ cos) cv = almost_devoid_co_var_of_cos cos cv almost_devoid_co_var_of_co (AppCo co arg) cv = almost_devoid_co_var_of_co co cv && almost_devoid_co_var_of_co arg cv almost_devoid_co_var_of_co (ForAllCo v kind_co co) cv = almost_devoid_co_var_of_co kind_co cv && (v == cv || almost_devoid_co_var_of_co co cv) almost_devoid_co_var_of_co (FunCo _ co1 co2) cv = almost_devoid_co_var_of_co co1 cv && almost_devoid_co_var_of_co co2 cv almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv almost_devoid_co_var_of_co (HoleCo h) cv = (coHoleCoVar h) /= cv almost_devoid_co_var_of_co (AxiomInstCo _ _ cos) cv = almost_devoid_co_var_of_cos cos cv almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv = almost_devoid_co_var_of_prov p cv && almost_devoid_co_var_of_type t1 cv && almost_devoid_co_var_of_type t2 cv almost_devoid_co_var_of_co (SymCo co) cv = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_co (TransCo co1 co2) cv = almost_devoid_co_var_of_co co1 cv && almost_devoid_co_var_of_co co2 cv almost_devoid_co_var_of_co (NthCo _ _ co) cv = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_co (LRCo _ co) cv = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_co (InstCo co arg) cv = almost_devoid_co_var_of_co co cv && almost_devoid_co_var_of_co arg cv almost_devoid_co_var_of_co (KindCo co) cv = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_co (SubCo co) cv = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_co (AxiomRuleCo _ cs) cv = almost_devoid_co_var_of_cos cs cv almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool almost_devoid_co_var_of_cos [] _ = True almost_devoid_co_var_of_cos (co:cos) cv = almost_devoid_co_var_of_co co cv && almost_devoid_co_var_of_cos cos cv almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool almost_devoid_co_var_of_prov (PhantomProv co) cv = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_prov (ProofIrrelProv co) cv = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_prov UnsafeCoerceProv _ = True almost_devoid_co_var_of_prov (PluginProv _) _ = True almost_devoid_co_var_of_type :: Type -> CoVar -> Bool almost_devoid_co_var_of_type (TyVarTy _) _ = True almost_devoid_co_var_of_type (TyConApp _ tys) cv = almost_devoid_co_var_of_types tys cv almost_devoid_co_var_of_type (LitTy {}) _ = True almost_devoid_co_var_of_type (AppTy fun arg) cv = almost_devoid_co_var_of_type fun cv && almost_devoid_co_var_of_type arg cv almost_devoid_co_var_of_type (FunTy _ arg res) cv = almost_devoid_co_var_of_type arg cv && almost_devoid_co_var_of_type res cv almost_devoid_co_var_of_type (ForAllTy (Bndr v _) ty) cv = almost_devoid_co_var_of_type (varType v) cv && (v == cv || almost_devoid_co_var_of_type ty cv) almost_devoid_co_var_of_type (CastTy ty co) cv = almost_devoid_co_var_of_type ty cv && almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_type (CoercionTy co) cv = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_types :: [Type] -> CoVar -> Bool almost_devoid_co_var_of_types [] _ = True almost_devoid_co_var_of_types (ty:tys) cv = almost_devoid_co_var_of_type ty cv && almost_devoid_co_var_of_types tys cv ------------- Injective free vars ----------------- -- | Returns the free variables of a 'Type' that are in injective positions. -- Specifically, it finds the free variables while: -- -- * Expanding type synonyms -- -- * Ignoring the coercion in @(ty |> co)@ -- -- * Ignoring the non-injective fields of a 'TyConApp' -- -- -- For example, if @F@ is a non-injective type family, then: -- -- @ -- injectiveTyVarsOf( Either c (Maybe (a, F b c)) ) = {a,c} -- @ -- -- If @'injectiveVarsOfType' ty = itvs@, then knowing @ty@ fixes @itvs@. -- More formally, if -- @a@ is in @'injectiveVarsOfType' ty@ -- and @S1(ty) ~ S2(ty)@, -- then @S1(a) ~ S2(a)@, -- where @S1@ and @S2@ are arbitrary substitutions. -- -- See @Note [When does a tycon application need an explicit kind signature?]@. injectiveVarsOfType :: Bool -- ^ Should we look under injective type families? -- See Note [Coverage condition for injective type families] -- in FamInst. -> Type -> FV injectiveVarsOfType look_under_tfs = go where go ty | Just ty' <- coreView ty = go ty' go (TyVarTy v) = unitFV v `unionFV` go (tyVarKind v) go (AppTy f a) = go f `unionFV` go a go (FunTy _ ty1 ty2) = go ty1 `unionFV` go ty2 go (TyConApp tc tys) = case tyConInjectivityInfo tc of Injective inj | look_under_tfs || not (isTypeFamilyTyCon tc) -> mapUnionFV go $ filterByList (inj ++ repeat True) tys -- Oversaturated arguments to a tycon are -- always injective, hence the repeat True _ -> emptyFV go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `unionFV` delFV tv (go ty) go LitTy{} = emptyFV go (CastTy ty _) = go ty go CoercionTy{} = emptyFV -- | Returns the free variables of a 'Type' that are in injective positions. -- Specifically, it finds the free variables while: -- -- * Expanding type synonyms -- -- * Ignoring the coercion in @(ty |> co)@ -- -- * Ignoring the non-injective fields of a 'TyConApp' -- -- See @Note [When does a tycon application need an explicit kind signature?]@. injectiveVarsOfTypes :: Bool -- ^ look under injective type families? -- See Note [Coverage condition for injective type families] -- in FamInst. -> [Type] -> FV injectiveVarsOfTypes look_under_tfs = mapUnionFV (injectiveVarsOfType look_under_tfs) ------------- Invisible vars ----------------- -- | Returns the set of variables that are used invisibly anywhere within -- the given type. A variable will be included even if it is used both visibly -- and invisibly. An invisible use site includes: -- * In the kind of a variable -- * In the kind of a bound variable in a forall -- * In a coercion -- * In a Specified or Inferred argument to a function -- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep invisibleVarsOfType :: Type -> FV invisibleVarsOfType = go where go ty | Just ty' <- coreView ty = go ty' go (TyVarTy v) = go (tyVarKind v) go (AppTy f a) = go f `unionFV` go a go (FunTy _ ty1 ty2) = go ty1 `unionFV` go ty2 go (TyConApp tc tys) = tyCoFVsOfTypes invisibles `unionFV` invisibleVarsOfTypes visibles where (invisibles, visibles) = partitionInvisibleTypes tc tys go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go ty go LitTy{} = emptyFV go (CastTy ty co) = tyCoFVsOfCo co `unionFV` go ty go (CoercionTy co) = tyCoFVsOfCo co -- | Like 'invisibleVarsOfType', but for many types. invisibleVarsOfTypes :: [Type] -> FV invisibleVarsOfTypes = mapUnionFV invisibleVarsOfType ------------- No free vars ----------------- -- | Returns True if this type has no free variables. Should be the same as -- isEmptyVarSet . tyCoVarsOfType, but faster in the non-forall case. noFreeVarsOfType :: Type -> Bool noFreeVarsOfType (TyVarTy _) = False noFreeVarsOfType (AppTy t1 t2) = noFreeVarsOfType t1 && noFreeVarsOfType t2 noFreeVarsOfType (TyConApp _ tys) = all noFreeVarsOfType tys noFreeVarsOfType ty@(ForAllTy {}) = isEmptyVarSet (tyCoVarsOfType ty) noFreeVarsOfType (FunTy _ t1 t2) = noFreeVarsOfType t1 && noFreeVarsOfType t2 noFreeVarsOfType (LitTy _) = True noFreeVarsOfType (CastTy ty co) = noFreeVarsOfType ty && noFreeVarsOfCo co noFreeVarsOfType (CoercionTy co) = noFreeVarsOfCo co noFreeVarsOfMCo :: MCoercion -> Bool noFreeVarsOfMCo MRefl = True noFreeVarsOfMCo (MCo co) = noFreeVarsOfCo co noFreeVarsOfTypes :: [Type] -> Bool noFreeVarsOfTypes = all noFreeVarsOfType -- | Returns True if this coercion has no free variables. Should be the same as -- isEmptyVarSet . tyCoVarsOfCo, but faster in the non-forall case. noFreeVarsOfCo :: Coercion -> Bool noFreeVarsOfCo (Refl ty) = noFreeVarsOfType ty noFreeVarsOfCo (GRefl _ ty co) = noFreeVarsOfType ty && noFreeVarsOfMCo co noFreeVarsOfCo (TyConAppCo _ _ args) = all noFreeVarsOfCo args noFreeVarsOfCo (AppCo c1 c2) = noFreeVarsOfCo c1 && noFreeVarsOfCo c2 noFreeVarsOfCo co@(ForAllCo {}) = isEmptyVarSet (tyCoVarsOfCo co) noFreeVarsOfCo (FunCo _ c1 c2) = noFreeVarsOfCo c1 && noFreeVarsOfCo c2 noFreeVarsOfCo (CoVarCo _) = False noFreeVarsOfCo (HoleCo {}) = True -- I'm unsure; probably never happens noFreeVarsOfCo (AxiomInstCo _ _ args) = all noFreeVarsOfCo args noFreeVarsOfCo (UnivCo p _ t1 t2) = noFreeVarsOfProv p && noFreeVarsOfType t1 && noFreeVarsOfType t2 noFreeVarsOfCo (SymCo co) = noFreeVarsOfCo co noFreeVarsOfCo (TransCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 noFreeVarsOfCo (NthCo _ _ co) = noFreeVarsOfCo co noFreeVarsOfCo (LRCo _ co) = noFreeVarsOfCo co noFreeVarsOfCo (InstCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 noFreeVarsOfCo (KindCo co) = noFreeVarsOfCo co noFreeVarsOfCo (SubCo co) = noFreeVarsOfCo co noFreeVarsOfCo (AxiomRuleCo _ cs) = all noFreeVarsOfCo cs -- | Returns True if this UnivCoProv has no free variables. Should be the same as -- isEmptyVarSet . tyCoVarsOfProv, but faster in the non-forall case. noFreeVarsOfProv :: UnivCoProvenance -> Bool noFreeVarsOfProv UnsafeCoerceProv = True noFreeVarsOfProv (PhantomProv co) = noFreeVarsOfCo co noFreeVarsOfProv (ProofIrrelProv co) = noFreeVarsOfCo co noFreeVarsOfProv (PluginProv {}) = True {- %************************************************************************ %* * Well-scoped tyvars * * ************************************************************************ Note [ScopedSort] ~~~~~~~~~~~~~~~~~ Consider foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> () This function type is implicitly generalised over [a, b, k, k2]. These variables will be Specified; that is, they will be available for visible type application. This is because they are written in the type signature by the user. However, we must ask: what order will they appear in? In cases without dependency, this is easy: we just use the lexical left-to-right ordering of first occurrence. With dependency, we cannot get off the hook so easily. We thus state: * These variables appear in the order as given by ScopedSort, where the input to ScopedSort is the left-to-right order of first occurrence. Note that this applies only to *implicit* quantification, without a `forall`. If the user writes a `forall`, then we just use the order given. ScopedSort is defined thusly (as proposed in #15743): * Work left-to-right through the input list, with a cursor. * If variable v at the cursor is depended on by any earlier variable w, move v immediately before the leftmost such w. INVARIANT: The prefix of variables before the cursor form a valid telescope. Note that ScopedSort makes sense only after type inference is done and all types/kinds are fully settled and zonked. -} -- | Do a topological sort on a list of tyvars, -- so that binders occur before occurrences -- E.g. given [ a::k, k::*, b::k ] -- it'll return a well-scoped list [ k::*, a::k, b::k ] -- -- This is a deterministic sorting operation -- (that is, doesn't depend on Uniques). -- -- It is also meant to be stable: that is, variables should not -- be reordered unnecessarily. This is specified in Note [ScopedSort] -- See also Note [Ordering of implicit variables] in RnTypes scopedSort :: [TyCoVar] -> [TyCoVar] scopedSort = go [] [] where go :: [TyCoVar] -- already sorted, in reverse order -> [TyCoVarSet] -- each set contains all the variables which must be placed -- before the tv corresponding to the set; they are accumulations -- of the fvs in the sorted tvs' kinds -- This list is in 1-to-1 correspondence with the sorted tyvars -- INVARIANT: -- all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list) -- That is, each set in the list is a superset of all later sets. -> [TyCoVar] -- yet to be sorted -> [TyCoVar] go acc _fv_list [] = reverse acc go acc fv_list (tv:tvs) = go acc' fv_list' tvs where (acc', fv_list') = insert tv acc fv_list insert :: TyCoVar -- var to insert -> [TyCoVar] -- sorted list, in reverse order -> [TyCoVarSet] -- list of fvs, as above -> ([TyCoVar], [TyCoVarSet]) -- augmented lists insert tv [] [] = ([tv], [tyCoVarsOfType (tyVarKind tv)]) insert tv (a:as) (fvs:fvss) | tv `elemVarSet` fvs , (as', fvss') <- insert tv as fvss = (a:as', fvs `unionVarSet` fv_tv : fvss') | otherwise = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss) where fv_tv = tyCoVarsOfType (tyVarKind tv) -- lists not in correspondence insert _ _ _ = panic "scopedSort" -- | Get the free vars of a type in scoped order tyCoVarsOfTypeWellScoped :: Type -> [TyVar] tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList -- | Get the free vars of types in scoped order tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList ghc-lib-parser-8.10.2.20200808/compiler/types/TyCoPpr.hs0000644000000000000000000002627113713635745020371 0ustar0000000000000000-- | Pretty-printing types and coercions. module TyCoPpr ( -- * Precedence PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, -- * Pretty-printing types pprType, pprParendType, pprPrecType, pprPrecTypeX, pprTypeApp, pprTCvBndr, pprTCvBndrs, pprSigmaType, pprTheta, pprParendTheta, pprForAll, pprUserForAll, pprTyVar, pprTyVars, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprTyLit, pprDataCons, pprWithExplicitKindsWhen, pprWithTYPE, pprSourceTyCon, -- * Pretty-printing coercions pprCo, pprParendCo, debugPprType, -- * Pretty-printing 'TyThing's pprTyThingCategory, pprShortTyThing, ) where import GhcPrelude import {-# SOURCE #-} ToIface( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX ) import {-# SOURCE #-} DataCon( dataConFullSig , dataConUserTyVarBinders , DataCon ) import {-# SOURCE #-} Type( isLiftedTypeKind ) import TyCon import TyCoRep import TyCoTidy import TyCoFVs import Class import Var import IfaceType import VarSet import VarEnv import DynFlags ( gopt_set, GeneralFlag(Opt_PrintExplicitKinds, Opt_PrintExplicitRuntimeReps) ) import Outputable import BasicTypes ( PprPrec(..), topPrec, sigPrec, opPrec , funPrec, appPrec, maybeParen ) {- %************************************************************************ %* * Pretty-printing types Defined very early because of debug printing in assertions %* * %************************************************************************ @pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is defined to use this. @pprParendType@ is the same, except it puts parens around the type, except for the atomic cases. @pprParendType@ works just by setting the initial context precedence very high. Note that any function which pretty-prints a @Type@ first converts the @Type@ to an @IfaceType@. See Note [IfaceType and pretty-printing] in IfaceType. See Note [Precedence in types] in BasicTypes. -} -------------------------------------------------------- -- When pretty-printing types, we convert to IfaceType, -- and pretty-print that. -- See Note [Pretty printing via IfaceSyn] in PprTyThing -------------------------------------------------------- pprType, pprParendType :: Type -> SDoc pprType = pprPrecType topPrec pprParendType = pprPrecType appPrec pprPrecType :: PprPrec -> Type -> SDoc pprPrecType = pprPrecTypeX emptyTidyEnv pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc pprPrecTypeX env prec ty = getPprStyle $ \sty -> if debugStyle sty -- Use debugPprType when in then debug_ppr_ty prec ty -- when in debug-style else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty) -- NB: debug-style is used for -dppr-debug -- dump-style is used for -ddump-tc-trace etc pprTyLit :: TyLit -> SDoc pprTyLit = pprIfaceTyLit . toIfaceTyLit pprKind, pprParendKind :: Kind -> SDoc pprKind = pprType pprParendKind = pprParendType tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType tidyToIfaceTypeStyX env ty sty | userStyle sty = tidyToIfaceTypeX env ty | otherwise = toIfaceTypeX (tyCoVarsOfType ty) ty -- in latter case, don't tidy, as we'll be printing uniques. tidyToIfaceType :: Type -> IfaceType tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType -- It's vital to tidy before converting to an IfaceType -- or nested binders will become indistinguishable! -- -- Also for the free type variables, tell toIfaceTypeX to -- leave them as IfaceFreeTyVar. This is super-important -- for debug printing. tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty) where env' = tidyFreeTyCoVars env free_tcvs free_tcvs = tyCoVarsOfTypeWellScoped ty ------------ pprCo, pprParendCo :: Coercion -> SDoc pprCo co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty) pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty) tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion tidyToIfaceCoSty co sty | userStyle sty = tidyToIfaceCo co | otherwise = toIfaceCoercionX (tyCoVarsOfCo co) co -- in latter case, don't tidy, as we'll be printing uniques. tidyToIfaceCo :: Coercion -> IfaceCoercion -- It's vital to tidy before converting to an IfaceType -- or nested binders will become indistinguishable! -- -- Also for the free type variables, tell toIfaceCoercionX to -- leave them as IfaceFreeCoVar. This is super-important -- for debug printing. tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co) where env = tidyFreeTyCoVars emptyTidyEnv free_tcvs free_tcvs = scopedSort $ tyCoVarsOfCoList co ------------ pprClassPred :: Class -> [Type] -> SDoc pprClassPred clas tys = pprTypeApp (classTyCon clas) tys ------------ pprTheta :: ThetaType -> SDoc pprTheta = pprIfaceContext topPrec . map tidyToIfaceType pprParendTheta :: ThetaType -> SDoc pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType pprThetaArrowTy :: ThetaType -> SDoc pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType ------------------ pprSigmaType :: Type -> SDoc pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType pprForAll :: [TyCoVarBinder] -> SDoc pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs) -- | Print a user-level forall; see Note [When to print foralls] in this module. pprUserForAll :: [TyCoVarBinder] -> SDoc pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr pprTCvBndrs :: [TyCoVarBinder] -> SDoc pprTCvBndrs tvs = sep (map pprTCvBndr tvs) pprTCvBndr :: TyCoVarBinder -> SDoc pprTCvBndr = pprTyVar . binderVar pprTyVars :: [TyVar] -> SDoc pprTyVars tvs = sep (map pprTyVar tvs) pprTyVar :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) -- Here we do not go via IfaceType, because the duplication with -- pprIfaceTvBndr is minimal, and the loss of uniques etc in -- debug printing is disastrous pprTyVar tv | isLiftedTypeKind kind = ppr tv | otherwise = parens (ppr tv <+> dcolon <+> ppr kind) where kind = tyVarKind tv ----------------- debugPprType :: Type -> SDoc -- ^ debugPprType is a simple pretty printer that prints a type -- without going through IfaceType. It does not format as prettily -- as the normal route, but it's much more direct, and that can -- be useful for debugging. E.g. with -dppr-debug it prints the -- kind on type-variable /occurrences/ which the normal route -- fundamentally cannot do. debugPprType ty = debug_ppr_ty topPrec ty debug_ppr_ty :: PprPrec -> Type -> SDoc debug_ppr_ty _ (LitTy l) = ppr l debug_ppr_ty _ (TyVarTy tv) = ppr tv -- With -dppr-debug we get (tv :: kind) debug_ppr_ty prec (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) = maybeParen prec funPrec $ sep [debug_ppr_ty funPrec arg, arrow <+> debug_ppr_ty prec res] where arrow = case af of VisArg -> text "->" InvisArg -> text "=>" debug_ppr_ty prec (TyConApp tc tys) | null tys = ppr tc | otherwise = maybeParen prec appPrec $ hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys)) debug_ppr_ty _ (AppTy t1 t2) = hang (debug_ppr_ty appPrec t1) -- Print parens so we see ((a b) c) 2 (debug_ppr_ty appPrec t2) -- so that we can distinguish -- TyConApp from AppTy debug_ppr_ty prec (CastTy ty co) = maybeParen prec topPrec $ hang (debug_ppr_ty topPrec ty) 2 (text "|>" <+> ppr co) debug_ppr_ty _ (CoercionTy co) = parens (text "CO" <+> ppr co) debug_ppr_ty prec ty@(ForAllTy {}) | (tvs, body) <- split ty = maybeParen prec funPrec $ hang (text "forall" <+> fsep (map ppr tvs) <> dot) -- The (map ppr tvs) will print kind-annotated -- tvs, because we are (usually) in debug-style 2 (ppr body) where split ty | ForAllTy tv ty' <- ty , (tvs, body) <- split ty' = (tv:tvs, body) | otherwise = ([], ty) {- Note [When to print foralls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Mostly we want to print top-level foralls when (and only when) the user specifies -fprint-explicit-foralls. But when kind polymorphism is at work, that suppresses too much information; see #9018. So I'm trying out this rule: print explicit foralls if a) User specifies -fprint-explicit-foralls, or b) Any of the quantified type variables has a kind that mentions a kind variable This catches common situations, such as a type siguature f :: m a which means f :: forall k. forall (m :: k->*) (a :: k). m a We really want to see both the "forall k" and the kind signatures on m and a. The latter comes from pprTCvBndr. Note [Infix type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ With TypeOperators you can say f :: (a ~> b) -> b and the (~>) is considered a type variable. However, the type pretty-printer in this module will just see (a ~> b) as App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b") So it'll print the type in prefix form. To avoid confusion we must remember to parenthesise the operator, thus (~>) a b -> b See #2766. -} pprDataCons :: TyCon -> SDoc pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons where sepWithVBars [] = empty sepWithVBars docs = sep (punctuate (space <> vbar) docs) pprDataConWithArgs :: DataCon -> SDoc pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] where (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc user_bndrs = dataConUserTyVarBinders dc forAllDoc = pprUserForAll user_bndrs thetaDoc = pprThetaArrowTy theta argsDoc = hsep (fmap pprParendType arg_tys) pprTypeApp :: TyCon -> [Type] -> SDoc pprTypeApp tc tys = pprIfaceTypeApp topPrec (toIfaceTyCon tc) (toIfaceTcArgs tc tys) -- TODO: toIfaceTcArgs seems rather wasteful here ------------------ -- | Display all kind information (with @-fprint-explicit-kinds@) when the -- provided 'Bool' argument is 'True'. -- See @Note [Kind arguments in error messages]@ in TcErrors. pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc pprWithExplicitKindsWhen b = updSDocDynFlags $ \dflags -> if b then gopt_set dflags Opt_PrintExplicitKinds else dflags -- | This variant preserves any use of TYPE in a type, effectively -- locally setting -fprint-explicit-runtime-reps. pprWithTYPE :: Type -> SDoc pprWithTYPE ty = updSDocDynFlags (flip gopt_set Opt_PrintExplicitRuntimeReps) $ ppr ty -- | Pretty prints a 'TyCon', using the family instance in case of a -- representation tycon. For example: -- -- > data T [a] = ... -- -- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' pprSourceTyCon :: TyCon -> SDoc pprSourceTyCon tycon | Just (fam_tc, tys) <- tyConFamInst_maybe tycon = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon | otherwise = ppr tycon ghc-lib-parser-8.10.2.20200808/compiler/types/TyCoRep.hs0000644000000000000000000017562613713635745020367 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1998 \section[TyCoRep]{Type and Coercion - friends' interface} Note [The Type-related module hierarchy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Class CoAxiom TyCon imports Class, CoAxiom TyCoRep imports Class, CoAxiom, TyCon TyCoPpr imports TyCoRep TyCoFVs imports TyCoRep TyCoSubst imports TyCoRep, TyCoFVs, TyCoPpr TyCoTidy imports TyCoRep, TyCoFVs TysPrim imports TyCoRep ( including mkTyConTy ) Coercion imports Type -} -- We expose the relevant stuff from this module via the Type module {-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf, PatternSynonyms, BangPatterns #-} module TyCoRep ( TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing, -- * Types Type( TyVarTy, AppTy, TyConApp, ForAllTy , LitTy, CastTy, CoercionTy , FunTy, ft_arg, ft_res, ft_af ), -- Export the type synonym FunTy too TyLit(..), KindOrType, Kind, KnotTied, PredType, ThetaType, -- Synonyms ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), -- * Coercions Coercion(..), UnivCoProvenance(..), CoercionHole(..), coHoleCoVar, setCoHoleCoVar, CoercionN, CoercionR, CoercionP, KindCoercion, MCoercion(..), MCoercionR, MCoercionN, -- * Functions over types mkTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, mkForAllTy, mkForAllTys, mkPiTy, mkPiTys, -- * Functions over binders TyCoBinder(..), TyCoVarBinder, TyBinder, binderVar, binderVars, binderType, binderArgFlag, delBinderVar, isInvisibleArgFlag, isVisibleArgFlag, isInvisibleBinder, isVisibleBinder, isTyBinder, isNamedBinder, -- * Functions over coercions pickLR, -- * Sizes typeSize, coercionSize, provSize ) where #include "GhclibHsVersions.h" import GhcPrelude import {-# SOURCE #-} TyCoPpr ( pprType, pprCo, pprTyLit ) -- Transitively pulls in a LOT of stuff, better to break the loop import {-# SOURCE #-} ConLike ( ConLike(..), conLikeName ) -- friends: import IfaceType import Var import VarSet import Name hiding ( varName ) import TyCon import CoAxiom -- others import BasicTypes ( LeftOrRight(..), pickLR ) import Outputable import FastString import Util -- libraries import qualified Data.Data as Data hiding ( TyCon ) import Data.IORef ( IORef ) -- for CoercionHole {- %************************************************************************ %* * TyThing %* * %************************************************************************ Despite the fact that DataCon has to be imported via a hi-boot route, this module seems the right place for TyThing, because it's needed for funTyCon and all the types in TysPrim. It is also SOURCE-imported into Name.hs Note [ATyCon for classes] ~~~~~~~~~~~~~~~~~~~~~~~~~ Both classes and type constructors are represented in the type environment as ATyCon. You can tell the difference, and get to the class, with isClassTyCon :: TyCon -> Bool tyConClass_maybe :: TyCon -> Maybe Class The Class and its associated TyCon have the same Name. -} -- | A global typecheckable-thing, essentially anything that has a name. -- Not to be confused with a 'TcTyThing', which is also a typecheckable -- thing but in the *local* context. See 'TcEnv' for how to retrieve -- a 'TyThing' given a 'Name'. data TyThing = AnId Id | AConLike ConLike | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] | ACoAxiom (CoAxiom Branched) instance Outputable TyThing where ppr = pprShortTyThing instance NamedThing TyThing where -- Can't put this with the type getName (AnId id) = getName id -- decl, because the DataCon instance getName (ATyCon tc) = getName tc -- isn't visible there getName (ACoAxiom cc) = getName cc getName (AConLike cl) = conLikeName cl pprShortTyThing :: TyThing -> SDoc -- c.f. PprTyThing.pprTyThing, which prints all the details pprShortTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing)) pprTyThingCategory :: TyThing -> SDoc pprTyThingCategory = text . capitalise . tyThingCategory tyThingCategory :: TyThing -> String tyThingCategory (ATyCon tc) | isClassTyCon tc = "class" | otherwise = "type constructor" tyThingCategory (ACoAxiom _) = "coercion axiom" tyThingCategory (AnId _) = "identifier" tyThingCategory (AConLike (RealDataCon _)) = "data constructor" tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym" {- ********************************************************************** * * Type * * ********************************************************************** -} -- | The key representation of types within the compiler type KindOrType = Type -- See Note [Arguments to type constructors] -- | The key type representing kinds in the compiler. type Kind = Type -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.hs data Type -- See Note [Non-trivial definitional equality] = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) | AppTy Type Type -- ^ Type application to something other than a 'TyCon'. Parameters: -- -- 1) Function: must /not/ be a 'TyConApp' or 'CastTy', -- must be another 'AppTy', or 'TyVarTy' -- See Note [Respecting definitional equality] (EQ1) about the -- no 'CastTy' requirement -- -- 2) Argument type | TyConApp TyCon [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. -- Invariant: saturated applications of 'FunTyCon' must -- use 'FunTy' and saturated synonyms must use their own -- constructors. However, /unsaturated/ 'FunTyCon's -- do appear as 'TyConApp's. -- Parameters: -- -- 1) Type constructor being applied to. -- -- 2) Type arguments. Might not have enough type arguments -- here to saturate the constructor. -- Even type synonyms are not necessarily saturated; -- for example unsaturated type synonyms -- can appear as the right hand side of a type synonym. | ForAllTy {-# UNPACK #-} !TyCoVarBinder Type -- ^ A Π type. | FunTy -- ^ t1 -> t2 Very common, so an important special case -- See Note [Function types] { ft_af :: AnonArgFlag -- Is this (->) or (=>)? , ft_arg :: Type -- Argument type , ft_res :: Type } -- Result type | LitTy TyLit -- ^ Type literals are similar to type constructors. | CastTy Type KindCoercion -- ^ A kind cast. The coercion is always nominal. -- INVARIANT: The cast is never refl. -- INVARIANT: The Type is not a CastTy (use TransCo instead) -- See Note [Respecting definitional equality] (EQ2) and (EQ3) | CoercionTy Coercion -- ^ Injection of a Coercion into a type -- This should only ever be used in the RHS of an AppTy, -- in the list of a TyConApp, when applying a promoted -- GADT data constructor deriving Data.Data instance Outputable Type where ppr = pprType -- NOTE: Other parts of the code assume that type literals do not contain -- types or type variables. data TyLit = NumTyLit Integer | StrTyLit FastString deriving (Eq, Ord, Data.Data) instance Outputable TyLit where ppr = pprTyLit {- Note [Function types] ~~~~~~~~~~~~~~~~~~~~~~~~ FFunTy is the constructor for a function type. Lots of things to say about it! * FFunTy is the data constructor, meaning "full function type". * The function type constructor (->) has kind (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> Type LiftedRep mkTyConApp ensure that we convert a saturated application TyConApp (->) [r1,r2,t1,t2] into FunTy t1 t2 dropping the 'r1' and 'r2' arguments; they are easily recovered from 't1' and 't2'. * The ft_af field says whether or not this is an invisible argument VisArg: t1 -> t2 Ordinary function type InvisArg: t1 => t2 t1 is guaranteed to be a predicate type, i.e. t1 :: Constraint See Note [Types for coercions, predicates, and evidence] This visibility info makes no difference in Core; it matters only when we regard the type as a Haskell source type. * FunTy is a (unidirectional) pattern synonym that allows positional pattern matching (FunTy arg res), ignoring the ArgFlag. -} {- ----------------------- Commented out until the pattern match checker can handle it; see #16185 For now we use the CPP macro #define FunTy FFunTy _ (see GhclibHsVersions.h) to allow pattern matching on a (positional) FunTy constructor. {-# COMPLETE FunTy, TyVarTy, AppTy, TyConApp , ForAllTy, LitTy, CastTy, CoercionTy :: Type #-} -- | 'FunTy' is a (uni-directional) pattern synonym for the common -- case where we want to match on the argument/result type, but -- ignoring the AnonArgFlag pattern FunTy :: Type -> Type -> Type pattern FunTy arg res <- FFunTy { ft_arg = arg, ft_res = res } End of commented out block ---------------------------------- -} {- Note [Types for coercions, predicates, and evidence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We treat differently: (a) Predicate types Test: isPredTy Binders: DictIds Kind: Constraint Examples: (Eq a), and (a ~ b) (b) Coercion types are primitive, unboxed equalities Test: isCoVarTy Binders: CoVars (can appear in coercions) Kind: TYPE (TupleRep []) Examples: (t1 ~# t2) or (t1 ~R# t2) (c) Evidence types is the type of evidence manipulated by the type constraint solver. Test: isEvVarType Binders: EvVars Kind: Constraint or TYPE (TupleRep []) Examples: all coercion types and predicate types Coercion types and predicate types are mutually exclusive, but evidence types are a superset of both. When treated as a user type, - Predicates (of kind Constraint) are invisible and are implicitly instantiated - Coercion types, and non-pred evidence types (i.e. not of kind Constrain), are just regular old types, are visible, and are not implicitly instantiated. In a FunTy { ft_af = InvisArg }, the argument type is always a Predicate type. Note [Constraints in kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Do we allow a type constructor to have a kind like S :: Eq a => a -> Type No, we do not. Doing so would mean would need a TyConApp like S @k @(d :: Eq k) (ty :: k) and we have no way to build, or decompose, evidence like (d :: Eq k) at the type level. But we admit one exception: equality. We /do/ allow, say, MkT :: (a ~ b) => a -> b -> Type a b Why? Because we can, without much difficulty. Moreover we can promote a GADT data constructor (see TyCon Note [Promoted data constructors]), like data GT a b where MkGT : a -> a -> GT a a so programmers might reasonably expect to be able to promote MkT as well. How does this work? * In TcValidity.checkConstraintsOK we reject kinds that have constraints other than (a~b) and (a~~b). * In Inst.tcInstInvisibleTyBinder we instantiate a call of MkT by emitting [W] co :: alpha ~# beta and producing the elaborated term MkT @alpha @beta (Eq# alpha beta co) We don't generate a boxed "Wanted"; we generate only a regular old /unboxed/ primitive-equality Wanted, and build the box on the spot. * How can we get such a MkT? By promoting a GADT-style data constructor data T a b where MkT :: (a~b) => a -> b -> T a b See DataCon.mkPromotedDataCon and Note [Promoted data constructors] in TyCon * We support both homogeneous (~) and heterogeneous (~~) equality. (See Note [The equality types story] in TysPrim for a primer on these equality types.) * How do we prevent a MkT having an illegal constraint like Eq a? We check for this at use-sites; see TcHsType.tcTyVar, specifically dc_theta_illegal_constraint. * Notice that nothing special happens if K :: (a ~# b) => blah because (a ~# b) is not a predicate type, and is never implicitly instantiated. (Mind you, it's not clear how you could creates a type constructor with such a kind.) See Note [Types for coercions, predicates, and evidence] * The existence of promoted MkT with an equality-constraint argument is the (only) reason that the AnonTCB constructor of TyConBndrVis carries an AnonArgFlag (VisArg/InvisArg). For example, when we promote the data constructor MkT :: forall a b. (a~b) => a -> b -> T a b we get a PromotedDataCon with tyConBinders Bndr (a :: Type) (NamedTCB Inferred) Bndr (b :: Type) (NamedTCB Inferred) Bndr (_ :: a ~ b) (AnonTCB InvisArg) Bndr (_ :: a) (AnonTCB VisArg)) Bndr (_ :: b) (AnonTCB VisArg)) * One might reasonably wonder who *unpacks* these boxes once they are made. After all, there is no type-level `case` construct. The surprising answer is that no one ever does. Instead, if a GADT constructor is used on the left-hand side of a type family equation, that occurrence forces GHC to unify the types in question. For example: data G a where MkG :: G Bool type family F (x :: G a) :: a where F MkG = False When checking the LHS `F MkG`, GHC sees the MkG constructor and then must unify F's implicit parameter `a` with Bool. This succeeds, making the equation F Bool (MkG @Bool ) = False Note that we never need unpack the coercion. This is because type family equations are *not* parametric in their kind variables. That is, we could have just said type family H (x :: G a) :: a where H _ = False The presence of False on the RHS also forces `a` to become Bool, giving us H Bool _ = False The fact that any of this works stems from the lack of phase separation between types and kinds (unlike the very present phase separation between terms and types). Once we have the ability to pattern-match on types below top-level, this will no longer cut it, but it seems fine for now. Note [Arguments to type constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Because of kind polymorphism, in addition to type application we now have kind instantiation. We reuse the same notations to do so. For example: Just (* -> *) Maybe Right * Nat Zero are represented by: TyConApp (PromotedDataCon Just) [* -> *, Maybe] TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)] Important note: Nat is used as a *kind* and not as a type. This can be confusing, since type-level Nat and kind-level Nat are identical. We use the kind of (PromotedDataCon Right) to know if its arguments are kinds or types. This kind instantiation only happens in TyConApp currently. Note [Non-trivial definitional equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Is Int |> <*> the same as Int? YES! In order to reduce headaches, we decide that any reflexive casts in types are just ignored. (Indeed they must be. See Note [Respecting definitional equality].) More generally, the `eqType` function, which defines Core's type equality relation, ignores casts and coercion arguments, as long as the two types have the same kind. This allows us to be a little sloppier in keeping track of coercions, which is a good thing. It also means that eqType does not depend on eqCoercion, which is also a good thing. Why is this sensible? That is, why is something different than α-equivalence appropriate for the implementation of eqType? Anything smaller than ~ and homogeneous is an appropriate definition for equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any expression of type τ can be transmuted to one of type σ at any point by casting. The same is true of expressions of type σ. So in some sense, τ and σ are interchangeable. But let's be more precise. If we examine the typing rules of FC (say, those in https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf) there are several places where the same metavariable is used in two different premises to a rule. (For example, see Ty_App.) There is an implicit equality check here. What definition of equality should we use? By convention, we use α-equivalence. Take any rule with one (or more) of these implicit equality checks. Then there is an admissible rule that uses ~ instead of the implicit check, adding in casts as appropriate. The only problem here is that ~ is heterogeneous. To make the kinds work out in the admissible rule that uses ~, it is necessary to homogenize the coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η; we use η |> kind η, which is homogeneous. The effect of this all is that eqType, the implementation of the implicit equality check, can use any homogeneous relation that is smaller than ~, as those rules must also be admissible. A more drawn out argument around all of this is presented in Section 7.2 of Richard E's thesis (http://cs.brynmawr.edu/~rae/papers/2016/thesis/eisenberg-thesis.pdf). What would go wrong if we insisted on the casts matching? See the beginning of Section 8 in the unpublished paper above. Theoretically, nothing at all goes wrong. But in practical terms, getting the coercions right proved to be nightmarish. And types would explode: during kind-checking, we often produce reflexive kind coercions. When we try to cast by these, mkCastTy just discards them. But if we used an eqType that distinguished between Int and Int |> <*>, then we couldn't discard -- the output of kind-checking would be enormous, and we would need enormous casts with lots of CoherenceCo's to straighten them out. Would anything go wrong if eqType respected type families? No, not at all. But that makes eqType rather hard to implement. Thus, the guideline for eqType is that it should be the largest easy-to-implement relation that is still smaller than ~ and homogeneous. The precise choice of relation is somewhat incidental, as long as the smart constructors and destructors in Type respect whatever relation is chosen. Another helpful principle with eqType is this: (EQ) If (t1 `eqType` t2) then I can replace t1 by t2 anywhere. This principle also tells us that eqType must relate only types with the same kinds. Note [Respecting definitional equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note [Non-trivial definitional equality] introduces the property (EQ). How is this upheld? Any function that pattern matches on all the constructors will have to consider the possibility of CastTy. Presumably, those functions will handle CastTy appropriately and we'll be OK. More dangerous are the splitXXX functions. Let's focus on splitTyConApp. We don't want it to fail on (T a b c |> co). Happily, if we have (T a b c |> co) `eqType` (T d e f) then co must be reflexive. Why? eqType checks that the kinds are equal, as well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f). By the kind check, we know that (T a b c |> co) and (T d e f) have the same kind. So the only way that co could be non-reflexive is for (T a b c) to have a different kind than (T d e f). But because T's kind is closed (all tycon kinds are closed), the only way for this to happen is that one of the arguments has to differ, leading to a contradiction. Thus, co is reflexive. Accordingly, by eliminating reflexive casts, splitTyConApp need not worry about outermost casts to uphold (EQ). Eliminating reflexive casts is done in mkCastTy. Unforunately, that's not the end of the story. Consider comparing (T a b c) =? (T a b |> (co -> )) (c |> co) These two types have the same kind (Type), but the left type is a TyConApp while the right type is not. To handle this case, we say that the right-hand type is ill-formed, requiring an AppTy never to have a casted TyConApp on its left. It is easy enough to pull around the coercions to maintain this invariant, as done in Type.mkAppTy. In the example above, trying to form the right-hand type will instead yield (T a b (c |> co |> sym co) |> ). Both the casts there are reflexive and will be dropped. Huzzah. This idea of pulling coercions to the right works for splitAppTy as well. However, there is one hiccup: it's possible that a coercion doesn't relate two Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@, then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not `eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate our (EQ) property. Lastly, in order to detect reflexive casts reliably, we must make sure not to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)). In sum, in order to uphold (EQ), we need the following three invariants: (EQ1) No decomposable CastTy to the left of an AppTy, where a decomposable cast is one that relates either a FunTy to a FunTy or a ForAllTy to a ForAllTy. (EQ2) No reflexive casts in CastTy. (EQ3) No nested CastTys. (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body). See Note [Weird typing rule for ForAllTy] in Type. These invariants are all documented above, in the declaration for Type. Note [Unused coercion variable in ForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have \(co:t1 ~ t2). e What type should we give to this expression? (1) forall (co:t1 ~ t2) -> t (2) (t1 ~ t2) -> t If co is used in t, (1) should be the right choice. if co is not used in t, we would like to have (1) and (2) equivalent. However, we want to keep eqType simple and don't want eqType (1) (2) to return True in any case. We decide to always construct (2) if co is not used in t. Thus in mkLamType, we check whether the variable is a coercion variable (of type (t1 ~# t2), and whether it is un-used in the body. If so, it returns a FunTy instead of a ForAllTy. There are cases we want to skip the check. For example, the check is unnecessary when it is known from the context that the input variable is a type variable. In those cases, we use mkForAllTy. -} -- | A type labeled 'KnotTied' might have knot-tied tycons in it. See -- Note [Type checking recursive type and class declarations] in -- TcTyClsDecls type KnotTied ty = ty {- ********************************************************************** * * TyCoBinder and ArgFlag * * ********************************************************************** -} -- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be -- dependent ('Named') or nondependent ('Anon'). They may also be visible or -- not. See Note [TyCoBinders] data TyCoBinder = Named TyCoVarBinder -- A type-lambda binder | Anon AnonArgFlag Type -- A term-lambda binder. Type here can be CoercionTy. -- Visibility is determined by the AnonArgFlag deriving Data.Data instance Outputable TyCoBinder where ppr (Anon af ty) = ppr af <+> ppr ty ppr (Named (Bndr v Required)) = ppr v ppr (Named (Bndr v Specified)) = char '@' <> ppr v ppr (Named (Bndr v Inferred)) = braces (ppr v) -- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder' -- in the 'Named' field. type TyBinder = TyCoBinder -- | Remove the binder's variable from the set, if the binder has -- a variable. delBinderVar :: VarSet -> TyCoVarBinder -> VarSet delBinderVar vars (Bndr tv _) = vars `delVarSet` tv -- | Does this binder bind an invisible argument? isInvisibleBinder :: TyCoBinder -> Bool isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis isInvisibleBinder (Anon InvisArg _) = True isInvisibleBinder (Anon VisArg _) = False -- | Does this binder bind a visible argument? isVisibleBinder :: TyCoBinder -> Bool isVisibleBinder = not . isInvisibleBinder isNamedBinder :: TyCoBinder -> Bool isNamedBinder (Named {}) = True isNamedBinder (Anon {}) = False -- | If its a named binder, is the binder a tyvar? -- Returns True for nondependent binder. -- This check that we're really returning a *Ty*Binder (as opposed to a -- coercion binder). That way, if/when we allow coercion quantification -- in more places, we'll know we missed updating some function. isTyBinder :: TyCoBinder -> Bool isTyBinder (Named bnd) = isTyVarBinder bnd isTyBinder _ = True {- Note [TyCoBinders] ~~~~~~~~~~~~~~~~~~~ A ForAllTy contains a TyCoVarBinder. But a type can be decomposed to a telescope consisting of a [TyCoBinder] A TyCoBinder represents the type of binders -- that is, the type of an argument to a Pi-type. GHC Core currently supports two different Pi-types: * A non-dependent function type, written with ->, e.g. ty1 -> ty2 represented as FunTy ty1 ty2. These are lifted to Coercions with the corresponding FunCo. * A dependent compile-time-only polytype, written with forall, e.g. forall (a:*). ty represented as ForAllTy (Bndr a v) ty Both Pi-types classify terms/types that take an argument. In other words, if `x` is either a function or a polytype, `x arg` makes sense (for an appropriate `arg`). Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * A ForAllTy (used for both types and kinds) contains a TyCoVarBinder. Each TyCoVarBinder Bndr a tvis is equipped with tvis::ArgFlag, which says whether or not arguments for this binder should be visible (explicit) in source Haskell. * A TyCon contains a list of TyConBinders. Each TyConBinder Bndr a cvis is equipped with cvis::TyConBndrVis, which says whether or not type and kind arguments for this TyCon should be visible (explicit) in source Haskell. This table summarises the visibility rules: --------------------------------------------------------------------------------------- | Occurrences look like this | GHC displays type as in Haskell source code |-------------------------------------------------------------------------------------- | Bndr a tvis :: TyCoVarBinder, in the binder of ForAllTy for a term | tvis :: ArgFlag | tvis = Inferred: f :: forall {a}. type Arg not allowed: f f :: forall {co}. type Arg not allowed: f | tvis = Specified: f :: forall a. type Arg optional: f or f @Int | tvis = Required: T :: forall k -> type Arg required: T * | This last form is illegal in terms: See Note [No Required TyCoBinder in terms] | | Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon | cvis :: TyConBndrVis | cvis = AnonTCB: T :: kind -> kind Required: T * | cvis = NamedTCB Inferred: T :: forall {k}. kind Arg not allowed: T | T :: forall {co}. kind Arg not allowed: T | cvis = NamedTCB Specified: T :: forall k. kind Arg not allowed[1]: T | cvis = NamedTCB Required: T :: forall k -> kind Required: T * --------------------------------------------------------------------------------------- [1] In types, in the Specified case, it would make sense to allow optional kind applications, thus (T @*), but we have not yet implemented that ---- In term declarations ---- * Inferred. Function defn, with no signature: f1 x = x We infer f1 :: forall {a}. a -> a, with 'a' Inferred It's Inferred because it doesn't appear in any user-written signature for f1 * Specified. Function defn, with signature (implicit forall): f2 :: a -> a; f2 x = x So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified even though 'a' is not bound in the source code by an explicit forall * Specified. Function defn, with signature (explicit forall): f3 :: forall a. a -> a; f3 x = x So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified * Inferred/Specified. Function signature with inferred kind polymorphism. f4 :: a b -> Int So 'f4' gets the type f4 :: forall {k} (a:k->*) (b:k). a b -> Int Here 'k' is Inferred (it's not mentioned in the type), but 'a' and 'b' are Specified. * Specified. Function signature with explicit kind polymorphism f5 :: a (b :: k) -> Int This time 'k' is Specified, because it is mentioned explicitly, so we get f5 :: forall (k:*) (a:k->*) (b:k). a b -> Int * Similarly pattern synonyms: Inferred - from inferred types (e.g. no pattern type signature) - or from inferred kind polymorphism ---- In type declarations ---- * Inferred (k) data T1 a b = MkT1 (a b) Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * The kind variable 'k' is Inferred, since it is not mentioned Note that 'a' and 'b' correspond to /Anon/ TyCoBinders in T1's kind, and Anon binders don't have a visibility flag. (Or you could think of Anon having an implicit Required flag.) * Specified (k) data T2 (a::k->*) b = MkT (a b) Here T's kind is T :: forall (k:*). (k->*) -> k -> * The kind variable 'k' is Specified, since it is mentioned in the signature. * Required (k) data T k (a::k->*) b = MkT (a b) Here T's kind is T :: forall k:* -> (k->*) -> k -> * The kind is Required, since it bound in a positional way in T's declaration Every use of T must be explicitly applied to a kind * Inferred (k1), Specified (k) data T a b (c :: k) = MkT (a b) (Proxy c) Here T's kind is T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> * So 'k' is Specified, because it appears explicitly, but 'k1' is Inferred, because it does not Generally, in the list of TyConBinders for a TyCon, * Inferred arguments always come first * Specified, Anon and Required can be mixed e.g. data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ... Here Foo's TyConBinders are [Required 'a', Specified 'b', Anon] and its kind prints as Foo :: forall a -> forall b. (a -> b -> Type) -> Type See also Note [Required, Specified, and Inferred for types] in TcTyClsDecls ---- Printing ----- We print forall types with enough syntax to tell you their visibility flag. But this is not source Haskell, and these types may not all be parsable. Specified: a list of Specified binders is written between `forall` and `.`: const :: forall a b. a -> b -> a Inferred: with -fprint-explicit-foralls, Inferred binders are written in braces: f :: forall {k} (a:k). S k a -> Int Otherwise, they are printed like Specified binders. Required: binders are put between `forall` and `->`: T :: forall k -> * ---- Other points ----- * In classic Haskell, all named binders (that is, the type variables in a polymorphic function type f :: forall a. a -> a) have been Inferred. * Inferred variables correspond to "generalized" variables from the Visible Type Applications paper (ESOP'16). Note [No Required TyCoBinder in terms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We don't allow Required foralls for term variables, including pattern synonyms and data constructors. Why? Because then an application would need a /compulsory/ type argument (possibly without an "@"?), thus (f Int); and we don't have concrete syntax for that. We could change this decision, but Required, Named TyCoBinders are rare anyway. (Most are Anons.) However the type of a term can (just about) have a required quantifier; see Note [Required quantifiers in the type of a term] in TcExpr. -} {- ********************************************************************** * * PredType * * ********************************************************************** -} -- | A type of the form @p@ of constraint kind represents a value whose type is -- the Haskell predicate @p@, where a predicate is what occurs before -- the @=>@ in a Haskell type. -- -- We use 'PredType' as documentation to mark those types that we guarantee to -- have this kind. -- -- It can be expanded into its representation, but: -- -- * The type checker must treat it as opaque -- -- * The rest of the compiler treats it as transparent -- -- Consider these examples: -- -- > f :: (Eq a) => a -> Int -- > g :: (?x :: Int -> Int) => a -> Int -- > h :: (r\l) => {r} => {l::Int | r} -- -- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" type PredType = Type -- | A collection of 'PredType's type ThetaType = [PredType] {- (We don't support TREX records yet, but the setup is designed to expand to allow them.) A Haskell qualified type, such as that for f,g,h above, is represented using * a FunTy for the double arrow * with a type of kind Constraint as the function argument The predicate really does turn into a real extra argument to the function. If the argument has type (p :: Constraint) then the predicate p is represented by evidence of type p. %************************************************************************ %* * Simple constructors %* * %************************************************************************ These functions are here so that they can be used by TysPrim, which in turn is imported by Type -} mkTyVarTy :: TyVar -> Type mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) ) TyVarTy v mkTyVarTys :: [TyVar] -> [Type] mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy mkTyCoVarTy :: TyCoVar -> Type mkTyCoVarTy v | isTyVar v = TyVarTy v | otherwise = CoercionTy (CoVarCo v) mkTyCoVarTys :: [TyCoVar] -> [Type] mkTyCoVarTys = map mkTyCoVarTy infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy` -- Associates to the right mkFunTy :: AnonArgFlag -> Type -> Type -> Type mkFunTy af arg res = FunTy { ft_af = af, ft_arg = arg, ft_res = res } mkVisFunTy, mkInvisFunTy :: Type -> Type -> Type mkVisFunTy = mkFunTy VisArg mkInvisFunTy = mkFunTy InvisArg -- | Make nested arrow types mkVisFunTys, mkInvisFunTys :: [Type] -> Type -> Type mkVisFunTys tys ty = foldr mkVisFunTy ty tys mkInvisFunTys tys ty = foldr mkInvisFunTy ty tys -- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder -- See Note [Unused coercion variable in ForAllTy] mkForAllTy :: TyCoVar -> ArgFlag -> Type -> Type mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty -- | Wraps foralls over the type using the provided 'TyCoVar's from left to right mkForAllTys :: [TyCoVarBinder] -> Type -> Type mkForAllTys tyvars ty = foldr ForAllTy ty tyvars mkPiTy:: TyCoBinder -> Type -> Type mkPiTy (Anon af ty1) ty2 = FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 } mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty mkPiTys :: [TyCoBinder] -> Type -> Type mkPiTys tbs ty = foldr mkPiTy ty tbs -- | Create the plain type constructor type which has been applied to no type arguments at all. mkTyConTy :: TyCon -> Type mkTyConTy tycon = TyConApp tycon [] {- %************************************************************************ %* * Coercions %* * %************************************************************************ -} -- | A 'Coercion' is concrete evidence of the equality/convertibility -- of two types. -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.hs data Coercion -- Each constructor has a "role signature", indicating the way roles are -- propagated through coercions. -- - P, N, and R stand for coercions of the given role -- - e stands for a coercion of a specific unknown role -- (think "role polymorphism") -- - "e" stands for an explicit role parameter indicating role e. -- - _ stands for a parameter that is not a Role or Coercion. -- These ones mirror the shape of types = -- Refl :: _ -> N Refl Type -- See Note [Refl invariant] -- Invariant: applications of (Refl T) to a bunch of identity coercions -- always show up as Refl. -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)). -- Applications of (Refl T) to some coercions, at least one of -- which is NOT the identity, show up as TyConAppCo. -- (They may not be fully saturated however.) -- ConAppCo coercions (like all coercions other than Refl) -- are NEVER the identity. -- Use (GRefl Representational ty MRefl), not (SubCo (Refl ty)) -- GRefl :: "e" -> _ -> Maybe N -> e -- See Note [Generalized reflexive coercion] | GRefl Role Type MCoercionN -- See Note [Refl invariant] -- Use (Refl ty), not (GRefl Nominal ty MRefl) -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _)) -- These ones simply lift the correspondingly-named -- Type constructors into Coercions -- TyConAppCo :: "e" -> _ -> ?? -> e -- See Note [TyConAppCo roles] | TyConAppCo Role TyCon [Coercion] -- lift TyConApp -- The TyCon is never a synonym; -- we expand synonyms eagerly -- But it can be a type function | AppCo Coercion CoercionN -- lift AppTy -- AppCo :: e -> N -> e -- See Note [Forall coercions] | ForAllCo TyCoVar KindCoercion Coercion -- ForAllCo :: _ -> N -> e -> e | FunCo Role Coercion Coercion -- lift FunTy -- FunCo :: "e" -> e -> e -> e -- Note: why doesn't FunCo have a AnonArgFlag, like FunTy? -- Because the AnonArgFlag has no impact on Core; it is only -- there to guide implicit instantiation of Haskell source -- types, and that is irrelevant for coercions, which are -- Core-only. -- These are special | CoVarCo CoVar -- :: _ -> (N or R) -- result role depends on the tycon of the variable's type -- AxiomInstCo :: e -> _ -> ?? -> e | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] -- See also [CoAxiom index] -- The coercion arguments always *precisely* saturate -- arity of (that branch of) the CoAxiom. If there are -- any left over, we use AppCo. -- See [Coercion axioms applied to coercions] -- The roles of the argument coercions are determined -- by the cab_roles field of the relevant branch of the CoAxiom | AxiomRuleCo CoAxiomRule [Coercion] -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule -- The number coercions should match exactly the expectations -- of the CoAxiomRule (i.e., the rule is fully saturated). | UnivCo UnivCoProvenance Role Type Type -- :: _ -> "e" -> _ -> _ -> e | SymCo Coercion -- :: e -> e | TransCo Coercion Coercion -- :: e -> e -> e | NthCo Role Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) -- :: "e" -> _ -> e0 -> e (inverse of TyConAppCo, see Note [TyConAppCo roles]) -- Using NthCo on a ForAllCo gives an N coercion always -- See Note [NthCo and newtypes] -- -- Invariant: (NthCo r i co), it is always the case that r = role of (Nth i co) -- That is: the role of the entire coercion is redundantly cached here. -- See Note [NthCo Cached Roles] | LRCo LeftOrRight CoercionN -- Decomposes (t_left t_right) -- :: _ -> N -> N | InstCo Coercion CoercionN -- :: e -> N -> e -- See Note [InstCo roles] -- Extract a kind coercion from a (heterogeneous) type coercion -- NB: all kind coercions are Nominal | KindCo Coercion -- :: e -> N | SubCo CoercionN -- Turns a ~N into a ~R -- :: N -> R | HoleCo CoercionHole -- ^ See Note [Coercion holes] -- Only present during typechecking deriving Data.Data type CoercionN = Coercion -- always nominal type CoercionR = Coercion -- always representational type CoercionP = Coercion -- always phantom type KindCoercion = CoercionN -- always nominal instance Outputable Coercion where ppr = pprCo -- | A semantically more meaningful type to represent what may or may not be a -- useful 'Coercion'. data MCoercion = MRefl -- A trivial Reflexivity coercion | MCo Coercion -- Other coercions deriving Data.Data type MCoercionR = MCoercion type MCoercionN = MCoercion instance Outputable MCoercion where ppr MRefl = text "MRefl" ppr (MCo co) = text "MCo" <+> ppr co {- Note [Refl invariant] ~~~~~~~~~~~~~~~~~~~~~ Invariant 1: Coercions have the following invariant Refl (similar for GRefl r ty MRefl) is always lifted as far as possible. You might think that a consequencs is: Every identity coercions has Refl at the root But that's not quite true because of coercion variables. Consider g where g :: Int~Int Left h where h :: Maybe Int ~ Maybe Int etc. So the consequence is only true of coercions that have no coercion variables. Note [Generalized reflexive coercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GRefl is a generalized reflexive coercion (see #15192). It wraps a kind coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing rules for GRefl: ty : k1 ------------------------------------ GRefl r ty MRefl: ty ~r ty ty : k1 co :: k1 ~ k2 ------------------------------------ GRefl r ty (MCo co) : ty ~r ty |> co Consider we have g1 :: s ~r t s :: k1 g2 :: k1 ~ k2 and we want to construct a coercions co which has type (s |> g2) ~r t We can define co = Sym (GRefl r s g2) ; g1 It is easy to see that Refl == GRefl Nominal ty MRefl :: ty ~n ty A nominal reflexive coercion is quite common, so we keep the special form Refl to save allocation. Note [Coercion axioms applied to coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The reason coercion axioms can be applied to coercions and not just types is to allow for better optimization. There are some cases where we need to be able to "push transitivity inside" an axiom in order to expose further opportunities for optimization. For example, suppose we have C a : t[a] ~ F a g : b ~ c and we want to optimize sym (C b) ; t[g] ; C c which has the kind F b ~ F c (stopping through t[b] and t[c] along the way). We'd like to optimize this to just F g -- but how? The key is that we need to allow axioms to be instantiated by *coercions*, not just by types. Then we can (in certain cases) push transitivity inside the axiom instantiations, and then react opposite-polarity instantiations of the same axiom. In this case, e.g., we match t[g] against the LHS of (C c)'s kind, to obtain the substitution a |-> g (note this operation is sort of the dual of lifting!) and hence end up with C g : t[b] ~ F c which indeed has the same kind as t[g] ; C c. Now we have sym (C b) ; C g which can be optimized to F g. Note [CoAxiom index] ~~~~~~~~~~~~~~~~~~~~ A CoAxiom has 1 or more branches. Each branch has contains a list of the free type variables in that branch, the LHS type patterns, and the RHS type for that branch. When we apply an axiom to a list of coercions, we must choose which branch of the axiom we wish to use, as the different branches may have different numbers of free type variables. (The number of type patterns is always the same among branches, but that doesn't quite concern us here.) The Int in the AxiomInstCo constructor is the 0-indexed number of the chosen branch. Note [Forall coercions] ~~~~~~~~~~~~~~~~~~~~~~~ Constructing coercions between forall-types can be a bit tricky, because the kinds of the bound tyvars can be different. The typing rule is: kind_co : k1 ~ k2 tv1:k1 |- co : t1 ~ t2 ------------------------------------------------------------------- ForAllCo tv1 kind_co co : all tv1:k1. t1 ~ all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co]) First, the TyCoVar stored in a ForAllCo is really an optimisation: this field should be a Name, as its kind is redundant. Thinking of the field as a Name is helpful in understanding what a ForAllCo means. The kind of TyCoVar always matches the left-hand kind of the coercion. The idea is that kind_co gives the two kinds of the tyvar. See how, in the conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. Of course, a type variable can't have different kinds at the same time. So, we arbitrarily prefer the first kind when using tv1 in the inner coercion co, which shows that t1 equals t2. The last wrinkle is that we need to fix the kinds in the conclusion. In t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with (tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it mentions the same name with different kinds, but it *is* well-kinded, noting that `(tv1:k2) |> sym kind_co` has kind k1. This all really would work storing just a Name in the ForAllCo. But we can't add Names to, e.g., VarSets, and there generally is just an impedance mismatch in a bunch of places. So we use tv1. When we need tv2, we can use setTyVarKind. Note [Predicate coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have g :: a~b How can we coerce between types ([c]~a) => [a] -> c and ([c]~b) => [b] -> c where the equality predicate *itself* differs? Answer: we simply treat (~) as an ordinary type constructor, so these types really look like ((~) [c] a) -> [a] -> c ((~) [c] b) -> [b] -> c So the coercion between the two is obviously ((~) [c] g) -> [g] -> c Another way to see this to say that we simply collapse predicates to their representation type (see Type.coreView and Type.predTypeRep). This collapse is done by mkPredCo; there is no PredCo constructor in Coercion. This is important because we need Nth to work on predicates too: Nth 1 ((~) [c] g) = g See Simplify.simplCoercionF, which generates such selections. Note [Roles] ~~~~~~~~~~~~ Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated in #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see https://gitlab.haskell.org/ghc/ghc/wikis/roles-implementation Here is one way to phrase the problem: Given: newtype Age = MkAge Int type family F x type instance F Age = Bool type instance F Int = Char This compiles down to: axAge :: Age ~ Int axF1 :: F Age ~ Bool axF2 :: F Int ~ Char Then, we can make: (sym (axF1) ; F axAge ; axF2) :: Bool ~ Char Yikes! The solution is _roles_, as articulated in "Generative Type Abstraction and Type-level Computation" (POPL 2010), available at http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf The specification for roles has evolved somewhat since that paper. For the current full details, see the documentation in docs/core-spec. Here are some highlights. We label every equality with a notion of type equivalence, of which there are three options: Nominal, Representational, and Phantom. A ground type is nominally equivalent only with itself. A newtype (which is considered a ground type in Haskell) is representationally equivalent to its representation. Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P" to denote the equivalences. The axioms above would be: axAge :: Age ~R Int axF1 :: F Age ~N Bool axF2 :: F Age ~N Char Then, because transitivity applies only to coercions proving the same notion of equivalence, the above construction is impossible. However, there is still an escape hatch: we know that any two types that are nominally equivalent are representationally equivalent as well. This is what the form SubCo proves -- it "demotes" a nominal equivalence into a representational equivalence. So, it would seem the following is possible: sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG What saves us here is that the arguments to a type function F, lifted into a coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and we are safe. Roles are attached to parameters to TyCons. When lifting a TyCon into a coercion (through TyConAppCo), we need to ensure that the arguments to the TyCon respect their roles. For example: data T a b = MkT a (F b) If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because the type function F branches on b's *name*, not representation. So, we say that 'a' has role Representational and 'b' has role Nominal. The third role, Phantom, is for parameters not used in the type's definition. Given the following definition data Q a = MkQ Int the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we can construct the coercion Bool ~P Char (using UnivCo). See the paper cited above for more examples and information. Note [TyConAppCo roles] ~~~~~~~~~~~~~~~~~~~~~~~ The TyConAppCo constructor has a role parameter, indicating the role at which the coercion proves equality. The choice of this parameter affects the required roles of the arguments of the TyConAppCo. To help explain it, assume the following definition: type instance F Int = Bool -- Axiom axF : F Int ~N Bool newtype Age = MkAge Int -- Axiom axAge : Age ~R Int data Foo a = MkFoo a -- Role on Foo's parameter is Representational TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool For (TyConAppCo Nominal) all arguments must have role Nominal. Why? So that Foo Age ~N Foo Int does *not* hold. TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool TyConAppCo Representational Foo axAge : Foo Age ~R Foo Int For (TyConAppCo Representational), all arguments must have the roles corresponding to the result of tyConRoles on the TyCon. This is the whole point of having roles on the TyCon to begin with. So, we can have Foo Age ~R Foo Int, if Foo's parameter has role R. If a Representational TyConAppCo is over-saturated (which is otherwise fine), the spill-over arguments must all be at Nominal. This corresponds to the behavior for AppCo. TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool All arguments must have role Phantom. This one isn't strictly necessary for soundness, but this choice removes ambiguity. The rules here dictate the roles of the parameters to mkTyConAppCo (should be checked by Lint). Note [NthCo and newtypes] ~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have newtype N a = MkN Int type role N representational This yields axiom NTCo:N :: forall a. N a ~R Int We can then build co :: forall a b. N a ~R N b co = NTCo:N a ; sym (NTCo:N b) for any `a` and `b`. Because of the role annotation on N, if we use NthCo, we'll get out a representational coercion. That is: NthCo r 0 co :: forall a b. a ~R b Yikes! Clearly, this is terrible. The solution is simple: forbid NthCo to be used on newtypes if the internal coercion is representational. This is not just some corner case discovered by a segfault somewhere; it was discovered in the proof of soundness of roles and described in the "Safe Coercions" paper (ICFP '14). Note [NthCo Cached Roles] ~~~~~~~~~~~~~~~~~~~~~~~~~ Why do we cache the role of NthCo in the NthCo constructor? Because computing role(Nth i co) involves figuring out that co :: T tys1 ~ T tys2 using coercionKind, and finding (coercionRole co), and then looking at the tyConRoles of T. Avoiding bad asymptotic behaviour here means we have to compute the kind and role of a coercion simultaneously, which makes the code complicated and inefficient. This only happens for NthCo. Caching the role solves the problem, and allows coercionKind and coercionRole to be simple. See #11735 Note [InstCo roles] ~~~~~~~~~~~~~~~~~~~ Here is (essentially) the typing rule for InstCo: g :: (forall a. t1) ~r (forall a. t2) w :: s1 ~N s2 ------------------------------- InstCo InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2]) Note that the Coercion w *must* be nominal. This is necessary because the variable a might be used in a "nominal position" (that is, a place where role inference would require a nominal role) in t1 or t2. If we allowed w to be representational, we could get bogus equalities. A more nuanced treatment might be able to relax this condition somewhat, by checking if t1 and/or t2 use their bound variables in nominal ways. If not, having w be representational is OK. %************************************************************************ %* * UnivCoProvenance %* * %************************************************************************ A UnivCo is a coercion whose proof does not directly express its role and kind (indeed for some UnivCos, like UnsafeCoerceProv, there /is/ no proof). The different kinds of UnivCo are described by UnivCoProvenance. Really each is entirely separate, but they all share the need to represent their role and kind, which is done in the UnivCo constructor. -} -- | For simplicity, we have just one UnivCo that represents a coercion from -- some type to some other type, with (in general) no restrictions on the -- type. The UnivCoProvenance specifies more exactly what the coercion really -- is and why a program should (or shouldn't!) trust the coercion. -- It is reasonable to consider each constructor of 'UnivCoProvenance' -- as a totally independent coercion form; their only commonality is -- that they don't tell you what types they coercion between. (That info -- is in the 'UnivCo' constructor of 'Coercion'. data UnivCoProvenance = UnsafeCoerceProv -- ^ From @unsafeCoerce#@. These are unsound. | PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom -- roled coercions | ProofIrrelProv KindCoercion -- ^ From the fact that any two coercions are -- considered equivalent. See Note [ProofIrrelProv]. -- Can be used in Nominal or Representational coercions | PluginProv String -- ^ From a plugin, which asserts that this coercion -- is sound. The string is for the use of the plugin. deriving Data.Data instance Outputable UnivCoProvenance where ppr UnsafeCoerceProv = text "(unsafeCoerce#)" ppr (PhantomProv _) = text "(phantom)" ppr (ProofIrrelProv _) = text "(proof irrel.)" ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) -- | A coercion to be filled in by the type-checker. See Note [Coercion holes] data CoercionHole = CoercionHole { ch_co_var :: CoVar -- See Note [CoercionHoles and coercion free variables] , ch_ref :: IORef (Maybe Coercion) } coHoleCoVar :: CoercionHole -> CoVar coHoleCoVar = ch_co_var setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole setCoHoleCoVar h cv = h { ch_co_var = cv } instance Data.Data CoercionHole where -- don't traverse? toConstr _ = abstractConstr "CoercionHole" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "CoercionHole" instance Outputable CoercionHole where ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv) {- Note [Phantom coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T a = T1 | T2 Then we have T s ~R T t for any old s,t. The witness for this is (TyConAppCo T Rep co), where (co :: s ~P t) is a phantom coercion built with PhantomProv. The role of the UnivCo is always Phantom. The Coercion stored is the (nominal) kind coercion between the types kind(s) ~N kind (t) Note [Coercion holes] ~~~~~~~~~~~~~~~~~~~~~~~~ During typechecking, constraint solving for type classes works by - Generate an evidence Id, d7 :: Num a - Wrap it in a Wanted constraint, [W] d7 :: Num a - Use the evidence Id where the evidence is needed - Solve the constraint later - When solved, add an enclosing let-binding let d7 = .... in .... which actually binds d7 to the (Num a) evidence For equality constraints we use a different strategy. See Note [The equality types story] in TysPrim for background on equality constraints. - For /boxed/ equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just like type classes above. (Indeed, boxed equality constraints *are* classes.) - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2) we use a different plan For unboxed equalities: - Generate a CoercionHole, a mutable variable just like a unification variable - Wrap the CoercionHole in a Wanted constraint; see TcRnTypes.TcEvDest - Use the CoercionHole in a Coercion, via HoleCo - Solve the constraint later - When solved, fill in the CoercionHole by side effect, instead of doing the let-binding thing The main reason for all this is that there may be no good place to let-bind the evidence for unboxed equalities: - We emit constraints for kind coercions, to be used to cast a type's kind. These coercions then must be used in types. Because they might appear in a top-level type, there is no place to bind these (unlifted) coercions in the usual way. - A coercion for (forall a. t1) ~ (forall a. t2) will look like forall a. (coercion for t1~t2) But the coercion for (t1~t2) may mention 'a', and we don't have let-bindings within coercions. We could add them, but coercion holes are easier. - Moreover, nothing is lost from the lack of let-bindings. For dicionaries want to achieve sharing to avoid recomoputing the dictionary. But coercions are entirely erased, so there's little benefit to sharing. Indeed, even if we had a let-binding, we always inline types and coercions at every use site and drop the binding. Other notes about HoleCo: * INVARIANT: CoercionHole and HoleCo are used only during type checking, and should never appear in Core. Just like unification variables; a Type can contain a TcTyVar, but only during type checking. If, one day, we use type-level information to separate out forms that can appear during type-checking vs forms that can appear in core proper, holes in Core will be ruled out. * See Note [CoercionHoles and coercion free variables] * Coercion holes can be compared for equality like other coercions: by looking at the types coerced. Note [CoercionHoles and coercion free variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Why does a CoercionHole contain a CoVar, as well as reference to fill in? Because we want to treat that CoVar as a free variable of the coercion. See #14584, and Note [What prevents a constraint from floating] in TcSimplify, item (4): forall k. [W] co1 :: t1 ~# t2 |> co2 [W] co2 :: k ~# * Here co2 is a CoercionHole. But we /must/ know that it is free in co1, because that's all that stops it floating outside the implication. Note [ProofIrrelProv] ~~~~~~~~~~~~~~~~~~~~~ A ProofIrrelProv is a coercion between coercions. For example: data G a where MkG :: G Bool In core, we get G :: * -> * MkG :: forall (a :: *). (a ~ Bool) -> G a Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be TyConAppCo Nominal MkG [co3, co4] where co3 :: co1 ~ co2 co4 :: a1 ~ a2 Note that co1 :: a1 ~ Bool co2 :: a2 ~ Bool Here, co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2) where co5 :: (a1 ~ Bool) ~ (a2 ~ Bool) co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, ] -} {- ********************************************************************* * * typeSize, coercionSize * * ********************************************************************* -} -- NB: We put typeSize/coercionSize here because they are mutually -- recursive, and have the CPR property. If we have mutual -- recursion across a hi-boot file, we don't get the CPR property -- and these functions allocate a tremendous amount of rubbish. -- It's not critical (because typeSize is really only used in -- debug mode, but I tripped over an example (T5642) in which -- typeSize was one of the biggest single allocators in all of GHC. -- And it's easy to fix, so I did. -- NB: typeSize does not respect `eqType`, in that two types that -- are `eqType` may return different sizes. This is OK, because this -- function is used only in reporting, not decision-making. typeSize :: Type -> Int typeSize (LitTy {}) = 1 typeSize (TyVarTy {}) = 1 typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 typeSize (FunTy _ t1 t2) = typeSize t1 + typeSize t2 typeSize (ForAllTy (Bndr tv _) t) = typeSize (varType tv) + typeSize t typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) typeSize (CastTy ty co) = typeSize ty + coercionSize co typeSize (CoercionTy co) = coercionSize co coercionSize :: Coercion -> Int coercionSize (Refl ty) = typeSize ty coercionSize (GRefl _ ty MRefl) = typeSize ty coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args) coercionSize (AppCo co arg) = coercionSize co + coercionSize arg coercionSize (ForAllCo _ h co) = 1 + coercionSize co + coercionSize h coercionSize (FunCo _ co1 co2) = 1 + coercionSize co1 + coercionSize co2 coercionSize (CoVarCo _) = 1 coercionSize (HoleCo _) = 1 coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args) coercionSize (UnivCo p _ t1 t2) = 1 + provSize p + typeSize t1 + typeSize t2 coercionSize (SymCo co) = 1 + coercionSize co coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 coercionSize (NthCo _ _ co) = 1 + coercionSize co coercionSize (LRCo _ co) = 1 + coercionSize co coercionSize (InstCo co arg) = 1 + coercionSize co + coercionSize arg coercionSize (KindCo co) = 1 + coercionSize co coercionSize (SubCo co) = 1 + coercionSize co coercionSize (AxiomRuleCo _ cs) = 1 + sum (map coercionSize cs) provSize :: UnivCoProvenance -> Int provSize UnsafeCoerceProv = 1 provSize (PhantomProv co) = 1 + coercionSize co provSize (ProofIrrelProv co) = 1 + coercionSize co provSize (PluginProv _) = 1 ghc-lib-parser-8.10.2.20200808/compiler/types/TyCoSubst.hs0000644000000000000000000012221513713635745020723 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1998 Type and Coercion - friends' interface -} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -- | Substitution into types and coercions. module TyCoSubst ( -- * Substitutions TCvSubst(..), TvSubstEnv, CvSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, mkTCvSubst, mkTvSubst, mkCvSubst, getTvSubstEnv, getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs, isInScope, notElemTCvSubst, setTvSubstEnv, setCvSubstEnv, zapTCvSubst, extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, extendTCvSubst, extendTCvSubstWithClone, extendCvSubst, extendCvSubstWithClone, extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone, extendTvSubstList, extendTvSubstAndInScope, extendTCvSubstList, unionTCvSubst, zipTyEnv, zipCoEnv, mkTyCoInScopeSet, zipTvSubst, zipCvSubst, zipTCvSubst, mkTvSubstPrs, substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, substCoWith, substTy, substTyAddInScope, substTyUnchecked, substTysUnchecked, substThetaUnchecked, substTyWithUnchecked, substCoUnchecked, substCoWithUnchecked, substTyWithInScope, substTys, substTheta, lookupTyVar, substCo, substCos, substCoVar, substCoVars, lookupCoVar, cloneTyVarBndr, cloneTyVarBndrs, substVarBndr, substVarBndrs, substTyVarBndr, substTyVarBndrs, substCoVarBndr, substTyVar, substTyVars, substTyCoVars, substForAllCoBndr, substVarBndrUsing, substForAllCoBndrUsing, checkValidSubst, isValidTCvSubst, ) where #include "GhclibHsVersions.h" import GhcPrelude import {-# SOURCE #-} Type ( mkCastTy, mkAppTy, isCoercionTy ) import {-# SOURCE #-} Coercion ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo , mkNomReflCo, mkSubCo, mkSymCo , mkFunCo, mkForAllCo, mkUnivCo , mkAxiomInstCo, mkAppCo, mkGReflCo , mkInstCo, mkLRCo, mkTyConAppCo , mkCoercionType , coercionKind, coVarKindsTypesRole ) import TyCoRep import TyCoFVs import TyCoPpr import Var import VarSet import VarEnv import Pair import Util import UniqSupply import Unique import UniqFM import UniqSet import Outputable import Data.List (mapAccumL) {- %************************************************************************ %* * Substitutions Data type defined here to avoid unnecessary mutual recursion %* * %************************************************************************ -} -- | Type & coercion substitution -- -- #tcvsubst_invariant# -- The following invariants must hold of a 'TCvSubst': -- -- 1. The in-scope set is needed /only/ to -- guide the generation of fresh uniques -- -- 2. In particular, the /kind/ of the type variables in -- the in-scope set is not relevant -- -- 3. The substitution is only applied ONCE! This is because -- in general such application will not reach a fixed point. data TCvSubst = TCvSubst InScopeSet -- The in-scope type and kind variables TvSubstEnv -- Substitutes both type and kind variables CvSubstEnv -- Substitutes coercion variables -- See Note [Substitutions apply only once] -- and Note [Extending the TvSubstEnv] -- and Note [Substituting types and coercions] -- and Note [The substitution invariant] -- | A substitution of 'Type's for 'TyVar's -- and 'Kind's for 'KindVar's type TvSubstEnv = TyVarEnv Type -- NB: A TvSubstEnv is used -- both inside a TCvSubst (with the apply-once invariant -- discussed in Note [Substitutions apply only once], -- and also independently in the middle of matching, -- and unification (see Types.Unify). -- So you have to look at the context to know if it's idempotent or -- apply-once or whatever -- | A substitution of 'Coercion's for 'CoVar's type CvSubstEnv = CoVarEnv Coercion {- Note [The substitution invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When calling (substTy subst ty) it should be the case that the in-scope set in the substitution is a superset of both: (SIa) The free vars of the range of the substitution (SIb) The free vars of ty minus the domain of the substitution The same rules apply to other substitutions (notably CoreSubst.Subst) * Reason for (SIa). Consider substTy [a :-> Maybe b] (forall b. b->a) we must rename the forall b, to get forall b2. b2 -> Maybe b Making 'b' part of the in-scope set forces this renaming to take place. * Reason for (SIb). Consider substTy [a :-> Maybe b] (forall b. (a,b,x)) Then if we use the in-scope set {b}, satisfying (SIa), there is a danger we will rename the forall'd variable to 'x' by mistake, getting this: forall x. (Maybe b, x, x) Breaking (SIb) caused the bug from #11371. Note: if the free vars of the range of the substitution are freshly created, then the problems of (SIa) can't happen, and so it would be sound to ignore (SIa). Note [Substitutions apply only once] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use TCvSubsts to instantiate things, and we might instantiate forall a b. ty with the types [a, b], or [b, a]. So the substitution might go [a->b, b->a]. A similar situation arises in Core when we find a beta redex like (/\ a /\ b -> e) b a Then we also end up with a substitution that permutes type variables. Other variations happen to; for example [a -> (a, b)]. ******************************************************** *** So a substitution must be applied precisely once *** ******************************************************** A TCvSubst is not idempotent, but, unlike the non-idempotent substitution we use during unifications, it must not be repeatedly applied. Note [Extending the TvSubstEnv] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See #tcvsubst_invariant# for the invariants that must hold. This invariant allows a short-cut when the subst envs are empty: if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst) holds --- then (substTy subst ty) does nothing. For example, consider: (/\a. /\b:(a~Int). ...b..) Int We substitute Int for 'a'. The Unique of 'b' does not change, but nevertheless we add 'b' to the TvSubstEnv, because b's kind does change This invariant has several crucial consequences: * In substVarBndr, we need extend the TvSubstEnv - if the unique has changed - or if the kind has changed * In substTyVar, we do not need to consult the in-scope set; the TvSubstEnv is enough * In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty Note [Substituting types and coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Types and coercions are mutually recursive, and either may have variables "belonging" to the other. Thus, every time we wish to substitute in a type, we may also need to substitute in a coercion, and vice versa. However, the constructor used to create type variables is distinct from that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note that it would be possible to use the CoercionTy constructor to combine these environments, but that seems like a false economy. Note that the TvSubstEnv should *never* map a CoVar (built with the Id constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore, the range of the TvSubstEnv should *never* include a type headed with CoercionTy. -} emptyTvSubstEnv :: TvSubstEnv emptyTvSubstEnv = emptyVarEnv emptyCvSubstEnv :: CvSubstEnv emptyCvSubstEnv = emptyVarEnv composeTCvSubstEnv :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> (TvSubstEnv, CvSubstEnv) -> (TvSubstEnv, CvSubstEnv) -- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. -- It assumes that both are idempotent. -- Typically, @env1@ is the refinement to a base substitution @env2@ composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2) = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2 , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 ) -- First apply env1 to the range of env2 -- Then combine the two, making sure that env1 loses if -- both bind the same variable; that's why env1 is the -- *left* argument to plusVarEnv, because the right arg wins where subst1 = TCvSubst in_scope tenv1 cenv1 -- | Composes two substitutions, applying the second one provided first, -- like in function composition. composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2) = TCvSubst is3 tenv3 cenv3 where is3 = is1 `unionInScope` is2 (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2) emptyTCvSubst :: TCvSubst emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv mkEmptyTCvSubst :: InScopeSet -> TCvSubst mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv isEmptyTCvSubst :: TCvSubst -> Bool -- See Note [Extending the TvSubstEnv] isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst -- ^ Make a TCvSubst with specified tyvar subst and empty covar subst mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst -- ^ Make a TCvSubst with specified covar subst and empty tyvar subst mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv getTvSubstEnv :: TCvSubst -> TvSubstEnv getTvSubstEnv (TCvSubst _ env _) = env getCvSubstEnv :: TCvSubst -> CvSubstEnv getCvSubstEnv (TCvSubst _ _ env) = env getTCvInScope :: TCvSubst -> InScopeSet getTCvInScope (TCvSubst in_scope _ _) = in_scope -- | Returns the free variables of the types in the range of a substitution as -- a non-deterministic set. getTCvSubstRangeFVs :: TCvSubst -> VarSet getTCvSubstRangeFVs (TCvSubst _ tenv cenv) = unionVarSet tenvFVs cenvFVs where tenvFVs = tyCoVarsOfTypesSet tenv cenvFVs = tyCoVarsOfCosSet cenv isInScope :: Var -> TCvSubst -> Bool isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope notElemTCvSubst :: Var -> TCvSubst -> Bool notElemTCvSubst v (TCvSubst _ tenv cenv) | isTyVar v = not (v `elemVarEnv` tenv) | otherwise = not (v `elemVarEnv` cenv) setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv zapTCvSubst :: TCvSubst -> TCvSubst zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv extendTCvInScope :: TCvSubst -> Var -> TCvSubst extendTCvInScope (TCvSubst in_scope tenv cenv) var = TCvSubst (extendInScopeSet in_scope var) tenv cenv extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst extendTCvSubst subst v ty | isTyVar v = extendTvSubst subst v ty | CoercionTy co <- ty = extendCvSubst subst v co | otherwise = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst extendTCvSubstWithClone subst tcv | isTyVar tcv = extendTvSubstWithClone subst tcv | otherwise = extendCvSubstWithClone subst tcv extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst extendTvSubst (TCvSubst in_scope tenv cenv) tv ty = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty = ASSERT( isTyVar v ) extendTvSubstAndInScope subst v ty extendTvSubstBinderAndInScope subst (Anon {}) _ = subst extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst -- Adds a new tv -> tv mapping, /and/ extends the in-scope set extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv' = TCvSubst (extendInScopeSetSet in_scope new_in_scope) (extendVarEnv tenv tv (mkTyVarTy tv')) cenv where new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv' extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst extendCvSubst (TCvSubst in_scope tenv cenv) v co = TCvSubst in_scope tenv (extendVarEnv cenv v co) extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv' = TCvSubst (extendInScopeSetSet in_scope new_in_scope) tenv (extendVarEnv cenv cv (mkCoVarCo cv')) where new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv' extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst -- Also extends the in-scope set extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) (extendVarEnv tenv tv ty) cenv extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst extendTvSubstList subst tvs tys = foldl2 extendTvSubst subst tvs tys extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst extendTCvSubstList subst tvs tys = foldl2 extendTCvSubst subst tvs tys unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst -- Works when the ranges are disjoint unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) && not (cenv1 `intersectsVarEnv` cenv2) ) TCvSubst (in_scope1 `unionInScope` in_scope2) (tenv1 `plusVarEnv` tenv2) (cenv1 `plusVarEnv` cenv2) -- mkTvSubstPrs and zipTvSubst generate the in-scope set from -- the types given; but it's just a thunk so with a bit of luck -- it'll never be evaluated -- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming -- environment. No CoVars, please! zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst zipTvSubst tvs tys = mkTvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) tenv where tenv = zipTyEnv tvs tys -- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming -- environment. No TyVars, please! zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst zipCvSubst cvs cos = TCvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv cenv where cenv = zipCoEnv cvs cos zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst zipTCvSubst tcvs tys = zip_tcvsubst tcvs tys (mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes tys)) where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst zip_tcvsubst (tv:tvs) (ty:tys) subst = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) zip_tcvsubst [] [] subst = subst -- empty case zip_tcvsubst _ _ _ = pprPanic "zipTCvSubst: length mismatch" (ppr tcvs <+> ppr tys) -- | Generates the in-scope set for the 'TCvSubst' from the types in the -- incoming environment. No CoVars, please! mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst mkTvSubstPrs prs = ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs ) mkTvSubst in_scope tenv where tenv = mkVarEnv prs in_scope = mkInScopeSet $ tyCoVarsOfTypes $ map snd prs onlyTyVarsAndNoCoercionTy = and [ isTyVar tv && not (isCoercionTy ty) | (tv, ty) <- prs ] zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv zipTyEnv tyvars tys | debugIsOn , not (all isTyVar tyvars) = pprPanic "zipTyEnv" (ppr tyvars <+> ppr tys) | otherwise = ASSERT( all (not . isCoercionTy) tys ) mkVarEnv (zipEqual "zipTyEnv" tyvars tys) -- There used to be a special case for when -- ty == TyVarTy tv -- (a not-uncommon case) in which case the substitution was dropped. -- But the type-tidier changes the print-name of a type variable without -- changing the unique, and that led to a bug. Why? Pre-tidying, we had -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. -- And it happened that t was the type variable of the class. Post-tiding, -- it got turned into {Foo t2}. The ext-core printer expanded this using -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, -- and so generated a rep type mentioning t not t2. -- -- Simplest fix is to nuke the "optimisation" zipCoEnv :: HasDebugCallStack => [CoVar] -> [Coercion] -> CvSubstEnv zipCoEnv cvs cos | debugIsOn , not (all isCoVar cvs) = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos) | otherwise = mkVarEnv (zipEqual "zipCoEnv" cvs cos) instance Outputable TCvSubst where ppr (TCvSubst ins tenv cenv) = brackets $ sep[ text "TCvSubst", nest 2 (text "In scope:" <+> ppr ins), nest 2 (text "Type env:" <+> ppr tenv), nest 2 (text "Co env:" <+> ppr cenv) ] {- %************************************************************************ %* * Performing type or kind substitutions %* * %************************************************************************ Note [Sym and ForAllCo] ~~~~~~~~~~~~~~~~~~~~~~~ In OptCoercion, we try to push "sym" out to the leaves of a coercion. But, how do we push sym into a ForAllCo? It's a little ugly. Here is the typing rule: h : k1 ~# k2 (tv : k1) |- g : ty1 ~# ty2 ---------------------------- ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~# (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) Here is what we want: ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~# (ForAllTy (tv : k1) ty1) Because the kinds of the type variables to the right of the colon are the kinds coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h). Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~# (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h'])) We thus see that we want g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h'] and thus g' = sym (g[tv |-> tv |> h']). Putting it all together, we get this: sym (ForAllCo tv h g) ==> ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h]) Note [Substituting in a coercion hole] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It seems highly suspicious to be substituting in a coercion that still has coercion holes. Yet, this can happen in a situation like this: f :: forall k. k :~: Type -> () f Refl = let x :: forall (a :: k). [a] -> ... x = ... When we check x's type signature, we require that k ~ Type. We indeed know this due to the Refl pattern match, but the eager unifier can't make use of givens. So, when we're done looking at x's type, a coercion hole will remain. Then, when we're checking x's definition, we skolemise x's type (in order to, e.g., bring the scoped type variable `a` into scope). This requires performing a substitution for the fresh skolem variables. This subsitution needs to affect the kind of the coercion hole, too -- otherwise, the kind will have an out-of-scope variable in it. More problematically in practice (we won't actually notice the out-of-scope variable ever), skolems in the kind might have too high a level, triggering a failure to uphold the invariant that no free variables in a type have a higher level than the ambient level in the type checker. In the event of having free variables in the hole's kind, I'm pretty sure we'll always have an erroneous program, so we don't need to worry what will happen when the hole gets filled in. After all, a hole relating a locally-bound type variable will be unable to be solved. This is why it's OK not to look through the IORef of a coercion hole during substitution. -} -- | Type substitution, see 'zipTvSubst' substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type -- Works only if the domain of the substitution is a -- superset of the type being substituted into substTyWith tvs tys = {-#SCC "substTyWith" #-} ASSERT( tvs `equalLength` tys ) substTy (zipTvSubst tvs tys) -- | Type substitution, see 'zipTvSubst'. Disables sanity checks. -- The problems that the sanity checks in substTy catch are described in -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substTyUnchecked to -- substTy and remove this function. Please don't use in new code. substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type substTyWithUnchecked tvs tys = ASSERT( tvs `equalLength` tys ) substTyUnchecked (zipTvSubst tvs tys) -- | Substitute tyvars within a type using a known 'InScopeSet'. -- Pre-condition: the 'in_scope' set should satisfy Note [The substitution -- invariant]; specifically it should include the free vars of 'tys', -- and of 'ty' minus the domain of the subst. substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type substTyWithInScope in_scope tvs tys ty = ASSERT( tvs `equalLength` tys ) substTy (mkTvSubst in_scope tenv) ty where tenv = zipTyEnv tvs tys -- | Coercion substitution, see 'zipTvSubst' substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion substCoWith tvs tys = ASSERT( tvs `equalLength` tys ) substCo (zipTvSubst tvs tys) -- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks. -- The problems that the sanity checks in substCo catch are described in -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substCoUnchecked to -- substCo and remove this function. Please don't use in new code. substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion substCoWithUnchecked tvs tys = ASSERT( tvs `equalLength` tys ) substCoUnchecked (zipTvSubst tvs tys) -- | Substitute covars within a type substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos) -- | Type substitution, see 'zipTvSubst' substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] substTysWith tvs tys = ASSERT( tvs `equalLength` tys ) substTys (zipTvSubst tvs tys) -- | Type substitution, see 'zipTvSubst' substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type] substTysWithCoVars cvs cos = ASSERT( cvs `equalLength` cos ) substTys (zipCvSubst cvs cos) -- | Substitute within a 'Type' after adding the free variables of the type -- to the in-scope set. This is useful for the case when the free variables -- aren't already in the in-scope set or easily available. -- See also Note [The substitution invariant]. substTyAddInScope :: TCvSubst -> Type -> Type substTyAddInScope subst ty = substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty -- | When calling `substTy` it should be the case that the in-scope set in -- the substitution is a superset of the free vars of the range of the -- substitution. -- See also Note [The substitution invariant]. isValidTCvSubst :: TCvSubst -> Bool isValidTCvSubst (TCvSubst in_scope tenv cenv) = (tenvFVs `varSetInScope` in_scope) && (cenvFVs `varSetInScope` in_scope) where tenvFVs = tyCoVarsOfTypesSet tenv cenvFVs = tyCoVarsOfCosSet cenv -- | This checks if the substitution satisfies the invariant from -- Note [The substitution invariant]. checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a = ASSERT2( isValidTCvSubst subst, text "in_scope" <+> ppr in_scope $$ text "tenv" <+> ppr tenv $$ text "tenvFVs" <+> ppr (tyCoVarsOfTypesSet tenv) $$ text "cenv" <+> ppr cenv $$ text "cenvFVs" <+> ppr (tyCoVarsOfCosSet cenv) $$ text "tys" <+> ppr tys $$ text "cos" <+> ppr cos ) ASSERT2( tysCosFVsInScope, text "in_scope" <+> ppr in_scope $$ text "tenv" <+> ppr tenv $$ text "cenv" <+> ppr cenv $$ text "tys" <+> ppr tys $$ text "cos" <+> ppr cos $$ text "needInScope" <+> ppr needInScope ) a where substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv -- It's OK to use nonDetKeysUFM here, because we only use this list to -- remove some elements from a set needInScope = (tyCoVarsOfTypes tys `unionVarSet` tyCoVarsOfCos cos) `delListFromUniqSet_Directly` substDomain tysCosFVsInScope = needInScope `varSetInScope` in_scope -- | Substitute within a 'Type' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. substTy :: HasCallStack => TCvSubst -> Type -> Type substTy subst ty | isEmptyTCvSubst subst = ty | otherwise = checkValidSubst subst [ty] [] $ subst_ty subst ty -- | Substitute within a 'Type' disabling the sanity checks. -- The problems that the sanity checks in substTy catch are described in -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substTyUnchecked to -- substTy and remove this function. Please don't use in new code. substTyUnchecked :: TCvSubst -> Type -> Type substTyUnchecked subst ty | isEmptyTCvSubst subst = ty | otherwise = subst_ty subst ty -- | Substitute within several 'Type's -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. substTys :: HasCallStack => TCvSubst -> [Type] -> [Type] substTys subst tys | isEmptyTCvSubst subst = tys | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys -- | Substitute within several 'Type's disabling the sanity checks. -- The problems that the sanity checks in substTys catch are described in -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substTysUnchecked to -- substTys and remove this function. Please don't use in new code. substTysUnchecked :: TCvSubst -> [Type] -> [Type] substTysUnchecked subst tys | isEmptyTCvSubst subst = tys | otherwise = map (subst_ty subst) tys -- | Substitute within a 'ThetaType' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType substTheta = substTys -- | Substitute within a 'ThetaType' disabling the sanity checks. -- The problems that the sanity checks in substTys catch are described in -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substThetaUnchecked to -- substTheta and remove this function. Please don't use in new code. substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType substThetaUnchecked = substTysUnchecked subst_ty :: TCvSubst -> Type -> Type -- subst_ty is the main workhorse for type substitution -- -- Note that the in_scope set is poked only if we hit a forall -- so it may often never be fully computed subst_ty subst ty = go ty where go (TyVarTy tv) = substTyVar subst tv go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) -- The mkAppTy smart constructor is important -- we might be replacing (a Int), represented with App -- by [Int], represented with TyConApp go (TyConApp tc tys) = let args = map go tys in args `seqList` TyConApp tc args go ty@(FunTy { ft_arg = arg, ft_res = res }) = let !arg' = go arg !res' = go res in ty { ft_arg = arg', ft_res = res' } go (ForAllTy (Bndr tv vis) ty) = case substVarBndrUnchecked subst tv of (subst', tv') -> (ForAllTy $! ((Bndr $! tv') vis)) $! (subst_ty subst' ty) go (LitTy n) = LitTy $! n go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) go (CoercionTy co) = CoercionTy $! (subst_co subst co) substTyVar :: TCvSubst -> TyVar -> Type substTyVar (TCvSubst _ tenv _) tv = ASSERT( isTyVar tv ) case lookupVarEnv tenv tv of Just ty -> ty Nothing -> TyVarTy tv substTyVars :: TCvSubst -> [TyVar] -> [Type] substTyVars subst = map $ substTyVar subst substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type] substTyCoVars subst = map $ substTyCoVar subst substTyCoVar :: TCvSubst -> TyCoVar -> Type substTyCoVar subst tv | isTyVar tv = substTyVar subst tv | otherwise = CoercionTy $ substCoVar subst tv lookupTyVar :: TCvSubst -> TyVar -> Maybe Type -- See Note [Extending the TCvSubst] lookupTyVar (TCvSubst _ tenv _) tv = ASSERT( isTyVar tv ) lookupVarEnv tenv tv -- | Substitute within a 'Coercion' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. substCo :: HasCallStack => TCvSubst -> Coercion -> Coercion substCo subst co | isEmptyTCvSubst subst = co | otherwise = checkValidSubst subst [] [co] $ subst_co subst co -- | Substitute within a 'Coercion' disabling sanity checks. -- The problems that the sanity checks in substCo catch are described in -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substCoUnchecked to -- substCo and remove this function. Please don't use in new code. substCoUnchecked :: TCvSubst -> Coercion -> Coercion substCoUnchecked subst co | isEmptyTCvSubst subst = co | otherwise = subst_co subst co -- | Substitute within several 'Coercion's -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion] substCos subst cos | isEmptyTCvSubst subst = cos | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos subst_co :: TCvSubst -> Coercion -> Coercion subst_co subst co = go co where go_ty :: Type -> Type go_ty = subst_ty subst go_mco :: MCoercion -> MCoercion go_mco MRefl = MRefl go_mco (MCo co) = MCo (go co) go :: Coercion -> Coercion go (Refl ty) = mkNomReflCo $! (go_ty ty) go (GRefl r ty mco) = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco) go (TyConAppCo r tc args)= let args' = map go args in args' `seqList` mkTyConAppCo r tc args' go (AppCo co arg) = (mkAppCo $! go co) $! go arg go (ForAllCo tv kind_co co) = case substForAllCoBndrUnchecked subst tv kind_co of (subst', tv', kind_co') -> ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co go (FunCo r co1 co2) = (mkFunCo r $! go co1) $! go co2 go (CoVarCo cv) = substCoVar subst cv go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos go (UnivCo p r t1 t2) = (((mkUnivCo $! go_prov p) $! r) $! (go_ty t1)) $! (go_ty t2) go (SymCo co) = mkSymCo $! (go co) go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) go (NthCo r d co) = mkNthCo r d $! (go co) go (LRCo lr co) = mkLRCo lr $! (go co) go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg go (KindCo co) = mkKindCo $! (go co) go (SubCo co) = mkSubCo $! (go co) go (AxiomRuleCo c cs) = let cs1 = map go cs in cs1 `seqList` AxiomRuleCo c cs1 go (HoleCo h) = HoleCo $! go_hole h go_prov UnsafeCoerceProv = UnsafeCoerceProv go_prov (PhantomProv kco) = PhantomProv (go kco) go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) go_prov p@(PluginProv _) = p -- See Note [Substituting in a coercion hole] go_hole h@(CoercionHole { ch_co_var = cv }) = h { ch_co_var = updateVarType go_ty cv } substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion -> (TCvSubst, TyCoVar, Coercion) substForAllCoBndr subst = substForAllCoBndrUsing False (substCo subst) subst -- | Like 'substForAllCoBndr', but disables sanity checks. -- The problems that the sanity checks in substCo catch are described in -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substCoUnchecked to -- substCo and remove this function. Please don't use in new code. substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion -> (TCvSubst, TyCoVar, Coercion) substForAllCoBndrUnchecked subst = substForAllCoBndrUsing False (substCoUnchecked subst) subst -- See Note [Sym and ForAllCo] substForAllCoBndrUsing :: Bool -- apply sym to binder? -> (Coercion -> Coercion) -- transformation to kind co -> TCvSubst -> TyCoVar -> KindCoercion -> (TCvSubst, TyCoVar, KindCoercion) substForAllCoBndrUsing sym sco subst old_var | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var | otherwise = substForAllCoCoVarBndrUsing sym sco subst old_var substForAllCoTyVarBndrUsing :: Bool -- apply sym to binder? -> (Coercion -> Coercion) -- transformation to kind co -> TCvSubst -> TyVar -> KindCoercion -> (TCvSubst, TyVar, KindCoercion) substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co = ASSERT( isTyVar old_var ) ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv , new_var, new_kind_co ) where new_env | no_change && not sym = delVarEnv tenv old_var | sym = extendVarEnv tenv old_var $ TyVarTy new_var `CastTy` new_kind_co | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) no_kind_change = noFreeVarsOfCo old_kind_co no_change = no_kind_change && (new_var == old_var) new_kind_co | no_kind_change = old_kind_co | otherwise = sco old_kind_co Pair new_ki1 _ = coercionKind new_kind_co -- We could do substitution to (tyVarKind old_var). We don't do so because -- we already substituted new_kind_co, which contains the kind information -- we want. We don't want to do substitution once more. Also, in most cases, -- new_kind_co is a Refl, in which case coercionKind is really fast. new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder? -> (Coercion -> Coercion) -- transformation to kind co -> TCvSubst -> CoVar -> KindCoercion -> (TCvSubst, CoVar, KindCoercion) substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co = ASSERT( isCoVar old_var ) ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv , new_var, new_kind_co ) where new_cenv | no_change && not sym = delVarEnv cenv old_var | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var) no_kind_change = noFreeVarsOfCo old_kind_co no_change = no_kind_change && (new_var == old_var) new_kind_co | no_kind_change = old_kind_co | otherwise = sco old_kind_co Pair h1 h2 = coercionKind new_kind_co new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type new_var_type | sym = h2 | otherwise = h1 substCoVar :: TCvSubst -> CoVar -> Coercion substCoVar (TCvSubst _ _ cenv) cv = case lookupVarEnv cenv cv of Just co -> co Nothing -> CoVarCo cv substCoVars :: TCvSubst -> [CoVar] -> [Coercion] substCoVars subst cvs = map (substCoVar subst) cvs lookupCoVar :: TCvSubst -> Var -> Maybe Coercion lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) substTyVarBndr = substTyVarBndrUsing substTy substTyVarBndrs :: HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) substTyVarBndrs = mapAccumL substTyVarBndr substVarBndr :: HasCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) substVarBndr = substVarBndrUsing substTy substVarBndrs :: HasCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) substVarBndrs = mapAccumL substVarBndr substCoVarBndr :: HasCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) substCoVarBndr = substCoVarBndrUsing substTy -- | Like 'substVarBndr', but disables sanity checks. -- The problems that the sanity checks in substTy catch are described in -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substTyUnchecked to -- substTy and remove this function. Please don't use in new code. substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) substVarBndrUnchecked = substVarBndrUsing substTyUnchecked substVarBndrUsing :: (TCvSubst -> Type -> Type) -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) substVarBndrUsing subst_fn subst v | isTyVar v = substTyVarBndrUsing subst_fn subst v | otherwise = substCoVarBndrUsing subst_fn subst v -- | Substitute a tyvar in a binding position, returning an -- extended subst and a new tyvar. -- Use the supplied function to substitute in the kind substTyVarBndrUsing :: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind -> TCvSubst -> TyVar -> (TCvSubst, TyVar) substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst ) ASSERT( isTyVar old_var ) (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) where new_env | no_change = delVarEnv tenv old_var | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) _no_capture = not (new_var `elemVarSet` tyCoVarsOfTypesSet tenv) -- Assertion check that we are not capturing something in the substitution old_ki = tyVarKind old_var no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed no_change = no_kind_change && (new_var == old_var) -- no_change means that the new_var is identical in -- all respects to the old_var (same unique, same kind) -- See Note [Extending the TCvSubst] -- -- In that case we don't need to extend the substitution -- to map old to new. But instead we must zap any -- current substitution for the variable. For example: -- (\x.e) with id_subst = [x |-> e'] -- Here we must simply zap the substitution for x new_var | no_kind_change = uniqAway in_scope old_var | otherwise = uniqAway in_scope $ setTyVarKind old_var (subst_fn subst old_ki) -- The uniqAway part makes sure the new variable is not already in scope -- | Substitute a covar in a binding position, returning an -- extended subst and a new covar. -- Use the supplied function to substitute in the kind substCoVarBndrUsing :: (TCvSubst -> Type -> Type) -> TCvSubst -> CoVar -> (TCvSubst, CoVar) substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var = ASSERT( isCoVar old_var ) (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) where new_co = mkCoVarCo new_var no_kind_change = noFreeVarsOfTypes [t1, t2] no_change = new_var == old_var && no_kind_change new_cenv | no_change = delVarEnv cenv old_var | otherwise = extendVarEnv cenv old_var new_co new_var = uniqAway in_scope subst_old_var subst_old_var = mkCoVar (varName old_var) new_var_type (_, _, t1, t2, role) = coVarKindsTypesRole old_var t1' = subst_fn subst t1 t2' = subst_fn subst t2 new_var_type = mkCoercionType role t1' t2' -- It's important to do the substitution for coercions, -- because they can have free type variables cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq = ASSERT2( isTyVar tv, ppr tv ) -- I think it's only called on TyVars (TCvSubst (extendInScopeSet in_scope tv') (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') where old_ki = tyVarKind tv no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed tv1 | no_kind_change = tv | otherwise = setTyVarKind tv (substTy subst old_ki) tv' = setVarUnique tv1 uniq cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar]) cloneTyVarBndrs subst [] _usupply = (subst, []) cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) where (uniq, usupply') = takeUniqFromSupply usupply (subst' , tv ) = cloneTyVarBndr subst t uniq (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' ghc-lib-parser-8.10.2.20200808/compiler/types/TyCoTidy.hs0000644000000000000000000002165513713635745020542 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} -- | Tidying types and coercions for printing in error messages. module TyCoTidy ( -- * Tidying type related things up for printing tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, tidyOpenKind, tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes, tidyOpenTyCoVar, tidyOpenTyCoVars, tidyTyCoVarOcc, tidyTopType, tidyKind, tidyCo, tidyCos, tidyTyCoVarBinder, tidyTyCoVarBinders ) where import GhcPrelude import TyCoRep import TyCoFVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList) import Name hiding (varName) import Var import VarEnv import Util (seqList) import Data.List (mapAccumL) {- %************************************************************************ %* * \subsection{TidyType} %* * %************************************************************************ -} -- | This tidies up a type for printing in an error message, or in -- an interface file. -- -- It doesn't change the uniques at all, just the print names. tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) tidyVarBndrs tidy_env tvs = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) tidyVarBndr tidy_env@(occ_env, subst) var = case tidyOccName occ_env (getHelpfulOccName var) of (occ_env', occ') -> ((occ_env', subst'), var') where subst' = extendVarEnv subst var var' var' = setVarType (setVarName var name') type' type' = tidyType tidy_env (varType var) name' = tidyNameOcc name occ' name = varName var avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv -- Seed the occ_env with clashes among the names, see -- Note [Tidying multiple names at once] in OccName avoidNameClashes tvs (occ_env, subst) = (avoidClashesOccEnv occ_env occs, subst) where occs = map getHelpfulOccName tvs getHelpfulOccName :: TyCoVar -> OccName -- A TcTyVar with a System Name is probably a -- unification variable; when we tidy them we give them a trailing -- "0" (or 1 etc) so that they don't take precedence for the -- un-modified name. Plus, indicating a unification variable in -- this way is a helpful clue for users getHelpfulOccName tv | isSystemName name, isTcTyVar tv = mkTyVarOcc (occNameString occ ++ "0") | otherwise = occ where name = varName tv occ = getOccName name tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis -> (TidyEnv, VarBndr TyCoVar vis) tidyTyCoVarBinder tidy_env (Bndr tv vis) = (tidy_env', Bndr tv' vis) where (tidy_env', tv') = tidyVarBndr tidy_env tv tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis] -> (TidyEnv, [VarBndr TyCoVar vis]) tidyTyCoVarBinders tidy_env tvbs = mapAccumL tidyTyCoVarBinder (avoidNameClashes (binderVars tvbs) tidy_env) tvbs --------------- tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv -- ^ Add the free 'TyVar's to the env in tidy form, -- so that we can tidy the type they are free in tidyFreeTyCoVars (full_occ_env, var_env) tyvars = fst (tidyOpenTyCoVars (full_occ_env, var_env) tyvars) --------------- tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars --------------- tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) -- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name -- using the environment if one has not already been allocated. See -- also 'tidyVarBndr' tidyOpenTyCoVar env@(_, subst) tyvar = case lookupVarEnv subst tyvar of Just tyvar' -> (env, tyvar') -- Already substituted Nothing -> let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar)) in tidyVarBndr env' tyvar -- Treat it as a binder --------------- tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar tidyTyCoVarOcc env@(_, subst) tv = case lookupVarEnv subst tv of Nothing -> updateVarType (tidyType env) tv Just tv' -> tv' --------------- tidyTypes :: TidyEnv -> [Type] -> [Type] tidyTypes env tys = map (tidyType env) tys --------------- tidyType :: TidyEnv -> Type -> Type tidyType _ (LitTy n) = LitTy n tidyType env (TyVarTy tv) = TyVarTy (tidyTyCoVarOcc env tv) tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys in args `seqList` TyConApp tycon args tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) tidyType env ty@(FunTy _ arg res) = let { !arg' = tidyType env arg ; !res' = tidyType env res } in ty { ft_arg = arg', ft_res = res' } tidyType env (ty@(ForAllTy{})) = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty where (tvs, vis, body_ty) = splitForAllTys' ty (env', tvs') = tidyVarBndrs env tvs tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) -- The following two functions differ from mkForAllTys and splitForAllTys in that -- they expect/preserve the ArgFlag argument. Thes belong to types/Type.hs, but -- how should they be named? mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs where strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty splitForAllTys' :: Type -> ([TyCoVar], [ArgFlag], Type) splitForAllTys' ty = go ty [] [] where go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss) go ty tvs viss = (reverse tvs, reverse viss, ty) --------------- -- | Grabs the free type variables, tidies them -- and then uses 'tidyType' to work over the type itself tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) tidyOpenTypes env tys = (env', tidyTypes (trimmed_occ_env, var_env) tys) where (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $ tyCoVarsOfTypesWellScoped tys trimmed_occ_env = initTidyOccEnv (map getOccName tvs') -- The idea here was that we restrict the new TidyEnv to the -- _free_ vars of the types, so that we don't gratuitously rename -- the _bound_ variables of the types. --------------- tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in (env', ty') --------------- -- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) tidyTopType :: Type -> Type tidyTopType ty = tidyType emptyTidyEnv ty --------------- tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind) tidyOpenKind = tidyOpenType tidyKind :: TidyEnv -> Kind -> Kind tidyKind = tidyType ---------------- tidyCo :: TidyEnv -> Coercion -> Coercion tidyCo env@(_, subst) co = go co where go_mco MRefl = MRefl go_mco (MCo co) = MCo (go co) go (Refl ty) = Refl (tidyType env ty) go (GRefl r ty mco) = GRefl r (tidyType env ty) $! go_mco mco go (TyConAppCo r tc cos) = let args = map go cos in args `seqList` TyConAppCo r tc args go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 go (ForAllCo tv h co) = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co) where (envp, tvp) = tidyVarBndr env tv -- the case above duplicates a bit of work in tidying h and the kind -- of tv. But the alternative is to use coercionKind, which seems worse. go (FunCo r co1 co2) = (FunCo r $! go co1) $! go co2 go (CoVarCo cv) = case lookupVarEnv subst cv of Nothing -> CoVarCo cv Just cv' -> CoVarCo cv' go (HoleCo h) = HoleCo h go (AxiomInstCo con ind cos) = let args = map go cos in args `seqList` AxiomInstCo con ind args go (UnivCo p r t1 t2) = (((UnivCo $! (go_prov p)) $! r) $! tidyType env t1) $! tidyType env t2 go (SymCo co) = SymCo $! go co go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 go (NthCo r d co) = NthCo r d $! go co go (LRCo lr co) = LRCo lr $! go co go (InstCo co ty) = (InstCo $! go co) $! go ty go (KindCo co) = KindCo $! go co go (SubCo co) = SubCo $! go co go (AxiomRuleCo ax cos) = let cos1 = tidyCos env cos in cos1 `seqList` AxiomRuleCo ax cos1 go_prov UnsafeCoerceProv = UnsafeCoerceProv go_prov (PhantomProv co) = PhantomProv (go co) go_prov (ProofIrrelProv co) = ProofIrrelProv (go co) go_prov p@(PluginProv _) = p tidyCos :: TidyEnv -> [Coercion] -> [Coercion] tidyCos env = map (tidyCo env) ghc-lib-parser-8.10.2.20200808/compiler/types/TyCon.hs0000644000000000000000000033160513713635745020065 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 The @TyCon@ datatype -} {-# LANGUAGE CPP, FlexibleInstances #-} module TyCon( -- * Main TyCon data types TyCon, AlgTyConRhs(..), visibleDataCons, AlgTyConFlav(..), isNoParent, FamTyConFlav(..), Role(..), Injectivity(..), RuntimeRepInfo(..), TyConFlavour(..), -- * TyConBinder TyConBinder, TyConBndrVis(..), TyConTyCoBinder, mkNamedTyConBinder, mkNamedTyConBinders, mkRequiredTyConBinder, mkAnonTyConBinder, mkAnonTyConBinders, tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder, isVisibleTyConBinder, isInvisibleTyConBinder, -- ** Field labels tyConFieldLabels, lookupTyConFieldLabel, -- ** Constructing TyCons mkAlgTyCon, mkClassTyCon, mkFunTyCon, mkPrimTyCon, mkKindTyCon, mkLiftedPrimTyCon, mkTupleTyCon, mkSumTyCon, mkDataTyConRhs, mkSynonymTyCon, mkFamilyTyCon, mkPromotedDataCon, mkTcTyCon, noTcTyConScopedTyVars, -- ** Predicates on TyCons isAlgTyCon, isVanillaAlgTyCon, isClassTyCon, isFamInstTyCon, isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, isUnboxedSumTyCon, isPromotedTupleTyCon, isTypeSynonymTyCon, mustBeSaturated, isPromotedDataCon, isPromotedDataCon_maybe, isKindTyCon, isLiftedTypeKindTyConName, isTauTyCon, isFamFreeTyCon, isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, isDataSumTyCon_maybe, isEnumerationTyCon, isNewTyCon, isAbstractTyCon, isFamilyTyCon, isOpenFamilyTyCon, isTypeFamilyTyCon, isDataFamilyTyCon, isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, tyConInjectivityInfo, isBuiltInSynFamTyCon_maybe, isUnliftedTyCon, isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe, isImplicitTyCon, isTyConWithSrcDataCons, isTcTyCon, setTcTyConKind, isTcLevPoly, -- ** Extracting information out of TyCons tyConName, tyConSkolem, tyConKind, tyConUnique, tyConTyVars, tyConVisibleTyVars, tyConCType, tyConCType_maybe, tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe, tyConSingleDataCon, tyConSingleAlgDataCon_maybe, tyConFamilySize, tyConStupidTheta, tyConArity, tyConRoles, tyConFlavour, tyConTuple_maybe, tyConClass_maybe, tyConATs, tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, tyConFamilyResVar_maybe, synTyConDefn_maybe, synTyConRhs_maybe, famTyConFlav_maybe, famTcResVar, algTyConRhs, newTyConRhs, newTyConEtadArity, newTyConEtadRhs, unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, newTyConDataCon_maybe, algTcFields, tyConRuntimeRepInfo, tyConBinders, tyConResKind, tyConTyVarBinders, tcTyConScopedTyVars, tcTyConIsPoly, mkTyConTagMap, -- ** Manipulating TyCons expandSynTyCon_maybe, newTyConCo, newTyConCo_maybe, pprPromotionQuote, mkTyConKind, -- ** Predicated on TyConFlavours tcFlavourIsOpen, -- * Runtime type representation TyConRepName, tyConRepName_maybe, mkPrelTyConRepName, tyConRepModOcc, -- * Primitive representations of Types PrimRep(..), PrimElemRep(..), isVoidRep, isGcPtrRep, primRepSizeB, primElemRepSizeB, primRepIsFloat, primRepsCompatible, primRepCompatible, -- * Recursion breaking RecTcChecker, initRecTc, defaultRecTcMaxBound, setRecTcMaxBound, checkRecTc ) where #include "GhclibHsVersions.h" import GhcPrelude import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, mkForAllTy, mkFunTy ) import {-# SOURCE #-} TyCoPpr ( pprType ) import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind , vecCountTyCon, vecElemTyCon, liftedTypeKind ) import {-# SOURCE #-} DataCon ( DataCon, dataConExTyCoVars, dataConFieldLabels , dataConTyCon, dataConFullSig , isUnboxedSumCon ) import Binary import Var import VarSet import Class import BasicTypes import DynFlags import ForeignCall import Name import NameEnv import CoAxiom import PrelNames import Maybes import Outputable import FastStringEnv import FieldLabel import Constants import Util import Unique( tyConRepNameUnique, dataConTyRepNameUnique ) import UniqSet import Module import qualified Data.Data as Data {- ----------------------------------------------- Notes about type families ----------------------------------------------- Note [Type synonym families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Type synonym families, also known as "type functions", map directly onto the type functions in FC: type family F a :: * type instance F Int = Bool ..etc... * Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon * From the user's point of view (F Int) and Bool are simply equivalent types. * A Haskell 98 type synonym is a degenerate form of a type synonym family. * Type functions can't appear in the LHS of a type function: type instance F (F Int) = ... -- BAD! * Translation of type family decl: type family F a :: * translates to a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon type family G a :: * where G Int = Bool G Bool = Char G a = () translates to a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the appropriate CoAxiom representing the equations We also support injective type families -- see Note [Injective type families] Note [Data type families] ~~~~~~~~~~~~~~~~~~~~~~~~~ See also Note [Wrappers for data instance tycons] in MkId.hs * Data type families are declared thus data family T a :: * data instance T Int = T1 | T2 Bool Here T is the "family TyCon". * Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon * The user does not see any "equivalent types" as he did with type synonym families. He just sees constructors with types T1 :: T Int T2 :: Bool -> T Int * Here's the FC version of the above declarations: data T a data R:TInt = T1 | T2 Bool axiom ax_ti : T Int ~R R:TInt Note that this is a *representational* coercion The R:TInt is the "representation TyCons". It has an AlgTyConFlav of DataFamInstTyCon T [Int] ax_ti * The axiom ax_ti may be eta-reduced; see Note [Eta reduction for data families] in FamInstEnv * Data family instances may have a different arity than the data family. See Note [Arity of data families] in FamInstEnv * The data constructor T2 has a wrapper (which is what the source-level "T2" invokes): $WT2 :: Bool -> T Int $WT2 b = T2 b `cast` sym ax_ti * A data instance can declare a fully-fledged GADT: data instance T (a,b) where X1 :: T (Int,Bool) X2 :: a -> b -> T (a,b) Here's the FC version of the above declaration: data R:TPair a b where X1 :: R:TPair Int Bool X2 :: a -> b -> R:TPair a b axiom ax_pr :: T (a,b) ~R R:TPair a b $WX1 :: forall a b. a -> b -> T (a,b) $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) The R:TPair are the "representation TyCons". We have a bit of work to do, to unpick the result types of the data instance declaration for T (a,b), to get the result type in the representation; e.g. T (a,b) --> R:TPair a b The representation TyCon R:TList, has an AlgTyConFlav of DataFamInstTyCon T [(a,b)] ax_pr * Notice that T is NOT translated to a FC type function; it just becomes a "data type" with no constructors, which can be coerced into R:TInt, R:TPair by the axioms. These axioms axioms come into play when (and *only* when) you - use a data constructor - do pattern matching Rather like newtype, in fact As a result - T behaves just like a data type so far as decomposition is concerned - (T Int) is not implicitly converted to R:TInt during type inference. Indeed the latter type is unknown to the programmer. - There *is* an instance for (T Int) in the type-family instance environment, but it is only used for overlap checking - It's fine to have T in the LHS of a type function: type instance F (T a) = [a] It was this last point that confused me! The big thing is that you should not think of a data family T as a *type function* at all, not even an injective one! We can't allow even injective type functions on the LHS of a type function: type family injective G a :: * type instance F (G Int) = Bool is no good, even if G is injective, because consider type instance G Int = Bool type instance F Bool = Char So a data type family is not an injective type function. It's just a data type with some axioms that connect it to other data types. * The tyConTyVars of the representation tycon are the tyvars that the user wrote in the patterns. This is important in TcDeriv, where we bring these tyvars into scope before type-checking the deriving clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl. Note [Associated families and their parent class] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *Associated* families are just like *non-associated* families, except that they have a famTcParent field of (Just cls_tc), which identifies the parent class. However there is an important sharing relationship between * the tyConTyVars of the parent Class * the tyConTyVars of the associated TyCon class C a b where data T p a type F a q b Here the 'a' and 'b' are shared with the 'Class'; that is, they have the same Unique. This is important. In an instance declaration we expect * all the shared variables to be instantiated the same way * the non-shared variables of the associated type should not be instantiated at all instance C [x] (Tree y) where data T p [x] = T1 x | T2 p type F [x] q (Tree y) = (x,y,q) Note [TyCon Role signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Every tycon has a role signature, assigning a role to each of the tyConTyVars (or of equal length to the tyConArity, if there are no tyConTyVars). An example demonstrates these best: say we have a tycon T, with parameters a at nominal, b at representational, and c at phantom. Then, to prove representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have nominal equality between a1 and a2, representational equality between b1 and b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This might happen, say, with the following declaration: data T a b c where MkT :: b -> T Int b c Data and class tycons have their roles inferred (see inferRoles in TcTyDecls), as do vanilla synonym tycons. Family tycons have all parameters at role N, though it is conceivable that we could relax this restriction. (->)'s and tuples' parameters are at role R. Each primitive tycon declares its roles; it's worth noting that (~#)'s parameters are at role N. Promoted data constructors' type arguments are at role R. All kind arguments are at role N. Note [Unboxed tuple RuntimeRep vars] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The contents of an unboxed tuple may have any representation. Accordingly, the kind of the unboxed tuple constructor is runtime-representation polymorphic. Type constructor (2 kind arguments) (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). TYPE q -> TYPE r -> TYPE (TupleRep [q, r]) Data constructor (4 type arguments) (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep) (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #) These extra tyvars (q and r) cause some delicate processing around tuples, where we need to manually insert RuntimeRep arguments. The same situation happens with unboxed sums: each alternative has its own RuntimeRep. For boxed tuples, there is no levity polymorphism, and therefore we add RuntimeReps only for the unboxed version. Type constructor (no kind arguments) (,) :: Type -> Type -> Type Data constructor (2 type arguments) (,) :: forall a b. a -> b -> (a, b) Note [Injective type families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We allow injectivity annotations for type families (both open and closed): type family F (a :: k) (b :: k) = r | r -> a type family G a b = res | res -> a b where ... Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`. `famTcInj` maybe stores a list of Bools, where each entry corresponds to a single element of `tyConTyVars` (both lists should have identical length). If no injectivity annotation was provided `famTcInj` is Nothing. From this follows an invariant that if `famTcInj` is a Just then at least one element in the list must be True. See also: * [Injectivity annotation] in GHC.Hs.Decls * [Renaming injectivity annotation] in RnSource * [Verifying injectivity annotation] in FamInstEnv * [Type inference for type families with injectivity] in TcInteract ************************************************************************ * * TyConBinder, TyConTyCoBinder * * ************************************************************************ -} type TyConBinder = VarBndr TyVar TyConBndrVis -- In the whole definition of @data TyCon@, only @PromotedDataCon@ will really -- contain CoVar. type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis data TyConBndrVis = NamedTCB ArgFlag | AnonTCB AnonArgFlag instance Outputable TyConBndrVis where ppr (NamedTCB flag) = text "NamedTCB" <> ppr flag ppr (AnonTCB af) = text "AnonTCB" <> ppr af mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder mkAnonTyConBinder af tv = ASSERT( isTyVar tv) Bndr tv (AnonTCB af) mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder] mkAnonTyConBinders af tvs = map (mkAnonTyConBinder af) tvs mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder -- The odd argument order supports currying mkNamedTyConBinder vis tv = ASSERT( isTyVar tv ) Bndr tv (NamedTCB vis) mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder] -- The odd argument order supports currying mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs -- | Make a Required TyConBinder. It chooses between NamedTCB and -- AnonTCB based on whether the tv is mentioned in the dependent set mkRequiredTyConBinder :: TyCoVarSet -- these are used dependently -> TyVar -> TyConBinder mkRequiredTyConBinder dep_set tv | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv | otherwise = mkAnonTyConBinder VisArg tv tyConBinderArgFlag :: TyConBinder -> ArgFlag tyConBinderArgFlag (Bndr _ vis) = tyConBndrVisArgFlag vis tyConBndrVisArgFlag :: TyConBndrVis -> ArgFlag tyConBndrVisArgFlag (NamedTCB vis) = vis tyConBndrVisArgFlag (AnonTCB VisArg) = Required tyConBndrVisArgFlag (AnonTCB InvisArg) = Inferred -- See Note [AnonTCB InvisArg] isNamedTyConBinder :: TyConBinder -> Bool -- Identifies kind variables -- E.g. data T k (a:k) = blah -- Here 'k' is a NamedTCB, a variable used in the kind of other binders isNamedTyConBinder (Bndr _ (NamedTCB {})) = True isNamedTyConBinder _ = False isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool -- Works for IfaceTyConBinder too isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis isVisibleTcbVis :: TyConBndrVis -> Bool isVisibleTcbVis (NamedTCB vis) = isVisibleArgFlag vis isVisibleTcbVis (AnonTCB VisArg) = True isVisibleTcbVis (AnonTCB InvisArg) = False isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool -- Works for IfaceTyConBinder too isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) -- Build the 'tyConKind' from the binders and the result kind. -- Keep in sync with 'mkTyConKind' in iface/IfaceType. mkTyConKind :: [TyConBinder] -> Kind -> Kind mkTyConKind bndrs res_kind = foldr mk res_kind bndrs where mk :: TyConBinder -> Kind -> Kind mk (Bndr tv (AnonTCB af)) k = mkFunTy af (varType tv) k mk (Bndr tv (NamedTCB vis)) k = mkForAllTy tv vis k tyConTyVarBinders :: [TyConBinder] -- From the TyCon -> [TyVarBinder] -- Suitable for the foralls of a term function -- See Note [Building TyVarBinders from TyConBinders] tyConTyVarBinders tc_bndrs = map mk_binder tc_bndrs where mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv where vis = case tc_vis of AnonTCB VisArg -> Specified AnonTCB InvisArg -> Inferred -- See Note [AnonTCB InvisArg] NamedTCB Required -> Specified NamedTCB vis -> vis -- Returns only tyvars, as covars are always inferred tyConVisibleTyVars :: TyCon -> [TyVar] tyConVisibleTyVars tc = [ tv | Bndr tv vis <- tyConBinders tc , isVisibleTcbVis vis ] {- Note [AnonTCB InvisArg] ~~~~~~~~~~~~~~~~~~~~~~~~~~ It's pretty rare to have an (AnonTCB InvisArg) binder. The only way it can occur is through equality constraints in kinds. These can arise in one of two ways: * In a PromotedDataCon whose kind has an equality constraint: 'MkT :: forall a b. (a~b) => blah See Note [Constraints in kinds] in TyCoRep, and Note [Promoted data constructors] in this module. * In a data type whose kind has an equality constraint, as in the following example from #12102: data T :: forall a. (IsTypeLit a ~ 'True) => a -> Type When mapping an (AnonTCB InvisArg) to an ArgFlag, in tyConBndrVisArgFlag, we use "Inferred" to mean "the user cannot specify this arguments, even with visible type/kind application; instead the type checker must fill it in. We map (AnonTCB VisArg) to Required, of course: the user must provide it. It would be utterly wrong to do this for constraint arguments, which is why AnonTCB must have the AnonArgFlag in the first place. Note [Building TyVarBinders from TyConBinders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We sometimes need to build the quantified type of a value from the TyConBinders of a type or class. For that we need not TyConBinders but TyVarBinders (used in forall-type) E.g: * From data T a = MkT (Maybe a) we are going to make a data constructor with type MkT :: forall a. Maybe a -> T a See the TyCoVarBinders passed to buildDataCon * From class C a where { op :: a -> Maybe a } we are going to make a default method $dmop :: forall a. C a => a -> Maybe a See the TyCoVarBinders passed to mkSigmaTy in mkDefaultMethodType Both of these are user-callable. (NB: default methods are not callable directly by the user but rather via the code generated by 'deriving', which uses visible type application; see mkDefMethBind.) Since they are user-callable we must get their type-argument visibility information right; and that info is in the TyConBinders. Here is an example: data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> * The TyCon has tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ] The TyConBinders for App line up with App's kind, given above. But the DataCon MkApp has the type MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b That is, its TyCoVarBinders should be dataConUnivTyVarBinders = [ Bndr (k:*) Inferred , Bndr (a:k->*) Specified , Bndr (b:k) Specified ] So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: - variable names from the TyConBinders - but changing Anon/Required to Specified The last part about Required->Specified comes from this: data T k (a:k) b = MkT (a b) Here k is Required in T's kind, but we don't have Required binders in the TyCoBinders for a term (see Note [No Required TyCoBinder in terms] in TyCoRep), so we change it to Specified when making MkT's TyCoBinders -} {- Note [The binders/kind/arity fields of a TyCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ All TyCons have this group of fields tyConBinders :: [TyConBinder/TyConTyCoBinder] tyConResKind :: Kind tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders -- NB: Currently (Aug 2018), TyCons that own this -- field really only contain TyVars. So it is -- [TyVar] instead of [TyCoVar]. tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind tyConArity :: Arity -- Cached = length tyConBinders They fit together like so: * tyConBinders gives the telescope of type/coercion variables on the LHS of the type declaration. For example: type App a (b :: k) = a b tyConBinders = [ Bndr (k::*) (NamedTCB Inferred) , Bndr (a:k->*) AnonTCB , Bndr (b:k) AnonTCB ] Note that that are three binders here, including the kind variable k. * See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep for what the visibility flag means. * Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), and that TyVar may scope over some other part of the TyCon's definition. Eg type T a = a -> a we have tyConBinders = [ Bndr (a:*) AnonTCB ] synTcRhs = a -> a So the 'a' scopes over the synTcRhs * From the tyConBinders and tyConResKind we can get the tyConKind E.g for our App example: App :: forall k. (k->*) -> k -> * We get a 'forall' in the kind for each NamedTCB, and an arrow for each AnonTCB tyConKind is the full kind of the TyCon, not just the result kind * For type families, tyConArity is the arguments this TyCon must be applied to, to be considered saturated. Here we mean "applied to in the actual Type", not surface syntax; i.e. including implicit kind variables. So it's just (length tyConBinders) * For an algebraic data type, or data instance, the tyConResKind is always (TYPE r); that is, the tyConBinders are enough to saturate the type constructor. I'm not quite sure why we have this invariant, but it's enforced by etaExpandAlgTyCon -} instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where ppr (Bndr v bi) = ppr_bi bi <+> parens (pprBndr LetBind v) where ppr_bi (AnonTCB VisArg) = text "anon-vis" ppr_bi (AnonTCB InvisArg) = text "anon-invis" ppr_bi (NamedTCB Required) = text "req" ppr_bi (NamedTCB Specified) = text "spec" ppr_bi (NamedTCB Inferred) = text "inf" instance Binary TyConBndrVis where put_ bh (AnonTCB af) = do { putByte bh 0; put_ bh af } put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis } get bh = do { h <- getByte bh ; case h of 0 -> do { af <- get bh; return (AnonTCB af) } _ -> do { vis <- get bh; return (NamedTCB vis) } } {- ********************************************************************* * * The TyCon type * * ************************************************************************ -} -- | TyCons represent type constructors. Type constructors are introduced by -- things such as: -- -- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of -- kind @*@ -- -- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor -- -- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor -- of kind @* -> *@ -- -- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor -- of kind @*@ -- -- This data type also encodes a number of primitive, built in type constructors -- such as those for function and tuple types. -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.hs data TyCon = -- | The function type constructor, @(->)@ FunTyCon { tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: -- identical to Unique of Name stored in -- tyConName field. tyConName :: Name, -- ^ Name of the constructor -- See Note [The binders/kind/arity fields of a TyCon] tyConBinders :: [TyConBinder], -- ^ Full binders tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity tcRepName :: TyConRepName } -- | Algebraic data types, from -- - @data@ declarations -- - @newtype@ declarations -- - data instance declarations -- - type instance declarations -- - the TyCon generated by a class declaration -- - boxed tuples -- - unboxed tuples -- - constraint tuples -- All these constructors are lifted and boxed except unboxed tuples -- which should have an 'UnboxedAlgTyCon' parent. -- Data/newtype/type /families/ are handled by 'FamilyTyCon'. -- See 'AlgTyConRhs' for more information. | AlgTyCon { tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: -- identical to Unique of Name stored in -- tyConName field. tyConName :: Name, -- ^ Name of the constructor -- See Note [The binders/kind/arity fields of a TyCon] tyConBinders :: [TyConBinder], -- ^ Full binders tyConTyVars :: [TyVar], -- ^ TyVar binders tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity -- The tyConTyVars scope over: -- -- 1. The 'algTcStupidTheta' -- 2. The cached types in algTyConRhs.NewTyCon -- 3. The family instance types if present -- -- Note that it does /not/ scope over the data -- constructors. tcRoles :: [Role], -- ^ The role for each type variable -- This list has length = tyConArity -- See also Note [TyCon Role signatures] tyConCType :: Maybe CType,-- ^ The C type that should be used -- for this type when using the FFI -- and CAPI algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT -- syntax? If so, that doesn't mean it's a -- true GADT; only that the "where" form -- was used. This field is used only to -- guide pretty-printing algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data -- type (always empty for GADTs). A -- \"stupid theta\" is the context to -- the left of an algebraic type -- declaration, e.g. @Eq a@ in the -- declaration @data Eq a => T a ...@. algTcRhs :: AlgTyConRhs, -- ^ Contains information about the -- data constructors of the algebraic type algTcFields :: FieldLabelEnv, -- ^ Maps a label to information -- about the field algTcParent :: AlgTyConFlav -- ^ Gives the class or family declaration -- 'TyCon' for derived 'TyCon's representing -- class or family instances, respectively. } -- | Represents type synonyms | SynonymTyCon { tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: -- identical to Unique of Name stored in -- tyConName field. tyConName :: Name, -- ^ Name of the constructor -- See Note [The binders/kind/arity fields of a TyCon] tyConBinders :: [TyConBinder], -- ^ Full binders tyConTyVars :: [TyVar], -- ^ TyVar binders tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity -- tyConTyVars scope over: synTcRhs tcRoles :: [Role], -- ^ The role for each type variable -- This list has length = tyConArity -- See also Note [TyCon Role signatures] synTcRhs :: Type, -- ^ Contains information about the expansion -- of the synonym synIsTau :: Bool, -- True <=> the RHS of this synonym does not -- have any foralls, after expanding any -- nested synonyms synIsFamFree :: Bool -- True <=> the RHS of this synonym does not mention -- any type synonym families (data families -- are fine), again after expanding any -- nested synonyms } -- | Represents families (both type and data) -- Argument roles are all Nominal | FamilyTyCon { tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: -- identical to Unique of Name stored in -- tyConName field. tyConName :: Name, -- ^ Name of the constructor -- See Note [The binders/kind/arity fields of a TyCon] tyConBinders :: [TyConBinder], -- ^ Full binders tyConTyVars :: [TyVar], -- ^ TyVar binders tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity -- tyConTyVars connect an associated family TyCon -- with its parent class; see TcValidity.checkConsistentFamInst famTcResVar :: Maybe Name, -- ^ Name of result type variable, used -- for pretty-printing with --show-iface -- and for reifying TyCon in Template -- Haskell famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, -- abstract, built-in. See comments for -- FamTyConFlav famTcParent :: Maybe TyCon, -- ^ For *associated* type/data families -- The class tycon in which the family is declared -- See Note [Associated families and their parent class] famTcInj :: Injectivity -- ^ is this a type family injective in -- its type variables? Nothing if no -- injectivity annotation was given } -- | Primitive types; cannot be defined in Haskell. This includes -- the usual suspects (such as @Int#@) as well as foreign-imported -- types and kinds (@*@, @#@, and @?@) | PrimTyCon { tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: -- identical to Unique of Name stored in -- tyConName field. tyConName :: Name, -- ^ Name of the constructor -- See Note [The binders/kind/arity fields of a TyCon] tyConBinders :: [TyConBinder], -- ^ Full binders tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity tcRoles :: [Role], -- ^ The role for each type variable -- This list has length = tyConArity -- See also Note [TyCon Role signatures] isUnlifted :: Bool, -- ^ Most primitive tycons are unlifted (may -- not contain bottom) but other are lifted, -- e.g. @RealWorld@ -- Only relevant if tyConKind = * primRepName :: Maybe TyConRepName -- Only relevant for kind TyCons -- i.e, *, #, ? } -- | Represents promoted data constructor. | PromotedDataCon { -- See Note [Promoted data constructors] tyConUnique :: Unique, -- ^ Same Unique as the data constructor tyConName :: Name, -- ^ Same Name as the data constructor -- See Note [The binders/kind/arity fields of a TyCon] tyConBinders :: [TyConTyCoBinder], -- ^ Full binders tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars dataCon :: DataCon, -- ^ Corresponding data constructor tcRepName :: TyConRepName, promDcRepInfo :: RuntimeRepInfo -- ^ See comments with 'RuntimeRepInfo' } -- | These exist only during type-checking. See Note [How TcTyCons work] -- in TcTyClsDecls | TcTyCon { tyConUnique :: Unique, tyConName :: Name, -- See Note [The binders/kind/arity fields of a TyCon] tyConBinders :: [TyConBinder], -- ^ Full binders tyConTyVars :: [TyVar], -- ^ TyVar binders tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity -- NB: the TyConArity of a TcTyCon must match -- the number of Required (positional, user-specified) -- arguments to the type constructor; see the use -- of tyConArity in generaliseTcTyCon tcTyConScopedTyVars :: [(Name,TyVar)], -- ^ Scoped tyvars over the tycon's body -- See Note [Scoped tyvars in a TcTyCon] tcTyConIsPoly :: Bool, -- ^ Is this TcTyCon already generalized? tcTyConFlavour :: TyConFlavour -- ^ What sort of 'TyCon' this represents. } {- Note [Scoped tyvars in a TcTyCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The tcTyConScopedTyVars field records the lexicial-binding connection between the original, user-specified Name (i.e. thing in scope) and the TcTyVar that the Name is bound to. Order *does* matter; the tcTyConScopedTyvars list consists of specified_tvs ++ required_tvs where * specified ones first * required_tvs the same as tyConTyVars * tyConArity = length required_tvs See also Note [How TcTyCons work] in TcTyClsDecls -} -- | Represents right-hand-sides of 'TyCon's for algebraic types data AlgTyConRhs -- | Says that we know nothing about this data type, except that -- it's represented by a pointer. Used when we export a data type -- abstractly into an .hi file. = AbstractTyCon -- | Information about those 'TyCon's derived from a @data@ -- declaration. This includes data types with no constructors at -- all. | DataTyCon { data_cons :: [DataCon], -- ^ The data type constructors; can be empty if the -- user declares the type to have no constructors -- -- INVARIANT: Kept in order of increasing 'DataCon' -- tag (see the tag assignment in mkTyConTagMap) data_cons_size :: Int, -- ^ Cached value: length data_cons is_enum :: Bool -- ^ Cached value: is this an enumeration type? -- See Note [Enumeration types] } | TupleTyCon { -- A boxed, unboxed, or constraint tuple data_con :: DataCon, -- NB: it can be an *unboxed* tuple tup_sort :: TupleSort -- ^ Is this a boxed, unboxed or constraint -- tuple? } -- | An unboxed sum type. | SumTyCon { data_cons :: [DataCon], data_cons_size :: Int -- ^ Cached value: length data_cons } -- | Information about those 'TyCon's derived from a @newtype@ declaration | NewTyCon { data_con :: DataCon, -- ^ The unique constructor for the @newtype@. -- It has no existentials nt_rhs :: Type, -- ^ Cached value: the argument type of the -- constructor, which is just the representation -- type of the 'TyCon' (remember that @newtype@s -- do not exist at runtime so need a different -- representation type). -- -- The free 'TyVar's of this type are the -- 'tyConTyVars' from the corresponding 'TyCon' nt_etad_rhs :: ([TyVar], Type), -- ^ Same as the 'nt_rhs', but this time eta-reduced. -- Hence the list of 'TyVar's in this field may be -- shorter than the declared arity of the 'TyCon'. -- See Note [Newtype eta] nt_co :: CoAxiom Unbranched, -- The axiom coercion that creates the @newtype@ -- from the representation 'Type'. -- See Note [Newtype coercions] -- Invariant: arity = #tvs in nt_etad_rhs; -- See Note [Newtype eta] -- Watch out! If any newtypes become transparent -- again check #1072. nt_lev_poly :: Bool -- 'True' if the newtype can be levity polymorphic when -- fully applied to its arguments, 'False' otherwise. -- This can only ever be 'True' with UnliftedNewtypes. -- -- Invariant: nt_lev_poly nt = isTypeLevPoly (nt_rhs nt) -- -- This is cached to make it cheaper to check if a -- variable binding is levity polymorphic, as used by -- isTcLevPoly. } mkSumTyConRhs :: [DataCon] -> AlgTyConRhs mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) mkDataTyConRhs :: [DataCon] -> AlgTyConRhs mkDataTyConRhs cons = DataTyCon { data_cons = cons, data_cons_size = length cons, is_enum = not (null cons) && all is_enum_con cons -- See Note [Enumeration types] in TyCon } where is_enum_con con | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res) <- dataConFullSig con = null ex_tvs && null eq_spec && null theta && null arg_tys -- | Some promoted datacons signify extra info relevant to GHC. For example, -- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep' -- constructor of 'PrimRep'. This data structure allows us to store this -- information right in the 'TyCon'. The other approach would be to look -- up things like @RuntimeRep@'s @PrimRep@ by known-key every time. -- See also Note [Getting from RuntimeRep to PrimRep] in RepType data RuntimeRepInfo = NoRRI -- ^ an ordinary promoted data con | RuntimeRep ([Type] -> [PrimRep]) -- ^ A constructor of @RuntimeRep@. The argument to the function should -- be the list of arguments to the promoted datacon. | VecCount Int -- ^ A constructor of @VecCount@ | VecElem PrimElemRep -- ^ A constructor of @VecElem@ -- | Extract those 'DataCon's that we are able to learn about. Note -- that visibility in this sense does not correspond to visibility in -- the context of any particular user program! visibleDataCons :: AlgTyConRhs -> [DataCon] visibleDataCons (AbstractTyCon {}) = [] visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (NewTyCon{ data_con = c }) = [c] visibleDataCons (TupleTyCon{ data_con = c }) = [c] visibleDataCons (SumTyCon{ data_cons = cs }) = cs -- ^ Both type classes as well as family instances imply implicit -- type constructors. These implicit type constructors refer to their parent -- structure (ie, the class or family from which they derive) using a type of -- the following form. data AlgTyConFlav = -- | An ordinary type constructor has no parent. VanillaAlgTyCon TyConRepName -- | An unboxed type constructor. The TyConRepName is a Maybe since we -- currently don't allow unboxed sums to be Typeable since there are too -- many of them. See #13276. | UnboxedAlgTyCon (Maybe TyConRepName) -- | Type constructors representing a class dictionary. -- See Note [ATyCon for classes] in TyCoRep | ClassTyCon Class -- INVARIANT: the classTyCon of this Class is the -- current tycon TyConRepName -- | Type constructors representing an *instance* of a *data* family. -- Parameters: -- -- 1) The type family in question -- -- 2) Instance types; free variables are the 'tyConTyVars' -- of the current 'TyCon' (not the family one). INVARIANT: -- the number of types matches the arity of the family 'TyCon' -- -- 3) A 'CoTyCon' identifying the representation -- type with the type instance family | DataFamInstTyCon -- See Note [Data type families] (CoAxiom Unbranched) -- The coercion axiom. -- A *Representational* coercion, -- of kind T ty1 ty2 ~R R:T a b c -- where T is the family TyCon, -- and R:T is the representation TyCon (ie this one) -- and a,b,c are the tyConTyVars of this TyCon -- -- BUT may be eta-reduced; see FamInstEnv -- Note [Eta reduction for data families] -- Cached fields of the CoAxiom, but adjusted to -- use the tyConTyVars of this TyCon TyCon -- The family TyCon [Type] -- Argument types (mentions the tyConTyVars of this TyCon) -- No shorter in length than the tyConTyVars of the family TyCon -- How could it be longer? See [Arity of data families] in FamInstEnv -- E.g. data instance T [a] = ... -- gives a representation tycon: -- data R:TList a = ... -- axiom co a :: T [a] ~ R:TList a -- with R:TList's algTcParent = DataFamInstTyCon T [a] co instance Outputable AlgTyConFlav where ppr (VanillaAlgTyCon {}) = text "Vanilla ADT" ppr (UnboxedAlgTyCon {}) = text "Unboxed ADT" ppr (ClassTyCon cls _) = text "Class parent" <+> ppr cls ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)" <+> ppr tc <+> sep (map pprType tys) -- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class -- name, if any okParent :: Name -> AlgTyConFlav -> Bool okParent _ (VanillaAlgTyCon {}) = True okParent _ (UnboxedAlgTyCon {}) = True okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls) okParent _ (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc isNoParent :: AlgTyConFlav -> Bool isNoParent (VanillaAlgTyCon {}) = True isNoParent _ = False -------------------- data Injectivity = NotInjective | Injective [Bool] -- 1-1 with tyConTyVars (incl kind vars) deriving( Eq ) -- | Information pertaining to the expansion of a type synonym (@type@) data FamTyConFlav = -- | Represents an open type family without a fixed right hand -- side. Additional instances can appear at any time. -- -- These are introduced by either a top level declaration: -- -- > data family T a :: * -- -- Or an associated data type declaration, within a class declaration: -- -- > class C a b where -- > data T b :: * DataFamilyTyCon TyConRepName -- | An open type synonym family e.g. @type family F x y :: * -> *@ | OpenSynFamilyTyCon -- | A closed type synonym family e.g. -- @type family F x where { F Int = Bool }@ | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched)) -- See Note [Closed type families] -- | A closed type synonym family declared in an hs-boot file with -- type family F a where .. | AbstractClosedSynFamilyTyCon -- | Built-in type family used by the TypeNats solver | BuiltInSynFamTyCon BuiltInSynFamily instance Outputable FamTyConFlav where ppr (DataFamilyTyCon n) = text "data family" <+> ppr n ppr OpenSynFamilyTyCon = text "open type family" ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family" ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family" ppr (BuiltInSynFamTyCon _) = text "built-in type family" {- Note [Closed type families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * In an open type family you can add new instances later. This is the usual case. * In a closed type family you can only put equations where the family is defined. A non-empty closed type family has a single axiom with multiple branches, stored in the 'ClosedSynFamilyTyCon' constructor. A closed type family with no equations does not have an axiom, because there is nothing for the axiom to prove! Note [Promoted data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ All data constructors can be promoted to become a type constructor, via the PromotedDataCon alternative in TyCon. * The TyCon promoted from a DataCon has the *same* Name and Unique as the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78, say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) * We promote the *user* type of the DataCon. Eg data T = MkT {-# UNPACK #-} !(Bool, Bool) The promoted kind is 'MkT :: (Bool,Bool) -> T *not* 'MkT :: Bool -> Bool -> T * Similarly for GADTs: data G a where MkG :: forall b. b -> G [b] The promoted data constructor has kind 'MkG :: forall b. b -> G [b] *not* 'MkG :: forall a b. (a ~# [b]) => b -> G a Note [Enumeration types] ~~~~~~~~~~~~~~~~~~~~~~~~ We define datatypes with no constructors to *not* be enumerations; this fixes trac #2578, Otherwise we end up generating an empty table for __closure_tbl which is used by tagToEnum# to map Int# to constructors in an enumeration. The empty table apparently upset the linker. Moreover, all the data constructor must be enumerations, meaning they have type (forall abc. T a b c). GADTs are not enumerations. For example consider data T a where T1 :: T Int T2 :: T Bool T3 :: T a What would [T1 ..] be? [T1,T3] :: T Int? Easiest thing is to exclude them. See #4528. Note [Newtype coercions] ~~~~~~~~~~~~~~~~~~~~~~~~ The NewTyCon field nt_co is a CoAxiom which is used for coercing from the representation type of the newtype, to the newtype itself. For example, newtype T a = MkT (a -> a) the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t. In the case that the right hand side is a type application ending with the same type variables as the left hand side, we "eta-contract" the coercion. So if we had newtype S a = MkT [a] then we would generate the arity 0 axiom CoS : S ~ []. The primary reason we do this is to make newtype deriving cleaner. In the paper we'd write axiom CoT : (forall t. T t) ~ (forall t. [t]) and then when we used CoT at a particular type, s, we'd say CoT @ s which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) Note [Newtype eta] ~~~~~~~~~~~~~~~~~~ Consider newtype Parser a = MkParser (IO a) deriving Monad Are these two types equal (to Core)? Monad Parser Monad IO which we need to make the derived instance for Monad Parser. Well, yes. But to see that easily we eta-reduce the RHS type of Parser, in this case to ([], Froogle), so that even unsaturated applications of Parser will work right. This eta reduction is done when the type constructor is built, and cached in NewTyCon. Here's an example that I think showed up in practice Source code: newtype T a = MkT [a] newtype Foo m = MkFoo (forall a. m a -> Int) w1 :: Foo [] w1 = ... w2 :: Foo T w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) After desugaring, and discarding the data constructors for the newtypes, we get: w2 = w1 `cast` Foo CoT so the coercion tycon CoT must have kind: T ~ [] and arity: 0 This eta-reduction is implemented in BuildTyCl.mkNewTyConRhs. ************************************************************************ * * TyConRepName * * ********************************************************************* -} type TyConRepName = Name -- The Name of the top-level declaration -- $tcMaybe :: Data.Typeable.Internal.TyCon -- $tcMaybe = TyCon { tyConName = "Maybe", ... } tyConRepName_maybe :: TyCon -> Maybe TyConRepName tyConRepName_maybe (FunTyCon { tcRepName = rep_nm }) = Just rep_nm tyConRepName_maybe (PrimTyCon { primRepName = mb_rep_nm }) = mb_rep_nm tyConRepName_maybe (AlgTyCon { algTcParent = parent }) | VanillaAlgTyCon rep_nm <- parent = Just rep_nm | ClassTyCon _ rep_nm <- parent = Just rep_nm | UnboxedAlgTyCon rep_nm <- parent = rep_nm tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) = Just rep_nm tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm }) | isUnboxedSumCon dc -- see #13276 = Nothing | otherwise = Just rep_nm tyConRepName_maybe _ = Nothing -- | Make a 'Name' for the 'Typeable' representation of the given wired-in type mkPrelTyConRepName :: Name -> TyConRepName -- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. mkPrelTyConRepName tc_name -- Prelude tc_name is always External, -- so nameModule will work = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name) where name_occ = nameOccName tc_name name_mod = nameModule tc_name name_uniq = nameUnique tc_name rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq | otherwise = dataConTyRepNameUnique name_uniq (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ -- | The name (and defining module) for the Typeable representation (TyCon) of a -- type constructor. -- -- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. tyConRepModOcc :: Module -> OccName -> (Module, OccName) tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ) where rep_module | tc_module == gHC_PRIM = gHC_TYPES | otherwise = tc_module {- ********************************************************************* * * PrimRep * * ************************************************************************ Note [rep swamp] GHC has a rich selection of types that represent "primitive types" of one kind or another. Each of them makes a different set of distinctions, and mostly the differences are for good reasons, although it's probably true that we could merge some of these. Roughly in order of "includes more information": - A Width (cmm/CmmType) is simply a binary value with the specified number of bits. It may represent a signed or unsigned integer, a floating-point value, or an address. data Width = W8 | W16 | W32 | W64 | W128 - Size, which is used in the native code generator, is Width + floating point information. data Size = II8 | II16 | II32 | II64 | FF32 | FF64 it is necessary because e.g. the instruction to move a 64-bit float on x86 (movsd) is different from the instruction to move a 64-bit integer (movq), so the mov instruction is parameterised by Size. - CmmType wraps Width with more information: GC ptr, float, or other value. data CmmType = CmmType CmmCat Width data CmmCat -- "Category" (not exported) = GcPtrCat -- GC pointer | BitsCat -- Non-pointer | FloatCat -- Float It is important to have GcPtr information in Cmm, since we generate info tables containing pointerhood for the GC from this. As for why we have float (and not signed/unsigned) here, see Note [Signed vs unsigned]. - ArgRep makes only the distinctions necessary for the call and return conventions of the STG machine. It is essentially CmmType + void. - PrimRep makes a few more distinctions than ArgRep: it divides non-GC-pointers into signed/unsigned and addresses, information that is necessary for passing these values to foreign functions. There's another tension here: whether the type encodes its size in bytes, or whether its size depends on the machine word size. Width and CmmType have the size built-in, whereas ArgRep and PrimRep do not. This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags. On the other hand, CmmType includes some "nonsense" values, such as CmmType GcPtrCat W32 on a 64-bit machine. The PrimRep type is closely related to the user-visible RuntimeRep type. See Note [RuntimeRep and PrimRep] in RepType. -} -- | A 'PrimRep' is an abstraction of a type. It contains information that -- the code generator needs in order to pass arguments, return results, -- and store values of this type. See also Note [RuntimeRep and PrimRep] in RepType -- and Note [VoidRep] in RepType. data PrimRep = VoidRep | LiftedRep | UnliftedRep -- ^ Unlifted pointer | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value | Int32Rep -- ^ Signed, 32-bit value | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) | IntRep -- ^ Signed, word-sized value | Word8Rep -- ^ Unsigned, 8 bit value | Word16Rep -- ^ Unsigned, 16 bit value | Word32Rep -- ^ Unsigned, 32 bit value | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) | WordRep -- ^ Unsigned, word-sized value | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep') | FloatRep | DoubleRep | VecRep Int PrimElemRep -- ^ A vector deriving( Show ) data PrimElemRep = Int8ElemRep | Int16ElemRep | Int32ElemRep | Int64ElemRep | Word8ElemRep | Word16ElemRep | Word32ElemRep | Word64ElemRep | FloatElemRep | DoubleElemRep deriving( Eq, Show ) instance Outputable PrimRep where ppr r = text (show r) instance Outputable PrimElemRep where ppr r = text (show r) isVoidRep :: PrimRep -> Bool isVoidRep VoidRep = True isVoidRep _other = False isGcPtrRep :: PrimRep -> Bool isGcPtrRep LiftedRep = True isGcPtrRep UnliftedRep = True isGcPtrRep _ = False -- A PrimRep is compatible with another iff one can be coerced to the other. -- See Note [bad unsafe coercion] in CoreLint for when are two types coercible. primRepCompatible :: DynFlags -> PrimRep -> PrimRep -> Bool primRepCompatible dflags rep1 rep2 = (isUnboxed rep1 == isUnboxed rep2) && (primRepSizeB dflags rep1 == primRepSizeB dflags rep2) && (primRepIsFloat rep1 == primRepIsFloat rep2) where isUnboxed = not . isGcPtrRep -- More general version of `primRepCompatible` for types represented by zero or -- more than one PrimReps. primRepsCompatible :: DynFlags -> [PrimRep] -> [PrimRep] -> Bool primRepsCompatible dflags reps1 reps2 = length reps1 == length reps2 && and (zipWith (primRepCompatible dflags) reps1 reps2) -- | The size of a 'PrimRep' in bytes. -- -- This applies also when used in a constructor, where we allow packing the -- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will -- take only 8 bytes, which for 64-bit arch will be equal to 1 word. -- See also mkVirtHeapOffsetsWithPadding for details of how data fields are -- layed out. primRepSizeB :: DynFlags -> PrimRep -> Int primRepSizeB dflags IntRep = wORD_SIZE dflags primRepSizeB dflags WordRep = wORD_SIZE dflags primRepSizeB _ Int8Rep = 1 primRepSizeB _ Int16Rep = 2 primRepSizeB _ Int32Rep = 4 primRepSizeB _ Int64Rep = wORD64_SIZE primRepSizeB _ Word8Rep = 1 primRepSizeB _ Word16Rep = 2 primRepSizeB _ Word32Rep = 4 primRepSizeB _ Word64Rep = wORD64_SIZE primRepSizeB _ FloatRep = fLOAT_SIZE primRepSizeB dflags DoubleRep = dOUBLE_SIZE dflags primRepSizeB dflags AddrRep = wORD_SIZE dflags primRepSizeB dflags LiftedRep = wORD_SIZE dflags primRepSizeB dflags UnliftedRep = wORD_SIZE dflags primRepSizeB _ VoidRep = 0 primRepSizeB _ (VecRep len rep) = len * primElemRepSizeB rep primElemRepSizeB :: PrimElemRep -> Int primElemRepSizeB Int8ElemRep = 1 primElemRepSizeB Int16ElemRep = 2 primElemRepSizeB Int32ElemRep = 4 primElemRepSizeB Int64ElemRep = 8 primElemRepSizeB Word8ElemRep = 1 primElemRepSizeB Word16ElemRep = 2 primElemRepSizeB Word32ElemRep = 4 primElemRepSizeB Word64ElemRep = 8 primElemRepSizeB FloatElemRep = 4 primElemRepSizeB DoubleElemRep = 8 -- | Return if Rep stands for floating type, -- returns Nothing for vector types. primRepIsFloat :: PrimRep -> Maybe Bool primRepIsFloat FloatRep = Just True primRepIsFloat DoubleRep = Just True primRepIsFloat (VecRep _ _) = Nothing primRepIsFloat _ = Just False {- ************************************************************************ * * Field labels * * ************************************************************************ -} -- | The labels for the fields of this particular 'TyCon' tyConFieldLabels :: TyCon -> [FieldLabel] tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc -- | The labels for the fields of this particular 'TyCon' tyConFieldLabelEnv :: TyCon -> FieldLabelEnv tyConFieldLabelEnv tc | isAlgTyCon tc = algTcFields tc | otherwise = emptyDFsEnv -- | Look up a field label belonging to this 'TyCon' lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl -- | Make a map from strings to FieldLabels from all the data -- constructors of this algebraic tycon fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl) | fl <- dataConsFields (visibleDataCons rhs) ] where -- Duplicates in this list will be removed by 'mkFsEnv' dataConsFields dcs = concatMap dataConFieldLabels dcs {- ************************************************************************ * * \subsection{TyCon Construction} * * ************************************************************************ Note: the TyCon constructors all take a Kind as one argument, even though they could, in principle, work out their Kind from their other arguments. But to do so they need functions from Types, and that makes a nasty module mutual-recursion. And they aren't called from many places. So we compromise, and move their Kind calculation to the call site. -} -- | Given the name of the function type constructor and it's kind, create the -- corresponding 'TyCon'. It is recommended to use 'TyCoRep.funTyCon' if you want -- this functionality mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon mkFunTyCon name binders rep_nm = FunTyCon { tyConUnique = nameUnique name, tyConName = name, tyConBinders = binders, tyConResKind = liftedTypeKind, tyConKind = mkTyConKind binders liftedTypeKind, tyConArity = length binders, tcRepName = rep_nm } -- | This is the making of an algebraic 'TyCon'. Notably, you have to -- pass in the generic (in the -XGenerics sense) information about the -- type constructor - you can get hold of it easily (see Generics -- module) mkAlgTyCon :: Name -> [TyConBinder] -- ^ Binders of the 'TyCon' -> Kind -- ^ Result kind -> [Role] -- ^ The roles for each TyVar -> Maybe CType -- ^ The C type this type corresponds to -- when using the CAPI FFI -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' -> AlgTyConRhs -- ^ Information about data constructors -> AlgTyConFlav -- ^ What flavour is it? -- (e.g. vanilla, type family) -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? -> TyCon mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, tyConBinders = binders, tyConResKind = res_kind, tyConKind = mkTyConKind binders res_kind, tyConArity = length binders, tyConTyVars = binderVars binders, tcRoles = roles, tyConCType = cType, algTcStupidTheta = stupid, algTcRhs = rhs, algTcFields = fieldsOfAlgTcRhs rhs, algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, algTcGadtSyntax = gadt_syn } -- | Simpler specialization of 'mkAlgTyCon' for classes mkClassTyCon :: Name -> [TyConBinder] -> [Role] -> AlgTyConRhs -> Class -> Name -> TyCon mkClassTyCon name binders roles rhs clas tc_rep_name = mkAlgTyCon name binders constraintKind roles Nothing [] rhs (ClassTyCon clas tc_rep_name) False mkTupleTyCon :: Name -> [TyConBinder] -> Kind -- ^ Result kind of the 'TyCon' -> Arity -- ^ Arity of the tuple 'TyCon' -> DataCon -> TupleSort -- ^ Whether the tuple is boxed or unboxed -> AlgTyConFlav -> TyCon mkTupleTyCon name binders res_kind arity con sort parent = AlgTyCon { tyConUnique = nameUnique name, tyConName = name, tyConBinders = binders, tyConTyVars = binderVars binders, tyConResKind = res_kind, tyConKind = mkTyConKind binders res_kind, tyConArity = arity, tcRoles = replicate arity Representational, tyConCType = Nothing, algTcGadtSyntax = False, algTcStupidTheta = [], algTcRhs = TupleTyCon { data_con = con, tup_sort = sort }, algTcFields = emptyDFsEnv, algTcParent = parent } mkSumTyCon :: Name -> [TyConBinder] -> Kind -- ^ Kind of the resulting 'TyCon' -> Arity -- ^ Arity of the sum -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' -> [DataCon] -> AlgTyConFlav -> TyCon mkSumTyCon name binders res_kind arity tyvars cons parent = AlgTyCon { tyConUnique = nameUnique name, tyConName = name, tyConBinders = binders, tyConTyVars = tyvars, tyConResKind = res_kind, tyConKind = mkTyConKind binders res_kind, tyConArity = arity, tcRoles = replicate arity Representational, tyConCType = Nothing, algTcGadtSyntax = False, algTcStupidTheta = [], algTcRhs = mkSumTyConRhs cons, algTcFields = emptyDFsEnv, algTcParent = parent } -- | Makes a tycon suitable for use during type-checking. It stores -- a variety of details about the definition of the TyCon, but no -- right-hand side. It lives only during the type-checking of a -- mutually-recursive group of tycons; it is then zonked to a proper -- TyCon in zonkTcTyCon. -- See also Note [Kind checking recursive type and class declarations] -- in TcTyClsDecls. mkTcTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind only -> [(Name,TcTyVar)] -- ^ Scoped type variables; -- see Note [How TcTyCons work] in TcTyClsDecls -> Bool -- ^ Is this TcTyCon generalised already? -> TyConFlavour -- ^ What sort of 'TyCon' this represents -> TyCon mkTcTyCon name binders res_kind scoped_tvs poly flav = TcTyCon { tyConUnique = getUnique name , tyConName = name , tyConTyVars = binderVars binders , tyConBinders = binders , tyConResKind = res_kind , tyConKind = mkTyConKind binders res_kind , tyConArity = length binders , tcTyConScopedTyVars = scoped_tvs , tcTyConIsPoly = poly , tcTyConFlavour = flav } -- | No scoped type variables (to be used with mkTcTyCon). noTcTyConScopedTyVars :: [(Name, TcTyVar)] noTcTyConScopedTyVars = [] -- | Create an unlifted primitive 'TyCon', such as @Int#@. mkPrimTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind, never levity-polymorphic -> [Role] -> TyCon mkPrimTyCon name binders res_kind roles = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name) -- | Kind constructors mkKindTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind -> [Role] -> Name -> TyCon mkKindTyCon name binders res_kind roles rep_nm = tc where tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) -- | Create a lifted primitive 'TyCon' such as @RealWorld@ mkLiftedPrimTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind -> [Role] -> TyCon mkLiftedPrimTyCon name binders res_kind roles = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) where rep_nm = mkPrelTyConRepName name mkPrimTyCon' :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind, never levity-polymorphic -- (If you need a levity-polymorphic PrimTyCon, change -- isTcLevPoly.) -> [Role] -> Bool -> Maybe TyConRepName -> TyCon mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm = PrimTyCon { tyConName = name, tyConUnique = nameUnique name, tyConBinders = binders, tyConResKind = res_kind, tyConKind = mkTyConKind binders res_kind, tyConArity = length roles, tcRoles = roles, isUnlifted = is_unlifted, primRepName = rep_nm } -- | Create a type synonym 'TyCon' mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind -> [Role] -> Type -> Bool -> Bool -> TyCon mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free = SynonymTyCon { tyConName = name, tyConUnique = nameUnique name, tyConBinders = binders, tyConResKind = res_kind, tyConKind = mkTyConKind binders res_kind, tyConArity = length binders, tyConTyVars = binderVars binders, tcRoles = roles, synTcRhs = rhs, synIsTau = is_tau, synIsFamFree = is_fam_free } -- | Create a type family 'TyCon' mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind -> Maybe Name -> FamTyConFlav -> Maybe Class -> Injectivity -> TyCon mkFamilyTyCon name binders res_kind resVar flav parent inj = FamilyTyCon { tyConUnique = nameUnique name , tyConName = name , tyConBinders = binders , tyConResKind = res_kind , tyConKind = mkTyConKind binders res_kind , tyConArity = length binders , tyConTyVars = binderVars binders , famTcResVar = resVar , famTcFlav = flav , famTcParent = classTyCon <$> parent , famTcInj = inj } -- | Create a promoted data constructor 'TyCon' -- Somewhat dodgily, we give it the same Name -- as the data constructor itself; when we pretty-print -- the TyCon we add a quote; see the Outputable TyCon instance mkPromotedDataCon :: DataCon -> Name -> TyConRepName -> [TyConTyCoBinder] -> Kind -> [Role] -> RuntimeRepInfo -> TyCon mkPromotedDataCon con name rep_name binders res_kind roles rep_info = PromotedDataCon { tyConUnique = nameUnique name, tyConName = name, tyConArity = length roles, tcRoles = roles, tyConBinders = binders, tyConResKind = res_kind, tyConKind = mkTyConKind binders res_kind, dataCon = con, tcRepName = rep_name, promDcRepInfo = rep_info } isFunTyCon :: TyCon -> Bool isFunTyCon (FunTyCon {}) = True isFunTyCon _ = False -- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) isAbstractTyCon :: TyCon -> Bool isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True isAbstractTyCon _ = False -- | Does this 'TyCon' represent something that cannot be defined in Haskell? isPrimTyCon :: TyCon -> Bool isPrimTyCon (PrimTyCon {}) = True isPrimTyCon _ = False -- | Is this 'TyCon' unlifted (i.e. cannot contain bottom)? Note that this can -- only be true for primitive and unboxed-tuple 'TyCon's isUnliftedTyCon :: TyCon -> Bool isUnliftedTyCon (PrimTyCon {isUnlifted = is_unlifted}) = is_unlifted isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) | TupleTyCon { tup_sort = sort } <- rhs = not (isBoxed (tupleSortBoxity sort)) isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) | SumTyCon {} <- rhs = True isUnliftedTyCon _ = False -- | Returns @True@ if the supplied 'TyCon' resulted from either a -- @data@ or @newtype@ declaration isAlgTyCon :: TyCon -> Bool isAlgTyCon (AlgTyCon {}) = True isAlgTyCon _ = False -- | Returns @True@ for vanilla AlgTyCons -- that is, those created -- with a @data@ or @newtype@ declaration. isVanillaAlgTyCon :: TyCon -> Bool isVanillaAlgTyCon (AlgTyCon { algTcParent = VanillaAlgTyCon _ }) = True isVanillaAlgTyCon _ = False isDataTyCon :: TyCon -> Bool -- ^ Returns @True@ for data types that are /definitely/ represented by -- heap-allocated constructors. These are scrutinised by Core-level -- @case@ expressions, and they get info tables allocated for them. -- -- Generally, the function will be true for all @data@ types and false -- for @newtype@s, unboxed tuples, unboxed sums and type family -- 'TyCon's. But it is not guaranteed to return @True@ in all cases -- that it could. -- -- NB: for a data type family, only the /instance/ 'TyCon's -- get an info table. The family declaration 'TyCon' does not isDataTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of TupleTyCon { tup_sort = sort } -> isBoxed (tupleSortBoxity sort) SumTyCon {} -> False DataTyCon {} -> True NewTyCon {} -> False AbstractTyCon {} -> False -- We don't know, so return False isDataTyCon _ = False -- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds -- (where X is the role passed in): -- If (T a1 b1 c1) ~X (T a2 b2 c2), then (a1 ~X1 a2), (b1 ~X2 b2), and (c1 ~X3 c2) -- (where X1, X2, and X3, are the roles given by tyConRolesX tc X) -- See also Note [Decomposing equality] in TcCanonical isInjectiveTyCon :: TyCon -> Role -> Bool isInjectiveTyCon _ Phantom = False isInjectiveTyCon (FunTyCon {}) _ = True isInjectiveTyCon (AlgTyCon {}) Nominal = True isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational = isGenInjAlgRhs rhs isInjectiveTyCon (SynonymTyCon {}) _ = False isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj isInjectiveTyCon (FamilyTyCon {}) _ = False isInjectiveTyCon (PrimTyCon {}) _ = True isInjectiveTyCon (PromotedDataCon {}) _ = True isInjectiveTyCon (TcTyCon {}) _ = True -- Reply True for TcTyCon to minimise knock on type errors -- See Note [How TcTyCons work] item (1) in TcTyClsDecls -- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds -- (where X is the role passed in): -- If (T tys ~X t), then (t's head ~X T). -- See also Note [Decomposing equality] in TcCanonical isGenerativeTyCon :: TyCon -> Role -> Bool isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True isGenerativeTyCon (FamilyTyCon {}) _ = False -- in all other cases, injectivity implies generativity isGenerativeTyCon tc r = isInjectiveTyCon tc r -- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective -- with respect to representational equality? isGenInjAlgRhs :: AlgTyConRhs -> Bool isGenInjAlgRhs (TupleTyCon {}) = True isGenInjAlgRhs (SumTyCon {}) = True isGenInjAlgRhs (DataTyCon {}) = True isGenInjAlgRhs (AbstractTyCon {}) = False isGenInjAlgRhs (NewTyCon {}) = False -- | Is this 'TyCon' that for a @newtype@ isNewTyCon :: TyCon -> Bool isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True isNewTyCon _ = False -- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it -- expands into, and (possibly) a coercion from the representation type to the -- @newtype@. -- Returns @Nothing@ if this is not possible. unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co, nt_rhs = rhs }}) = Just (tvs, rhs, co) unwrapNewTyCon_maybe _ = Nothing unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co, nt_etad_rhs = (tvs,rhs) }}) = Just (tvs, rhs, co) unwrapNewTyConEtad_maybe _ = Nothing isProductTyCon :: TyCon -> Bool -- True of datatypes or newtypes that have -- one, non-existential, data constructor -- See Note [Product types] isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of TupleTyCon {} -> True DataTyCon{ data_cons = [data_con] } -> null (dataConExTyCoVars data_con) NewTyCon {} -> True _ -> False isProductTyCon _ = False isDataProductTyCon_maybe :: TyCon -> Maybe DataCon -- True of datatypes (not newtypes) with -- one, vanilla, data constructor -- See Note [Product types] isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs }) = case rhs of DataTyCon { data_cons = [con] } | null (dataConExTyCoVars con) -- non-existential -> Just con TupleTyCon { data_con = con } -> Just con _ -> Nothing isDataProductTyCon_maybe _ = Nothing isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon] isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs }) = case rhs of DataTyCon { data_cons = cons } | cons `lengthExceeds` 1 , all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? -> Just cons SumTyCon { data_cons = cons } | all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? -> Just cons _ -> Nothing isDataSumTyCon_maybe _ = Nothing {- Note [Product types] ~~~~~~~~~~~~~~~~~~~~~~~ A product type is * A data type (not a newtype) * With one, boxed data constructor * That binds no existential type variables The main point is that product types are amenable to unboxing for * Strict function calls; we can transform f (D a b) = e to fw a b = e via the worker/wrapper transformation. (Question: couldn't this work for existentials too?) * CPR for function results; we can transform f x y = let ... in D a b to fw x y = let ... in (# a, b #) Note that the data constructor /can/ have evidence arguments: equality constraints, type classes etc. So it can be GADT. These evidence arguments are simply value arguments, and should not get in the way. -} -- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? isTypeSynonymTyCon :: TyCon -> Bool isTypeSynonymTyCon (SynonymTyCon {}) = True isTypeSynonymTyCon _ = False isTauTyCon :: TyCon -> Bool isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau isTauTyCon _ = True isFamFreeTyCon :: TyCon -> Bool isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free isFamFreeTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav isFamFreeTyCon _ = True -- As for newtypes, it is in some contexts important to distinguish between -- closed synonyms and synonym families, as synonym families have no unique -- right hand side to which a synonym family application can expand. -- -- | True iff we can decompose (T a b c) into ((T a b) c) -- I.e. is it injective and generative w.r.t nominal equality? -- That is, if (T a b) ~N d e f, is it always the case that -- (T ~N d), (a ~N e) and (b ~N f)? -- Specifically NOT true of synonyms (open and otherwise) -- -- It'd be unusual to call mustBeSaturated on a regular H98 -- type synonym, because you should probably have expanded it first -- But regardless, it's not decomposable mustBeSaturated :: TyCon -> Bool mustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour -- | Is this an algebraic 'TyCon' declared with the GADT syntax? isGadtSyntaxTyCon :: TyCon -> Bool isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res isGadtSyntaxTyCon _ = False -- | Is this an algebraic 'TyCon' which is just an enumeration of values? isEnumerationTyCon :: TyCon -> Bool -- See Note [Enumeration types] in TyCon isEnumerationTyCon (AlgTyCon { tyConArity = arity, algTcRhs = rhs }) = case rhs of DataTyCon { is_enum = res } -> res TupleTyCon {} -> arity == 0 _ -> False isEnumerationTyCon _ = False -- | Is this a 'TyCon', synonym or otherwise, that defines a family? isFamilyTyCon :: TyCon -> Bool isFamilyTyCon (FamilyTyCon {}) = True isFamilyTyCon _ = False -- | Is this a 'TyCon', synonym or otherwise, that defines a family with -- instances? isOpenFamilyTyCon :: TyCon -> Bool isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav }) | OpenSynFamilyTyCon <- flav = True | DataFamilyTyCon {} <- flav = True isOpenFamilyTyCon _ = False -- | Is this a synonym 'TyCon' that can have may have further instances appear? isTypeFamilyTyCon :: TyCon -> Bool isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav) isTypeFamilyTyCon _ = False -- | Is this a synonym 'TyCon' that can have may have further instances appear? isDataFamilyTyCon :: TyCon -> Bool isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav isDataFamilyTyCon _ = False -- | Is this an open type family TyCon? isOpenTypeFamilyTyCon :: TyCon -> Bool isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True isOpenTypeFamilyTyCon _ = False -- | Is this a non-empty closed type family? Returns 'Nothing' for -- abstract or empty closed families. isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched) isClosedSynFamilyTyConWithAxiom_maybe (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing -- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ is @tc@ is an -- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is -- injective), or 'NotInjective' otherwise. tyConInjectivityInfo :: TyCon -> Injectivity tyConInjectivityInfo tc | FamilyTyCon { famTcInj = inj } <- tc = inj | isInjectiveTyCon tc Nominal = Injective (replicate (tyConArity tc) True) | otherwise = NotInjective isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily isBuiltInSynFamTyCon_maybe (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops isBuiltInSynFamTyCon_maybe _ = Nothing isDataFamFlav :: FamTyConFlav -> Bool isDataFamFlav (DataFamilyTyCon {}) = True -- Data family isDataFamFlav _ = False -- Type synonym family -- | Is this TyCon for an associated type? isTyConAssoc :: TyCon -> Bool isTyConAssoc = isJust . tyConAssoc_maybe -- | Get the enclosing class TyCon (if there is one) for the given TyCon. tyConAssoc_maybe :: TyCon -> Maybe TyCon tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour -- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour tyConFlavourAssoc_maybe :: TyConFlavour -> Maybe TyCon tyConFlavourAssoc_maybe (DataFamilyFlavour mb_parent) = mb_parent tyConFlavourAssoc_maybe (OpenTypeFamilyFlavour mb_parent) = mb_parent tyConFlavourAssoc_maybe _ = Nothing -- The unit tycon didn't used to be classed as a tuple tycon -- but I thought that was silly so I've undone it -- If it can't be for some reason, it should be a AlgTyCon isTupleTyCon :: TyCon -> Bool -- ^ Does this 'TyCon' represent a tuple? -- -- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to -- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they -- get spat into the interface file as tuple tycons, so I don't think -- it matters. isTupleTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True isTupleTyCon _ = False tyConTuple_maybe :: TyCon -> Maybe TupleSort tyConTuple_maybe (AlgTyCon { algTcRhs = rhs }) | TupleTyCon { tup_sort = sort} <- rhs = Just sort tyConTuple_maybe _ = Nothing -- | Is this the 'TyCon' for an unboxed tuple? isUnboxedTupleTyCon :: TyCon -> Bool isUnboxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) | TupleTyCon { tup_sort = sort } <- rhs = not (isBoxed (tupleSortBoxity sort)) isUnboxedTupleTyCon _ = False -- | Is this the 'TyCon' for a boxed tuple? isBoxedTupleTyCon :: TyCon -> Bool isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) | TupleTyCon { tup_sort = sort } <- rhs = isBoxed (tupleSortBoxity sort) isBoxedTupleTyCon _ = False -- | Is this the 'TyCon' for an unboxed sum? isUnboxedSumTyCon :: TyCon -> Bool isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs }) | SumTyCon {} <- rhs = True isUnboxedSumTyCon _ = False -- | Is this the 'TyCon' for a /promoted/ tuple? isPromotedTupleTyCon :: TyCon -> Bool isPromotedTupleTyCon tyCon | Just dataCon <- isPromotedDataCon_maybe tyCon , isTupleTyCon (dataConTyCon dataCon) = True | otherwise = False -- | Is this a PromotedDataCon? isPromotedDataCon :: TyCon -> Bool isPromotedDataCon (PromotedDataCon {}) = True isPromotedDataCon _ = False -- | Retrieves the promoted DataCon if this is a PromotedDataCon; isPromotedDataCon_maybe :: TyCon -> Maybe DataCon isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc isPromotedDataCon_maybe _ = Nothing -- | Is this tycon really meant for use at the kind level? That is, -- should it be permitted without -XDataKinds? isKindTyCon :: TyCon -> Bool isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys -- | These TyCons should be allowed at the kind level, even without -- -XDataKinds. kindTyConKeys :: UniqSet Unique kindTyConKeys = unionManyUniqSets ( mkUniqSet [ liftedTypeKindTyConKey, constraintKindTyConKey, tYPETyConKey ] : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon , vecCountTyCon, vecElemTyCon ] ) where tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) isLiftedTypeKindTyConName :: Name -> Bool isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey) -- | Identifies implicit tycons that, in particular, do not go into interface -- files (because they are implicitly reconstructed when the interface is -- read). -- -- Note that: -- -- * Associated families are implicit, as they are re-constructed from -- the class declaration in which they reside, and -- -- * Family instances are /not/ implicit as they represent the instance body -- (similar to a @dfun@ does that for a class instance). -- -- * Tuples are implicit iff they have a wired-in name -- (namely: boxed and unboxed tuples are wired-in and implicit, -- but constraint tuples are not) isImplicitTyCon :: TyCon -> Bool isImplicitTyCon (FunTyCon {}) = True isImplicitTyCon (PrimTyCon {}) = True isImplicitTyCon (PromotedDataCon {}) = True isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name }) | TupleTyCon {} <- rhs = isWiredInName name | SumTyCon {} <- rhs = True | otherwise = False isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent isImplicitTyCon (SynonymTyCon {}) = False isImplicitTyCon (TcTyCon {}) = False tyConCType_maybe :: TyCon -> Maybe CType tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc tyConCType_maybe _ = Nothing -- | Is this a TcTyCon? (That is, one only used during type-checking?) isTcTyCon :: TyCon -> Bool isTcTyCon (TcTyCon {}) = True isTcTyCon _ = False setTcTyConKind :: TyCon -> Kind -> TyCon -- Update the Kind of a TcTyCon -- The new kind is always a zonked version of its previous -- kind, so we don't need to update any other fields. -- See Note [The Purely Kinded Invariant] in TcHsType setTcTyConKind tc@(TcTyCon {}) kind = tc { tyConKind = kind } setTcTyConKind tc _ = pprPanic "setTcTyConKind" (ppr tc) -- | Could this TyCon ever be levity-polymorphic when fully applied? -- True is safe. False means we're sure. Does only a quick check -- based on the TyCon's category. -- Precondition: The fully-applied TyCon has kind (TYPE blah) isTcLevPoly :: TyCon -> Bool isTcLevPoly FunTyCon{} = False isTcLevPoly (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) | UnboxedAlgTyCon _ <- parent = True | NewTyCon { nt_lev_poly = lev_poly } <- rhs = lev_poly -- Newtypes can be levity polymorphic with UnliftedNewtypes (#17360) | otherwise = False isTcLevPoly SynonymTyCon{} = True isTcLevPoly FamilyTyCon{} = True isTcLevPoly PrimTyCon{} = False isTcLevPoly TcTyCon{} = False isTcLevPoly tc@PromotedDataCon{} = pprPanic "isTcLevPoly datacon" (ppr tc) {- ----------------------------------------------- -- Expand type-constructor applications ----------------------------------------------- -} expandSynTyCon_maybe :: TyCon -> [tyco] -- ^ Arguments to 'TyCon' -> Maybe ([(TyVar,tyco)], Type, [tyco]) -- ^ Returns a 'TyVar' substitution, the body -- type of the synonym (not yet substituted) -- and any arguments remaining from the -- application -- ^ Expand a type synonym application, if any expandSynTyCon_maybe tc tys | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc = case tys `listLengthCmp` arity of GT -> Just (tvs `zip` tys, rhs, drop arity tys) EQ -> Just (tvs `zip` tys, rhs, []) LT -> Nothing | otherwise = Nothing ---------------- -- | Check if the tycon actually refers to a proper `data` or `newtype` -- with user defined constructors rather than one from a class or other -- construction. -- NB: This is only used in TcRnExports.checkPatSynParent to determine if an -- exported tycon can have a pattern synonym bundled with it, e.g., -- module Foo (TyCon(.., PatSyn)) where isTyConWithSrcDataCons :: TyCon -> Bool isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcParent = parent }) = case rhs of DataTyCon {} -> isSrcParent NewTyCon {} -> isSrcParent TupleTyCon {} -> isSrcParent _ -> False where isSrcParent = isNoParent parent isTyConWithSrcDataCons (FamilyTyCon { famTcFlav = DataFamilyTyCon {} }) = True -- #14058 isTyConWithSrcDataCons _ = False -- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no -- constructors could be found tyConDataCons :: TyCon -> [DataCon] -- It's convenient for tyConDataCons to return the -- empty list for type synonyms etc tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] -- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon' -- is the sort that can have any constructors (note: this does not include -- abstract algebraic types) tyConDataCons_maybe :: TyCon -> Maybe [DataCon] tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs}) = case rhs of DataTyCon { data_cons = cons } -> Just cons NewTyCon { data_con = con } -> Just [con] TupleTyCon { data_con = con } -> Just [con] SumTyCon { data_cons = cons } -> Just cons _ -> Nothing tyConDataCons_maybe _ = Nothing -- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ -- type with one alternative, a tuple type or a @newtype@ then that constructor -- is returned. If the 'TyCon' has more than one constructor, or represents a -- primitive or function type constructor then @Nothing@ is returned. In any -- other case, the function panics tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs }) = case rhs of DataTyCon { data_cons = [c] } -> Just c TupleTyCon { data_con = c } -> Just c NewTyCon { data_con = c } -> Just c _ -> Nothing tyConSingleDataCon_maybe _ = Nothing tyConSingleDataCon :: TyCon -> DataCon tyConSingleDataCon tc = case tyConSingleDataCon_maybe tc of Just c -> c Nothing -> pprPanic "tyConDataCon" (ppr tc) tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon -- Returns (Just con) for single-constructor -- *algebraic* data types *not* newtypes tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs }) = case rhs of DataTyCon { data_cons = [c] } -> Just c TupleTyCon { data_con = c } -> Just c _ -> Nothing tyConSingleAlgDataCon_maybe _ = Nothing -- | Determine the number of value constructors a 'TyCon' has. Panics if the -- 'TyCon' is not algebraic or a tuple tyConFamilySize :: TyCon -> Int tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs }) = case rhs of DataTyCon { data_cons_size = size } -> size NewTyCon {} -> 1 TupleTyCon {} -> 1 SumTyCon { data_cons_size = size } -> size _ -> pprPanic "tyConFamilySize 1" (ppr tc) tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc) -- | Extract an 'AlgTyConRhs' with information about data constructors from an -- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon' algTyConRhs :: TyCon -> AlgTyConRhs algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs algTyConRhs other = pprPanic "algTyConRhs" (ppr other) -- | Extract type variable naming the result of injective type family tyConFamilyResVar_maybe :: TyCon -> Maybe Name tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res tyConFamilyResVar_maybe _ = Nothing -- | Get the list of roles for the type parameters of a TyCon tyConRoles :: TyCon -> [Role] -- See also Note [TyCon Role signatures] tyConRoles tc = case tc of { FunTyCon {} -> [Nominal, Nominal, Representational, Representational] ; AlgTyCon { tcRoles = roles } -> roles ; SynonymTyCon { tcRoles = roles } -> roles ; FamilyTyCon {} -> const_role Nominal ; PrimTyCon { tcRoles = roles } -> roles ; PromotedDataCon { tcRoles = roles } -> roles ; TcTyCon {} -> const_role Nominal } where const_role r = replicate (tyConArity tc) r -- | Extract the bound type variables and type expansion of a type synonym -- 'TyCon'. Panics if the 'TyCon' is not a synonym newTyConRhs :: TyCon -> ([TyVar], Type) newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }}) = (tvs, rhs) newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon) -- | The number of type parameters that need to be passed to a newtype to -- resolve it. May be less than in the definition if it can be eta-contracted. newTyConEtadArity :: TyCon -> Int newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = length (fst tvs_rhs) newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon) -- | Extract the bound type variables and type expansion of an eta-contracted -- type synonym 'TyCon'. Panics if the 'TyCon' is not a synonym newTyConEtadRhs :: TyCon -> ([TyVar], Type) newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) -- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to -- construct something with the @newtype@s type from its representation type -- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns -- @Nothing@ newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched) newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co newTyConCo_maybe _ = Nothing newTyConCo :: TyCon -> CoAxiom Unbranched newTyConCo tc = case newTyConCo_maybe tc of Just co -> co Nothing -> pprPanic "newTyConCo" (ppr tc) newTyConDataCon_maybe :: TyCon -> Maybe DataCon newTyConDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just con newTyConDataCon_maybe _ = Nothing -- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context -- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration -- @data Eq a => T a ...@ tyConStupidTheta :: TyCon -> [PredType] tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid tyConStupidTheta (FunTyCon {}) = [] tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) -- | Extract the 'TyVar's bound by a vanilla type synonym -- and the corresponding (unsubstituted) right hand side. synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty}) = Just (tyvars, ty) synTyConDefn_maybe _ = Nothing -- | Extract the information pertaining to the right hand side of a type synonym -- (@type@) declaration. synTyConRhs_maybe :: TyCon -> Maybe Type synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs synTyConRhs_maybe _ = Nothing -- | Extract the flavour of a type family (with all the extra information that -- it carries) famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav famTyConFlav_maybe _ = Nothing -- | Is this 'TyCon' that for a class instance? isClassTyCon :: TyCon -> Bool isClassTyCon (AlgTyCon {algTcParent = ClassTyCon {}}) = True isClassTyCon _ = False -- | If this 'TyCon' is that for a class instance, return the class it is for. -- Otherwise returns @Nothing@ tyConClass_maybe :: TyCon -> Maybe Class tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas _}) = Just clas tyConClass_maybe _ = Nothing -- | Return the associated types of the 'TyCon', if any tyConATs :: TyCon -> [TyCon] tyConATs (AlgTyCon {algTcParent = ClassTyCon clas _}) = classATs clas tyConATs _ = [] ---------------------------------------------------------------------------- -- | Is this 'TyCon' that for a data family instance? isFamInstTyCon :: TyCon -> Bool isFamInstTyCon (AlgTyCon {algTcParent = DataFamInstTyCon {} }) = True isFamInstTyCon _ = False tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched) tyConFamInstSig_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax f ts }) = Just (f, ts, ax) tyConFamInstSig_maybe _ = Nothing -- | If this 'TyCon' is that of a data family instance, return the family in question -- and the instance types. Otherwise, return @Nothing@ tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) tyConFamInst_maybe (AlgTyCon {algTcParent = DataFamInstTyCon _ f ts }) = Just (f, ts) tyConFamInst_maybe _ = Nothing -- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which -- represents a coercion identifying the representation type with the type -- instance family. Otherwise, return @Nothing@ tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched) tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ }) = Just ax tyConFamilyCoercion_maybe _ = Nothing -- | Extract any 'RuntimeRepInfo' from this TyCon tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri tyConRuntimeRepInfo _ = NoRRI -- could panic in that second case. But Douglas Adams told me not to. {- Note [Constructor tag allocation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When typechecking we need to allocate constructor tags to constructors. They are allocated based on the position in the data_cons field of TyCon, with the first constructor getting fIRST_TAG. We used to pay linear cost per constructor, with each constructor looking up its relative index in the constructor list. That was quadratic and prohibitive for large data types with more than 10k constructors. The current strategy is to build a NameEnv with a mapping from costructor's Name to ConTag and pass it down to buildDataCon for efficient lookup. Relevant ticket: #14657 -} mkTyConTagMap :: TyCon -> NameEnv ConTag mkTyConTagMap tycon = mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..] -- See Note [Constructor tag allocation] {- ************************************************************************ * * \subsection[TyCon-instances]{Instance declarations for @TyCon@} * * ************************************************************************ @TyCon@s are compared by comparing their @Unique@s. -} instance Eq TyCon where a == b = getUnique a == getUnique b a /= b = getUnique a /= getUnique b instance Uniquable TyCon where getUnique tc = tyConUnique tc instance Outputable TyCon where -- At the moment a promoted TyCon has the same Name as its -- corresponding TyCon, so we add the quote to distinguish it here ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc where pp_tc = getPprStyle $ \sty -> if ((debugStyle sty || dumpStyle sty) && isTcTyCon tc) then text "[tc]" else empty -- | Paints a picture of what a 'TyCon' represents, in broad strokes. -- This is used towards more informative error messages. data TyConFlavour = ClassFlavour | TupleFlavour Boxity | SumFlavour | DataTypeFlavour | NewtypeFlavour | AbstractTypeFlavour | DataFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) | OpenTypeFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) | ClosedTypeFamilyFlavour | TypeSynonymFlavour | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'. | PromotedDataConFlavour deriving Eq instance Outputable TyConFlavour where ppr = text . go where go ClassFlavour = "class" go (TupleFlavour boxed) | isBoxed boxed = "tuple" | otherwise = "unboxed tuple" go SumFlavour = "unboxed sum" go DataTypeFlavour = "data type" go NewtypeFlavour = "newtype" go AbstractTypeFlavour = "abstract type" go (DataFamilyFlavour (Just _)) = "associated data family" go (DataFamilyFlavour Nothing) = "data family" go (OpenTypeFamilyFlavour (Just _)) = "associated type family" go (OpenTypeFamilyFlavour Nothing) = "type family" go ClosedTypeFamilyFlavour = "type family" go TypeSynonymFlavour = "type synonym" go BuiltInTypeFlavour = "built-in type" go PromotedDataConFlavour = "promoted data constructor" tyConFlavour :: TyCon -> TyConFlavour tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) | ClassTyCon _ _ <- parent = ClassFlavour | otherwise = case rhs of TupleTyCon { tup_sort = sort } -> TupleFlavour (tupleSortBoxity sort) SumTyCon {} -> SumFlavour DataTyCon {} -> DataTypeFlavour NewTyCon {} -> NewtypeFlavour AbstractTyCon {} -> AbstractTypeFlavour tyConFlavour (FamilyTyCon { famTcFlav = flav, famTcParent = parent }) = case flav of DataFamilyTyCon{} -> DataFamilyFlavour parent OpenSynFamilyTyCon -> OpenTypeFamilyFlavour parent ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour tyConFlavour (SynonymTyCon {}) = TypeSynonymFlavour tyConFlavour (FunTyCon {}) = BuiltInTypeFlavour tyConFlavour (PrimTyCon {}) = BuiltInTypeFlavour tyConFlavour (PromotedDataCon {}) = PromotedDataConFlavour tyConFlavour (TcTyCon { tcTyConFlavour = flav }) = flav -- | Can this flavour of 'TyCon' appear unsaturated? tcFlavourMustBeSaturated :: TyConFlavour -> Bool tcFlavourMustBeSaturated ClassFlavour = False tcFlavourMustBeSaturated DataTypeFlavour = False tcFlavourMustBeSaturated NewtypeFlavour = False tcFlavourMustBeSaturated DataFamilyFlavour{} = False tcFlavourMustBeSaturated TupleFlavour{} = False tcFlavourMustBeSaturated SumFlavour = False tcFlavourMustBeSaturated AbstractTypeFlavour = False tcFlavourMustBeSaturated BuiltInTypeFlavour = False tcFlavourMustBeSaturated PromotedDataConFlavour = False tcFlavourMustBeSaturated TypeSynonymFlavour = True tcFlavourMustBeSaturated OpenTypeFamilyFlavour{} = True tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True -- | Is this flavour of 'TyCon' an open type family or a data family? tcFlavourIsOpen :: TyConFlavour -> Bool tcFlavourIsOpen DataFamilyFlavour{} = True tcFlavourIsOpen OpenTypeFamilyFlavour{} = True tcFlavourIsOpen ClosedTypeFamilyFlavour = False tcFlavourIsOpen ClassFlavour = False tcFlavourIsOpen DataTypeFlavour = False tcFlavourIsOpen NewtypeFlavour = False tcFlavourIsOpen TupleFlavour{} = False tcFlavourIsOpen SumFlavour = False tcFlavourIsOpen AbstractTypeFlavour = False tcFlavourIsOpen BuiltInTypeFlavour = False tcFlavourIsOpen PromotedDataConFlavour = False tcFlavourIsOpen TypeSynonymFlavour = False pprPromotionQuote :: TyCon -> SDoc -- Promoted data constructors already have a tick in their OccName pprPromotionQuote tc = case tc of PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types _ -> empty instance NamedThing TyCon where getName = tyConName instance Data.Data TyCon where -- don't traverse? toConstr _ = abstractConstr "TyCon" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "TyCon" instance Binary Injectivity where put_ bh NotInjective = putByte bh 0 put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs get bh = do { h <- getByte bh ; case h of 0 -> return NotInjective _ -> do { xs <- get bh ; return (Injective xs) } } {- ************************************************************************ * * Walking over recursive TyCons * * ************************************************************************ Note [Expanding newtypes and products] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When expanding a type to expose a data-type constructor, we need to be careful about newtypes, lest we fall into an infinite loop. Here are the key examples: newtype Id x = MkId x newtype Fix f = MkFix (f (Fix f)) newtype T = MkT (T -> T) Type Expansion -------------------------- T T -> T Fix Maybe Maybe (Fix Maybe) Id (Id Int) Int Fix Id NO NO NO Notice that * We can expand T, even though it's recursive. * We can expand Id (Id Int), even though the Id shows up twice at the outer level, because Id is non-recursive So, when expanding, we keep track of when we've seen a recursive newtype at outermost level; and bail out if we see it again. We sometimes want to do the same for product types, so that the strictness analyser doesn't unbox infinitely deeply. More precisely, we keep a *count* of how many times we've seen it. This is to account for data instance T (a,b) = MkT (T a) (T b) Then (#10482) if we have a type like T (Int,(Int,(Int,(Int,Int)))) we can still unbox deeply enough during strictness analysis. We have to treat T as potentially recursive, but it's still good to be able to unwrap multiple layers. The function that manages all this is checkRecTc. -} data RecTcChecker = RC !Int (NameEnv Int) -- The upper bound, and the number of times -- we have encountered each TyCon -- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'. initRecTc :: RecTcChecker initRecTc = RC defaultRecTcMaxBound emptyNameEnv -- | The default upper bound (100) for the number of times a 'RecTcChecker' is -- allowed to encounter each 'TyCon'. defaultRecTcMaxBound :: Int defaultRecTcMaxBound = 100 -- Should we have a flag for this? -- | Change the upper bound for the number of times a 'RecTcChecker' is allowed -- to encounter each 'TyCon'. setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker -- Nothing => Recursion detected -- Just rec_tcs => Keep going checkRecTc (RC bound rec_nts) tc = case lookupNameEnv rec_nts tc_name of Just n | n >= bound -> Nothing | otherwise -> Just (RC bound (extendNameEnv rec_nts tc_name (n+1))) Nothing -> Just (RC bound (extendNameEnv rec_nts tc_name 1)) where tc_name = tyConName tc -- | Returns whether or not this 'TyCon' is definite, or a hole -- that may be filled in at some later point. See Note [Skolem abstract data] tyConSkolem :: TyCon -> Bool tyConSkolem = isHoleName . tyConName -- Note [Skolem abstract data] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Skolem abstract data arises from data declarations in an hsig file. -- -- The best analogy is to interpret the types declared in signature files as -- elaborating to universally quantified type variables; e.g., -- -- unit p where -- signature H where -- data T -- data S -- module M where -- import H -- f :: (T ~ S) => a -> b -- f x = x -- -- elaborates as (with some fake structural types): -- -- p :: forall t s. { f :: forall a b. t ~ s => a -> b } -- p = { f = \x -> x } -- ill-typed -- -- It is clear that inside p, t ~ s is not provable (and -- if we tried to write a function to cast t to s, that -- would not work), but if we call p @Int @Int, clearly Int ~ Int -- is provable. The skolem variables are all distinct from -- one another, but we can't make assumptions like "f is -- inaccessible", because the skolem variables will get -- instantiated eventually! -- -- Skolem abstractness can apply to "non-abstract" data as well): -- -- unit p where -- signature H1 where -- data T = MkT -- signature H2 where -- data T = MkT -- module M where -- import qualified H1 -- import qualified H2 -- f :: (H1.T ~ H2.T) => a -> b -- f x = x -- -- This is why the test is on the original name of the TyCon, -- not whether it is abstract or not. ghc-lib-parser-8.10.2.20200808/compiler/types/Type.hs0000644000000000000000000037230313713635745017752 0ustar0000000000000000-- (c) The University of Glasgow 2006 -- (c) The GRASP/AQUA Project, Glasgow University, 1998 -- -- Type - public interface {-# LANGUAGE CPP, FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Main functions for manipulating types and type-related things module Type ( -- Note some of this is just re-exports from TyCon.. -- * Main data types representing Types -- $type_classification -- $representation_types TyThing(..), Type, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), KindOrType, PredType, ThetaType, Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder, KnotTied, -- ** Constructing and deconstructing types mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, getCastedTyVar_maybe, tyVarKind, varType, mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys, splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, funResultTy, funArgTy, mkTyConApp, mkTyConTy, tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, splitTyConApp_maybe, splitTyConApp, tyConAppArgN, nextRole, tcSplitTyConApp_maybe, splitListTyConApp_maybe, repSplitTyConApp_maybe, mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, mkSpecForAllTy, mkSpecForAllTys, mkVisForAllTys, mkTyCoInvForAllTy, mkInvForAllTy, mkInvForAllTys, splitForAllTys, splitForAllTysSameVis, splitForAllVarBndrs, splitForAllTy_maybe, splitForAllTy, splitForAllTy_ty_maybe, splitForAllTy_co_maybe, splitPiTy_maybe, splitPiTy, splitPiTys, mkTyConBindersPreferAnon, mkPiTy, mkPiTys, mkLamType, mkLamTypes, piResultTy, piResultTys, applyTysX, dropForAlls, mkFamilyTyConApp, mkNumLitTy, isNumLitTy, mkStrLitTy, isStrLitTy, isLitTy, isPredTy, getRuntimeRep_maybe, kindRep_maybe, kindRep, mkCastTy, mkCoercionTy, splitCastTy_maybe, discardCast, userTypeError_maybe, pprUserTypeErrorTy, coAxNthLHS, stripCoercionTy, splitPiTysInvisible, splitPiTysInvisibleN, invisibleTyBndrCount, filterOutInvisibleTypes, filterOutInferredTypes, partitionInvisibleTypes, partitionInvisibles, tyConArgFlags, appTyArgFlags, synTyConResKind, modifyJoinResTy, setJoinResTy, -- ** Analyzing types TyCoMapper(..), mapType, mapCoercion, -- (Newtypes) newTyConInstRhs, -- ** Binders sameVis, mkTyCoVarBinder, mkTyCoVarBinders, mkTyVarBinders, mkAnonBinder, isAnonTyCoBinder, binderVar, binderVars, binderType, binderArgFlag, tyCoBinderType, tyCoBinderVar_maybe, tyBinderType, binderRelevantType_maybe, isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder, isInvisibleBinder, isNamedBinder, tyConBindersTyCoBinders, -- ** Common type constructors funTyCon, -- ** Predicates on types isTyVarTy, isFunTy, isCoercionTy, isCoercionTy_maybe, isForAllTy, isForAllTy_ty, isForAllTy_co, isPiTy, isTauTy, isFamFreeTy, isCoVarType, isValidJoinPointType, tyConAppNeedsKindSig, -- *** Levity and boxity isLiftedType_maybe, isLiftedTypeKind, isUnliftedTypeKind, isLiftedRuntimeRep, isUnliftedRuntimeRep, isUnliftedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType, isAlgType, isDataFamilyAppType, isPrimitiveType, isStrictType, isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, dropRuntimeRepArgs, getRuntimeRep, -- * Main data types representing Kinds Kind, -- ** Finding the kind of a type typeKind, tcTypeKind, isTypeLevPoly, resultIsLevPoly, tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind, tcIsRuntimeTypeKind, -- ** Common Kind liftedTypeKind, -- * Type free variables tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, tyCoVarsOfType, tyCoVarsOfTypes, tyCoVarsOfTypeDSet, coVarsOfType, coVarsOfTypes, closeOverKindsDSet, closeOverKindsFV, closeOverKindsList, closeOverKinds, noFreeVarsOfType, splitVisVarsOfType, splitVisVarsOfTypes, expandTypeSynonyms, typeSize, occCheckExpand, -- * Well-scoped lists of variables scopedSort, tyCoVarsOfTypeWellScoped, tyCoVarsOfTypesWellScoped, -- * Type comparison eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX, nonDetCmpTypesX, nonDetCmpTc, eqVarBndrs, -- * Forcing evaluation of types seqType, seqTypes, -- * Other views onto Types coreView, tcView, tyConsOfType, -- * Main type substitution data types TvSubstEnv, -- Representation widely visible TCvSubst(..), -- Representation visible to a few friends -- ** Manipulating type substitutions emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, mkTCvSubst, zipTvSubst, mkTvSubstPrs, zipTCvSubst, notElemTCvSubst, getTvSubstEnv, setTvSubstEnv, zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs, extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, extendTCvSubst, extendCvSubst, extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstList, extendTvSubstAndInScope, extendTCvSubstList, extendTvSubstWithClone, extendTCvSubstWithClone, isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv, isEmptyTCvSubst, unionTCvSubst, -- ** Performing substitution on types and kinds substTy, substTys, substTyWith, substTysWith, substTheta, substTyAddInScope, substTyUnchecked, substTysUnchecked, substThetaUnchecked, substTyWithUnchecked, substCoUnchecked, substCoWithUnchecked, substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars, substVarBndr, substVarBndrs, cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, -- * Tidying type related things up for printing tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, tidyOpenKind, tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, tidyOpenTyCoVar, tidyOpenTyCoVars, tidyTyCoVarOcc, tidyTopType, tidyKind, tidyTyCoVarBinder, tidyTyCoVarBinders, -- * Kinds isConstraintKindCon, classifiesTypeWithValues, isKindLevPoly ) where #include "GhclibHsVersions.h" import GhcPrelude import BasicTypes -- We import the representation and primitive functions from TyCoRep. -- Many things are reexported, but not the representation! import TyCoRep import TyCoSubst import TyCoTidy import TyCoFVs -- friends: import Var import VarEnv import VarSet import UniqSet import TyCon import TysPrim import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind , typeSymbolKind, liftedTypeKind , constraintKind ) import PrelNames import CoAxiom import {-# SOURCE #-} Coercion( mkNomReflCo, mkGReflCo, mkReflCo , mkTyConAppCo, mkAppCo, mkCoVarCo, mkAxiomRuleCo , mkForAllCo, mkFunCo, mkAxiomInstCo, mkUnivCo , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo , mkKindCo, mkSubCo, mkFunCo, mkAxiomInstCo , decomposePiCos, coercionKind, coercionType , isReflexiveCo, seqCo ) -- others import Util import FV import Outputable import FastString import Pair import ListSetOps import Unique ( nonDetCmpUnique ) import Maybes ( orElse ) import Data.Maybe ( isJust ) import Control.Monad ( guard ) -- $type_classification -- #type_classification# -- -- Types are one of: -- -- [Unboxed] Iff its representation is other than a pointer -- Unboxed types are also unlifted. -- -- [Lifted] Iff it has bottom as an element. -- Closures always have lifted types: i.e. any -- let-bound identifier in Core must have a lifted -- type. Operationally, a lifted object is one that -- can be entered. -- Only lifted types may be unified with a type variable. -- -- [Algebraic] Iff it is a type with one or more constructors, whether -- declared with @data@ or @newtype@. -- An algebraic type is one that can be deconstructed -- with a case expression. This is /not/ the same as -- lifted types, because we also include unboxed -- tuples in this classification. -- -- [Data] Iff it is a type declared with @data@, or a boxed tuple. -- -- [Primitive] Iff it is a built-in type that can't be expressed in Haskell. -- -- Currently, all primitive types are unlifted, but that's not necessarily -- the case: for example, @Int@ could be primitive. -- -- Some primitive types are unboxed, such as @Int#@, whereas some are boxed -- but unlifted (such as @ByteArray#@). The only primitive types that we -- classify as algebraic are the unboxed tuples. -- -- Some examples of type classifications that may make this a bit clearer are: -- -- @ -- Type primitive boxed lifted algebraic -- ----------------------------------------------------------------------------- -- Int# Yes No No No -- ByteArray# Yes Yes No No -- (\# a, b \#) Yes No No Yes -- (\# a | b \#) Yes No No Yes -- ( a, b ) No Yes Yes Yes -- [a] No Yes Yes Yes -- @ -- $representation_types -- A /source type/ is a type that is a separate type as far as the type checker is -- concerned, but which has a more low-level representation as far as Core-to-Core -- passes and the rest of the back end is concerned. -- -- You don't normally have to worry about this, as the utility functions in -- this module will automatically convert a source into a representation type -- if they are spotted, to the best of its abilities. If you don't want this -- to happen, use the equivalent functions from the "TcType" module. {- ************************************************************************ * * Type representation * * ************************************************************************ Note [coreView vs tcView] ~~~~~~~~~~~~~~~~~~~~~~~~~ So far as the typechecker is concerned, 'Constraint' and 'TYPE LiftedRep' are distinct kinds. But in Core these two are treated as identical. We implement this by making 'coreView' convert 'Constraint' to 'TYPE LiftedRep' on the fly. The function tcView (used in the type checker) does not do this. See also #11715, which tracks removing this inconsistency. -} -- | Gives the typechecker view of a type. This unwraps synonyms but -- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into -- TYPE LiftedRep. Returns Nothing if no unwrapping happens. -- See also Note [coreView vs tcView] {-# INLINE tcView #-} tcView :: Type -> Maybe Type tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') -- The free vars of 'rhs' should all be bound by 'tenv', so it's -- ok to use 'substTy' here. -- See also Note [The substitution invariant] in TyCoSubst. -- Its important to use mkAppTys, rather than (foldl AppTy), -- because the function part might well return a -- partially-applied type constructor; indeed, usually will! tcView _ = Nothing {-# INLINE coreView #-} coreView :: Type -> Maybe Type -- ^ This function Strips off the /top layer only/ of a type synonym -- application (if any) its underlying representation type. -- Returns Nothing if there is nothing to look through. -- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@. -- -- By being non-recursive and inlined, this case analysis gets efficiently -- joined onto the case analysis that the caller is already doing coreView ty@(TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') -- This equation is exactly like tcView -- At the Core level, Constraint = Type -- See Note [coreView vs tcView] | isConstraintKindCon tc = ASSERT2( null tys, ppr ty ) Just liftedTypeKind coreView _ = Nothing ----------------------------------------------- expandTypeSynonyms :: Type -> Type -- ^ Expand out all type synonyms. Actually, it'd suffice to expand out -- just the ones that discard type variables (e.g. type Funny a = Int) -- But we don't know which those are currently, so we just expand all. -- -- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type, -- not in the kinds of any TyCon or TyVar mentioned in the type. -- -- Keep this synchronized with 'synonymTyConsOfType' expandTypeSynonyms ty = go (mkEmptyTCvSubst in_scope) ty where in_scope = mkInScopeSet (tyCoVarsOfType ty) go subst (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys = let subst' = mkTvSubst in_scope (mkVarEnv tenv) -- Make a fresh substitution; rhs has nothing to -- do with anything that has happened so far -- NB: if you make changes here, be sure to build an -- /idempotent/ substitution, even in the nested case -- type T a b = a -> b -- type S x y = T y x -- (#11665) in mkAppTys (go subst' rhs) tys' | otherwise = TyConApp tc expanded_tys where expanded_tys = (map (go subst) tys) go _ (LitTy l) = LitTy l go subst (TyVarTy tv) = substTyVar subst tv go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) go subst ty@(FunTy _ arg res) = ty { ft_arg = go subst arg, ft_res = go subst res } go subst (ForAllTy (Bndr tv vis) t) = let (subst', tv') = substVarBndrUsing go subst tv in ForAllTy (Bndr tv' vis) (go subst' t) go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) go subst (CoercionTy co) = mkCoercionTy (go_co subst co) go_mco _ MRefl = MRefl go_mco subst (MCo co) = MCo (go_co subst co) go_co subst (Refl ty) = mkNomReflCo (go subst ty) go_co subst (GRefl r ty mco) = mkGReflCo r (go subst ty) (go_mco subst mco) -- NB: coercions are always expanded upon creation go_co subst (TyConAppCo r tc args) = mkTyConAppCo r tc (map (go_co subst) args) go_co subst (AppCo co arg) = mkAppCo (go_co subst co) (go_co subst arg) go_co subst (ForAllCo tv kind_co co) = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in mkForAllCo tv' kind_co' (go_co subst' co) go_co subst (FunCo r co1 co2) = mkFunCo r (go_co subst co1) (go_co subst co2) go_co subst (CoVarCo cv) = substCoVar subst cv go_co subst (AxiomInstCo ax ind args) = mkAxiomInstCo ax ind (map (go_co subst) args) go_co subst (UnivCo p r t1 t2) = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2) go_co subst (SymCo co) = mkSymCo (go_co subst co) go_co subst (TransCo co1 co2) = mkTransCo (go_co subst co1) (go_co subst co2) go_co subst (NthCo r n co) = mkNthCo r n (go_co subst co) go_co subst (LRCo lr co) = mkLRCo lr (go_co subst co) go_co subst (InstCo co arg) = mkInstCo (go_co subst co) (go_co subst arg) go_co subst (KindCo co) = mkKindCo (go_co subst co) go_co subst (SubCo co) = mkSubCo (go_co subst co) go_co subst (AxiomRuleCo ax cs) = AxiomRuleCo ax (map (go_co subst) cs) go_co _ (HoleCo h) = pprPanic "expandTypeSynonyms hit a hole" (ppr h) go_prov _ UnsafeCoerceProv = UnsafeCoerceProv go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) go_prov _ p@(PluginProv _) = p -- the "False" and "const" are to accommodate the type of -- substForAllCoBndrUsing, which is general enough to -- handle coercion optimization (which sometimes swaps the -- order of a coercion) go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst -- | Extract the RuntimeRep classifier of a type from its kind. For example, -- @kindRep * = LiftedRep@; Panics if this is not possible. -- Treats * and Constraint as the same kindRep :: HasDebugCallStack => Kind -> Type kindRep k = case kindRep_maybe k of Just r -> r Nothing -> pprPanic "kindRep" (ppr k) -- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr. -- For example, @kindRep_maybe * = Just LiftedRep@ -- Returns 'Nothing' if the kind is not of form (TYPE rr) -- Treats * and Constraint as the same kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type kindRep_maybe kind | Just kind' <- coreView kind = kindRep_maybe kind' | TyConApp tc [arg] <- kind , tc `hasKey` tYPETyConKey = Just arg | otherwise = Nothing -- | This version considers Constraint to be the same as *. Returns True -- if the argument is equivalent to Type/Constraint and False otherwise. -- See Note [Kind Constraint and kind Type] isLiftedTypeKind :: Kind -> Bool isLiftedTypeKind kind = case kindRep_maybe kind of Just rep -> isLiftedRuntimeRep rep Nothing -> False isLiftedRuntimeRep :: Type -> Bool -- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep -- False of type variables (a :: RuntimeRep) -- and of other reps e.g. (IntRep :: RuntimeRep) isLiftedRuntimeRep rep | Just rep' <- coreView rep = isLiftedRuntimeRep rep' | TyConApp rr_tc args <- rep , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True | otherwise = False -- | Returns True if the kind classifies unlifted types and False otherwise. -- Note that this returns False for levity-polymorphic kinds, which may -- be specialized to a kind that classifies unlifted types. isUnliftedTypeKind :: Kind -> Bool isUnliftedTypeKind kind = case kindRep_maybe kind of Just rep -> isUnliftedRuntimeRep rep Nothing -> False isUnliftedRuntimeRep :: Type -> Bool -- True of definitely-unlifted RuntimeReps -- False of (LiftedRep :: RuntimeRep) -- and of variables (a :: RuntimeRep) isUnliftedRuntimeRep rep | Just rep' <- coreView rep = isUnliftedRuntimeRep rep' | TyConApp rr_tc _ <- rep -- NB: args might be non-empty -- e.g. TupleRep [r1, .., rn] = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey) -- Avoid searching all the unlifted RuntimeRep type cons -- In the RuntimeRep data type, only LiftedRep is lifted -- But be careful of type families (F tys) :: RuntimeRep | otherwise {- Variables, applications -} = False -- | Is this the type 'RuntimeRep'? isRuntimeRepTy :: Type -> Bool isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty' isRuntimeRepTy (TyConApp tc args) | tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True isRuntimeRepTy _ = False -- | Is a tyvar of type 'RuntimeRep'? isRuntimeRepVar :: TyVar -> Bool isRuntimeRepVar = isRuntimeRepTy . tyVarKind {- ************************************************************************ * * Analyzing types * * ************************************************************************ These functions do a map-like operation over types, performing some operation on all variables and binding sites. Primarily used for zonking. Note [Efficiency for mapCoercion ForAllCo case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As noted in Note [Forall coercions] in TyCoRep, a ForAllCo is a bit redundant. It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches the left-hand kind of the coercion. This is convenient lots of the time, but not when mapping a function over a coercion. The problem is that tcm_tybinder will affect the TyCoVar's kind and mapCoercion will affect the Coercion, and we hope that the results will be the same. Even if they are the same (which should generally happen with correct algorithms), then there is an efficiency issue. In particular, this problem seems to make what should be a linear algorithm into a potentially exponential one. But it's only going to be bad in the case where there's lots of foralls in the kinds of other foralls. Like this: forall a : (forall b : (forall c : ...). ...). ... This construction seems unlikely. So we'll do the inefficient, easy way for now. Note [Specialising mappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ These INLINABLE pragmas are indispensable. mapType/mapCoercion are used to implement zonking, and it's vital that they get specialised to the TcM monad. This specialisation happens automatically (that is, without a SPECIALISE pragma) as long as the definitions are INLINABLE. For example, this one change made a 20% allocation difference in perf/compiler/T5030. -} -- | This describes how a "map" operation over a type/coercion should behave data TyCoMapper env m = TyCoMapper { tcm_tyvar :: env -> TyVar -> m Type , tcm_covar :: env -> CoVar -> m Coercion , tcm_hole :: env -> CoercionHole -> m Coercion -- ^ What to do with coercion holes. -- See Note [Coercion holes] in TyCoRep. , tcm_tycobinder :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar) -- ^ The returned env is used in the extended scope , tcm_tycon :: TyCon -> m TyCon -- ^ This is used only for TcTyCons -- a) To zonk TcTyCons -- b) To turn TcTyCons into TyCons. -- See Note [Type checking recursive type and class declarations] -- in TcTyClsDecls } {-# INLINABLE mapType #-} -- See Note [Specialising mappers] mapType :: Monad m => TyCoMapper env m -> env -> Type -> m Type mapType mapper@(TyCoMapper { tcm_tyvar = tyvar , tcm_tycobinder = tycobinder , tcm_tycon = tycon }) env ty = go ty where go (TyVarTy tv) = tyvar env tv go (AppTy t1 t2) = mkAppTy <$> go t1 <*> go t2 go ty@(LitTy {}) = return ty go (CastTy ty co) = mkCastTy <$> go ty <*> mapCoercion mapper env co go (CoercionTy co) = CoercionTy <$> mapCoercion mapper env co go ty@(FunTy _ arg res) = do { arg' <- go arg; res' <- go res ; return (ty { ft_arg = arg', ft_res = res' }) } go ty@(TyConApp tc tys) | isTcTyCon tc = do { tc' <- tycon tc ; mkTyConApp tc' <$> mapM go tys } -- Not a TcTyCon | null tys -- Avoid allocation in this very = return ty -- common case (E.g. Int, LiftedRep etc) | otherwise = mkTyConApp tc <$> mapM go tys go (ForAllTy (Bndr tv vis) inner) = do { (env', tv') <- tycobinder env tv vis ; inner' <- mapType mapper env' inner ; return $ ForAllTy (Bndr tv' vis) inner' } {-# INLINABLE mapCoercion #-} -- See Note [Specialising mappers] mapCoercion :: Monad m => TyCoMapper env m -> env -> Coercion -> m Coercion mapCoercion mapper@(TyCoMapper { tcm_covar = covar , tcm_hole = cohole , tcm_tycobinder = tycobinder , tcm_tycon = tycon }) env co = go co where go_mco MRefl = return MRefl go_mco (MCo co) = MCo <$> (go co) go (Refl ty) = Refl <$> mapType mapper env ty go (GRefl r ty mco) = mkGReflCo r <$> mapType mapper env ty <*> (go_mco mco) go (TyConAppCo r tc args) = do { tc' <- if isTcTyCon tc then tycon tc else return tc ; mkTyConAppCo r tc' <$> mapM go args } go (AppCo c1 c2) = mkAppCo <$> go c1 <*> go c2 go (ForAllCo tv kind_co co) = do { kind_co' <- go kind_co ; (env', tv') <- tycobinder env tv Inferred ; co' <- mapCoercion mapper env' co ; return $ mkForAllCo tv' kind_co' co' } -- See Note [Efficiency for mapCoercion ForAllCo case] go (FunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2 go (CoVarCo cv) = covar env cv go (AxiomInstCo ax i args) = mkAxiomInstCo ax i <$> mapM go args go (HoleCo hole) = cohole env hole go (UnivCo p r t1 t2) = mkUnivCo <$> go_prov p <*> pure r <*> mapType mapper env t1 <*> mapType mapper env t2 go (SymCo co) = mkSymCo <$> go co go (TransCo c1 c2) = mkTransCo <$> go c1 <*> go c2 go (AxiomRuleCo r cos) = AxiomRuleCo r <$> mapM go cos go (NthCo r i co) = mkNthCo r i <$> go co go (LRCo lr co) = mkLRCo lr <$> go co go (InstCo co arg) = mkInstCo <$> go co <*> go arg go (KindCo co) = mkKindCo <$> go co go (SubCo co) = mkSubCo <$> go co go_prov UnsafeCoerceProv = return UnsafeCoerceProv go_prov (PhantomProv co) = PhantomProv <$> go co go_prov (ProofIrrelProv co) = ProofIrrelProv <$> go co go_prov p@(PluginProv _) = return p {- ************************************************************************ * * \subsection{Constructor-specific functions} * * ************************************************************************ --------------------------------------------------------------------- TyVarTy ~~~~~~~ -} -- | Attempts to obtain the type variable underlying a 'Type', and panics with the -- given message if this is not a type variable type. See also 'getTyVar_maybe' getTyVar :: String -> Type -> TyVar getTyVar msg ty = case getTyVar_maybe ty of Just tv -> tv Nothing -> panic ("getTyVar: " ++ msg) isTyVarTy :: Type -> Bool isTyVarTy ty = isJust (getTyVar_maybe ty) -- | Attempts to obtain the type variable underlying a 'Type' getTyVar_maybe :: Type -> Maybe TyVar getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty' | otherwise = repGetTyVar_maybe ty -- | If the type is a tyvar, possibly under a cast, returns it, along -- with the coercion. Thus, the co is :: kind tv ~N kind ty getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) getCastedTyVar_maybe ty | Just ty' <- coreView ty = getCastedTyVar_maybe ty' getCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) getCastedTyVar_maybe (TyVarTy tv) = Just (tv, mkReflCo Nominal (tyVarKind tv)) getCastedTyVar_maybe _ = Nothing -- | Attempts to obtain the type variable underlying a 'Type', without -- any expansion repGetTyVar_maybe :: Type -> Maybe TyVar repGetTyVar_maybe (TyVarTy tv) = Just tv repGetTyVar_maybe _ = Nothing {- --------------------------------------------------------------------- AppTy ~~~~~ We need to be pretty careful with AppTy to make sure we obey the invariant that a TyConApp is always visibly so. mkAppTy maintains the invariant: use it. Note [Decomposing fat arrow c=>t] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Can we unify (a b) with (Eq a => ty)? If we do so, we end up with a partial application like ((=>) Eq a) which doesn't make sense in source Haskell. In contrast, we *can* unify (a b) with (t1 -> t2). Here's an example (#9858) of how you might do it: i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep i p = typeRep p j = i (Proxy :: Proxy (Eq Int => Int)) The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes, but suppose we want that. But then in the call to 'i', we end up decomposing (Eq Int => Int), and we definitely don't want that. This really only applies to the type checker; in Core, '=>' and '->' are the same, as are 'Constraint' and '*'. But for now I've put the test in repSplitAppTy_maybe, which applies throughout, because the other calls to splitAppTy are in Unify, which is also used by the type checker (e.g. when matching type-function equations). -} -- | Applies a type to another, as in e.g. @k a@ mkAppTy :: Type -> Type -> Type -- See Note [Respecting definitional equality], invariant (EQ1). mkAppTy (CastTy fun_ty co) arg_ty | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty] = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) mkAppTy ty1 ty2 = AppTy ty1 ty2 -- Note that the TyConApp could be an -- under-saturated type synonym. GHC allows that; e.g. -- type Foo k = k a -> k a -- type Id x = x -- foo :: Foo Id -> Foo Id -- -- Here Id is partially applied in the type sig for Foo, -- but once the type synonyms are expanded all is well -- -- Moreover in TcHsTypes.tcInferApps we build up a type -- (T t1 t2 t3) one argument at a type, thus forming -- (T t1), (T t1 t2), etc mkAppTys :: Type -> [Type] -> Type mkAppTys ty1 [] = ty1 mkAppTys (CastTy fun_ty co) arg_tys -- much more efficient then nested mkAppTy -- Why do this? See (EQ1) of -- Note [Respecting definitional equality] -- in TyCoRep = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers where (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys (args_to_cast, leftovers) = splitAtList arg_cos arg_tys casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) mkAppTys ty1 tys2 = foldl' AppTy ty1 tys2 ------------- splitAppTy_maybe :: Type -> Maybe (Type, Type) -- ^ Attempt to take a type application apart, whether it is a -- function, type constructor, or plain type application. Note -- that type family applications are NEVER unsaturated by this! splitAppTy_maybe ty | Just ty' <- coreView ty = splitAppTy_maybe ty' splitAppTy_maybe ty = repSplitAppTy_maybe ty ------------- repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) -- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that -- any Core view stuff is already done repSplitAppTy_maybe (FunTy _ ty1 ty2) = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) where rep1 = getRuntimeRep ty1 rep2 = getRuntimeRep ty2 repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) repSplitAppTy_maybe (TyConApp tc tys) | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc , Just (tys', ty') <- snocView tys = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! repSplitAppTy_maybe _other = Nothing -- This one doesn't break apart (c => t). -- See Note [Decomposing fat arrow c=>t] -- Defined here to avoid module loops between Unify and TcType. tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type) -- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that -- any coreView stuff is already done. Refuses to look through (c => t) tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 }) | InvisArg <- af = Nothing -- See Note [Decomposing fat arrow c=>t] | otherwise = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) where rep1 = getRuntimeRep ty1 rep2 = getRuntimeRep ty2 tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) tcRepSplitAppTy_maybe (TyConApp tc tys) | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc , Just (tys', ty') <- snocView tys = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! tcRepSplitAppTy_maybe _other = Nothing ------------- splitAppTy :: Type -> (Type, Type) -- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', -- and panics if this is not possible splitAppTy ty = case splitAppTy_maybe ty of Just pr -> pr Nothing -> panic "splitAppTy" ------------- splitAppTys :: Type -> (Type, [Type]) -- ^ Recursively splits a type as far as is possible, leaving a residual -- type being applied to and the type arguments applied to it. Never fails, -- even if that means returning an empty list of type applications. splitAppTys ty = split ty ty [] where split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args split _ (AppTy ty arg) args = split ty ty (arg:args) split _ (TyConApp tc tc_args) args = let -- keep type families saturated n | mustBeSaturated tc = tyConArity tc | otherwise = 0 (tc_args1, tc_args2) = splitAt n tc_args in (TyConApp tc tc_args1, tc_args2 ++ args) split _ (FunTy _ ty1 ty2) args = ASSERT( null args ) (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) where rep1 = getRuntimeRep ty1 rep2 = getRuntimeRep ty2 split orig_ty _ args = (orig_ty, args) -- | Like 'splitAppTys', but doesn't look through type synonyms repSplitAppTys :: HasDebugCallStack => Type -> (Type, [Type]) repSplitAppTys ty = split ty [] where split (AppTy ty arg) args = split ty (arg:args) split (TyConApp tc tc_args) args = let n | mustBeSaturated tc = tyConArity tc | otherwise = 0 (tc_args1, tc_args2) = splitAt n tc_args in (TyConApp tc tc_args1, tc_args2 ++ args) split (FunTy _ ty1 ty2) args = ASSERT( null args ) (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) where rep1 = getRuntimeRep ty1 rep2 = getRuntimeRep ty2 split ty args = (ty, args) {- LitTy ~~~~~ -} mkNumLitTy :: Integer -> Type mkNumLitTy n = LitTy (NumTyLit n) -- | Is this a numeric literal. We also look through type synonyms. isNumLitTy :: Type -> Maybe Integer isNumLitTy ty | Just ty1 <- coreView ty = isNumLitTy ty1 isNumLitTy (LitTy (NumTyLit n)) = Just n isNumLitTy _ = Nothing mkStrLitTy :: FastString -> Type mkStrLitTy s = LitTy (StrTyLit s) -- | Is this a symbol literal. We also look through type synonyms. isStrLitTy :: Type -> Maybe FastString isStrLitTy ty | Just ty1 <- coreView ty = isStrLitTy ty1 isStrLitTy (LitTy (StrTyLit s)) = Just s isStrLitTy _ = Nothing -- | Is this a type literal (symbol or numeric). isLitTy :: Type -> Maybe TyLit isLitTy ty | Just ty1 <- coreView ty = isLitTy ty1 isLitTy (LitTy l) = Just l isLitTy _ = Nothing -- | Is this type a custom user error? -- If so, give us the kind and the error message. userTypeError_maybe :: Type -> Maybe Type userTypeError_maybe t = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t -- There may be more than 2 arguments, if the type error is -- used as a type constructor (e.g. at kind `Type -> Type`). ; guard (tyConName tc == errorMessageTypeErrorFamName) ; return msg } -- | Render a type corresponding to a user type error into a SDoc. pprUserTypeErrorTy :: Type -> SDoc pprUserTypeErrorTy ty = case splitTyConApp_maybe ty of -- Text "Something" Just (tc,[txt]) | tyConName tc == typeErrorTextDataConName , Just str <- isStrLitTy txt -> ftext str -- ShowType t Just (tc,[_k,t]) | tyConName tc == typeErrorShowTypeDataConName -> ppr t -- t1 :<>: t2 Just (tc,[t1,t2]) | tyConName tc == typeErrorAppendDataConName -> pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2 -- t1 :$$: t2 Just (tc,[t1,t2]) | tyConName tc == typeErrorVAppendDataConName -> pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2 -- An unevaluated type function _ -> ppr ty {- --------------------------------------------------------------------- FunTy ~~~~~ Note [Representation of function types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Functions (e.g. Int -> Char) can be thought of as being applications of funTyCon (known in Haskell surface syntax as (->)), (->) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type However, for efficiency's sake we represent saturated applications of (->) with FunTy. For instance, the type, (->) r1 r2 a b is equivalent to, FunTy (Anon a) b Note how the RuntimeReps are implied in the FunTy representation. For this reason we must be careful when recontructing the TyConApp representation (see, for instance, splitTyConApp_maybe). In the compiler we maintain the invariant that all saturated applications of (->) are represented with FunTy. See #11714. -} splitFunTy :: Type -> (Type, Type) -- ^ Attempts to extract the argument and result types from a type, and -- panics if that is not possible. See also 'splitFunTy_maybe' splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty' splitFunTy (FunTy _ arg res) = (arg, res) splitFunTy other = pprPanic "splitFunTy" (ppr other) splitFunTy_maybe :: Type -> Maybe (Type, Type) -- ^ Attempts to extract the argument and result types from a type splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty' splitFunTy_maybe (FunTy _ arg res) = Just (arg, res) splitFunTy_maybe _ = Nothing splitFunTys :: Type -> ([Type], Type) splitFunTys ty = split [] ty ty where split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' split args _ (FunTy _ arg res) = split (arg:args) res res split args orig_ty _ = (reverse args, orig_ty) funResultTy :: Type -> Type -- ^ Extract the function result type and panic if that is not possible funResultTy ty | Just ty' <- coreView ty = funResultTy ty' funResultTy (FunTy { ft_res = res }) = res funResultTy ty = pprPanic "funResultTy" (ppr ty) funArgTy :: Type -> Type -- ^ Extract the function argument type and panic if that is not possible funArgTy ty | Just ty' <- coreView ty = funArgTy ty' funArgTy (FunTy { ft_arg = arg }) = arg funArgTy ty = pprPanic "funArgTy" (ppr ty) -- ^ Just like 'piResultTys' but for a single argument -- Try not to iterate 'piResultTy', because it's inefficient to substitute -- one variable at a time; instead use 'piResultTys" piResultTy :: HasDebugCallStack => Type -> Type -> Type piResultTy ty arg = case piResultTy_maybe ty arg of Just res -> res Nothing -> pprPanic "piResultTy" (ppr ty $$ ppr arg) piResultTy_maybe :: Type -> Type -> Maybe Type -- We don't need a 'tc' version, because -- this function behaves the same for Type and Constraint piResultTy_maybe ty arg | Just ty' <- coreView ty = piResultTy_maybe ty' arg | FunTy { ft_res = res } <- ty = Just res | ForAllTy (Bndr tv _) res <- ty = let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfTypes [arg,res] in Just (substTy (extendTCvSubst empty_subst tv arg) res) | otherwise = Nothing -- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn) -- where f :: f_ty -- 'piResultTys' is interesting because: -- 1. 'f_ty' may have more for-alls than there are args -- 2. Less obviously, it may have fewer for-alls -- For case 2. think of: -- piResultTys (forall a.a) [forall b.b, Int] -- This really can happen, but only (I think) in situations involving -- undefined. For example: -- undefined :: forall a. a -- Term: undefined @(forall b. b->b) @Int -- This term should have type (Int -> Int), but notice that -- there are more type args than foralls in 'undefined's type. -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.hs -- This is a heavily used function (e.g. from typeKind), -- so we pay attention to efficiency, especially in the special case -- where there are no for-alls so we are just dropping arrows from -- a function type/kind. piResultTys :: HasDebugCallStack => Type -> [Type] -> Type piResultTys ty [] = ty piResultTys ty orig_args@(arg:args) | Just ty' <- coreView ty = piResultTys ty' orig_args | FunTy { ft_res = res } <- ty = piResultTys res args | ForAllTy (Bndr tv _) res <- ty = go (extendTCvSubst init_subst tv arg) res args | otherwise = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) where init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) go :: TCvSubst -> Type -> [Type] -> Type go subst ty [] = substTyUnchecked subst ty go subst ty all_args@(arg:args) | Just ty' <- coreView ty = go subst ty' all_args | FunTy { ft_res = res } <- ty = go subst res args | ForAllTy (Bndr tv _) res <- ty = go (extendTCvSubst subst tv arg) res args | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] = go init_subst (substTy subst ty) all_args | otherwise = -- We have not run out of arguments, but the function doesn't -- have the right kind to apply to them; so panic. -- Without the explicit isEmptyVarEnv test, an ill-kinded type -- would give an infniite loop, which is very unhelpful -- c.f. #15473 pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) applyTysX :: [TyVar] -> Type -> [Type] -> Type -- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys -- Assumes that (/\tvs. body_ty) is closed applyTysX tvs body_ty arg_tys = ASSERT2( arg_tys `lengthAtLeast` n_tvs, pp_stuff ) ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff ) mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty) (drop n_tvs arg_tys) where pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys] n_tvs = length tvs {- Note [Care with kind instantiation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have T :: forall k. k and we are finding the kind of T (forall b. b -> b) * Int Then T (forall b. b->b) :: k[ k :-> forall b. b->b] :: forall b. b -> b So T (forall b. b->b) * :: (b -> b)[ b :-> *] :: * -> * In other words we must intantiate the forall! Similarly (#15428) S :: forall k f. k -> f k and we are finding the kind of S * (* ->) Int Bool We have S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)] :: * -> * -> * So again we must instantiate. The same thing happens in ToIface.toIfaceAppArgsX. --------------------------------------------------------------------- TyConApp ~~~~~~~~ -} -- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to -- its arguments. Applies its arguments to the constructor from left to right. mkTyConApp :: TyCon -> [Type] -> Type mkTyConApp tycon tys | isFunTyCon tycon , [_rep1,_rep2,ty1,ty2] <- tys = FunTy { ft_af = VisArg, ft_arg = ty1, ft_res = ty2 } -- The FunTyCon (->) is always a visible one | otherwise = TyConApp tycon tys -- splitTyConApp "looks through" synonyms, because they don't -- mean a distinct type, but all other type-constructor applications -- including functions are returned as Just .. -- | Retrieve the tycon heading this type, if there is one. Does /not/ -- look through synonyms. tyConAppTyConPicky_maybe :: Type -> Maybe TyCon tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc tyConAppTyConPicky_maybe (FunTy {}) = Just funTyCon tyConAppTyConPicky_maybe _ = Nothing -- | The same as @fst . splitTyConApp@ tyConAppTyCon_maybe :: Type -> Maybe TyCon tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty' tyConAppTyCon_maybe (TyConApp tc _) = Just tc tyConAppTyCon_maybe (FunTy {}) = Just funTyCon tyConAppTyCon_maybe _ = Nothing tyConAppTyCon :: Type -> TyCon tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) -- | The same as @snd . splitTyConApp@ tyConAppArgs_maybe :: Type -> Maybe [Type] tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty' tyConAppArgs_maybe (TyConApp _ tys) = Just tys tyConAppArgs_maybe (FunTy _ arg res) | Just rep1 <- getRuntimeRep_maybe arg , Just rep2 <- getRuntimeRep_maybe res = Just [rep1, rep2, arg, res] tyConAppArgs_maybe _ = Nothing tyConAppArgs :: Type -> [Type] tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) tyConAppArgN :: Int -> Type -> Type -- Executing Nth tyConAppArgN n ty = case tyConAppArgs_maybe ty of Just tys -> ASSERT2( tys `lengthExceeds` n, ppr n <+> ppr tys ) tys `getNth` n Nothing -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty) -- | Attempts to tease a type apart into a type constructor and the application -- of a number of arguments to that constructor. Panics if that is not possible. -- See also 'splitTyConApp_maybe' splitTyConApp :: Type -> (TyCon, [Type]) splitTyConApp ty = case splitTyConApp_maybe ty of Just stuff -> stuff Nothing -> pprPanic "splitTyConApp" (ppr ty) -- | Attempts to tease a type apart into a type constructor and the application -- of a number of arguments to that constructor splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty' splitTyConApp_maybe ty = repSplitTyConApp_maybe ty -- | Split a type constructor application into its type constructor and -- applied types. Note that this may fail in the case of a 'FunTy' with an -- argument of unknown kind 'FunTy' (e.g. @FunTy (a :: k) Int@. since the kind -- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your -- type before using this function. -- -- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'. tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) -- Defined here to avoid module loops between Unify and TcType. tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty' tcSplitTyConApp_maybe ty = repSplitTyConApp_maybe ty ------------------- repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -- ^ Like 'splitTyConApp_maybe', but doesn't look through synonyms. This -- assumes the synonyms have already been dealt with. -- -- Moreover, for a FunTy, it only succeeds if the argument types -- have enough info to extract the runtime-rep arguments that -- the funTyCon requires. This will usually be true; -- but may be temporarily false during canonicalization: -- see Note [FunTy and decomposing tycon applications] in TcCanonical -- repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) repSplitTyConApp_maybe (FunTy _ arg res) | Just arg_rep <- getRuntimeRep_maybe arg , Just res_rep <- getRuntimeRep_maybe res = Just (funTyCon, [arg_rep, res_rep, arg, res]) repSplitTyConApp_maybe _ = Nothing ------------------- -- | Attempts to tease a list type apart and gives the type of the elements if -- successful (looks through type synonyms) splitListTyConApp_maybe :: Type -> Maybe Type splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of Just (tc,[e]) | tc == listTyCon -> Just e _other -> Nothing nextRole :: Type -> Role nextRole ty | Just (tc, tys) <- splitTyConApp_maybe ty , let num_tys = length tys , num_tys < tyConArity tc = tyConRoles tc `getNth` num_tys | otherwise = Nominal newTyConInstRhs :: TyCon -> [Type] -> Type -- ^ Unwrap one 'layer' of newtype on a type constructor and its -- arguments, using an eta-reduced version of the @newtype@ if possible. -- This requires tys to have at least @newTyConInstArity tycon@ elements. newTyConInstRhs tycon tys = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs ) applyTysX tvs rhs tys where (tvs, rhs) = newTyConEtadRhs tycon {- --------------------------------------------------------------------- CastTy ~~~~~~ A casted type has its *kind* casted into something new. -} splitCastTy_maybe :: Type -> Maybe (Type, Coercion) splitCastTy_maybe ty | Just ty' <- coreView ty = splitCastTy_maybe ty' splitCastTy_maybe (CastTy ty co) = Just (ty, co) splitCastTy_maybe _ = Nothing -- | Make a 'CastTy'. The Coercion must be nominal. Checks the -- Coercion for reflexivity, dropping it if it's reflexive. -- See Note [Respecting definitional equality] in TyCoRep mkCastTy :: Type -> Coercion -> Type mkCastTy ty co | isReflexiveCo co = ty -- (EQ2) from the Note -- NB: Do the slow check here. This is important to keep the splitXXX -- functions working properly. Otherwise, we may end up with something -- like (((->) |> something_reflexive_but_not_obviously_so) biz baz) -- fails under splitFunTy_maybe. This happened with the cheaper check -- in test dependent/should_compile/dynamic-paper. mkCastTy (CastTy ty co1) co2 -- (EQ3) from the Note = mkCastTy ty (co1 `mkTransCo` co2) -- call mkCastTy again for the reflexivity check mkCastTy (ForAllTy (Bndr tv vis) inner_ty) co -- (EQ4) from the Note | isTyVar tv , let fvs = tyCoVarsOfCo co = -- have to make sure that pushing the co in doesn't capture the bound var! if tv `elemVarSet` fvs then let empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs) (subst, tv') = substVarBndr empty_subst tv in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mkCastTy` co) else ForAllTy (Bndr tv vis) (inner_ty `mkCastTy` co) mkCastTy ty co = CastTy ty co tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder] -- Return the tyConBinders in TyCoBinder form tyConBindersTyCoBinders = map to_tyb where to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) to_tyb (Bndr tv (AnonTCB af)) = Anon af (varType tv) -- | Drop the cast on a type, if any. If there is no -- cast, just return the original type. This is rarely what -- you want. The CastTy data constructor (in TyCoRep) has the -- invariant that another CastTy is not inside. See the -- data constructor for a full description of this invariant. -- Since CastTy cannot be nested, the result of discardCast -- cannot be a CastTy. discardCast :: Type -> Type discardCast (CastTy ty _) = ASSERT(not (isCastTy ty)) ty where isCastTy CastTy{} = True isCastTy _ = False discardCast ty = ty {- -------------------------------------------------------------------- CoercionTy ~~~~~~~~~~ CoercionTy allows us to inject coercions into types. A CoercionTy should appear only in the right-hand side of an application. -} mkCoercionTy :: Coercion -> Type mkCoercionTy = CoercionTy isCoercionTy :: Type -> Bool isCoercionTy (CoercionTy _) = True isCoercionTy _ = False isCoercionTy_maybe :: Type -> Maybe Coercion isCoercionTy_maybe (CoercionTy co) = Just co isCoercionTy_maybe _ = Nothing stripCoercionTy :: Type -> Coercion stripCoercionTy (CoercionTy co) = co stripCoercionTy ty = pprPanic "stripCoercionTy" (ppr ty) {- --------------------------------------------------------------------- SynTy ~~~~~ Notes on type synonyms ~~~~~~~~~~~~~~~~~~~~~~ The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try to return type synonyms wherever possible. Thus type Foo a = a -> a we want splitFunTys (a -> Foo a) = ([a], Foo a) not ([a], a -> a) The reason is that we then get better (shorter) type signatures in interfaces. Notably this plays a role in tcTySigs in TcBinds.hs. --------------------------------------------------------------------- ForAllTy ~~~~~~~~ -} -- | Make a dependent forall over an 'Inferred' variable mkTyCoInvForAllTy :: TyCoVar -> Type -> Type mkTyCoInvForAllTy tv ty | isCoVar tv , not (tv `elemVarSet` tyCoVarsOfType ty) = mkVisFunTy (varType tv) ty | otherwise = ForAllTy (Bndr tv Inferred) ty -- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar mkInvForAllTy :: TyVar -> Type -> Type mkInvForAllTy tv ty = ASSERT( isTyVar tv ) ForAllTy (Bndr tv Inferred) ty -- | Like 'mkForAllTys', but assumes all variables are dependent and -- 'Inferred', a common case mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs -- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar mkInvForAllTys :: [TyVar] -> Type -> Type mkInvForAllTys tvs ty = foldr mkInvForAllTy ty tvs -- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified', -- a common case mkSpecForAllTy :: TyVar -> Type -> Type mkSpecForAllTy tv ty = ASSERT( isTyVar tv ) -- covar is always Inferred, so input should be tyvar ForAllTy (Bndr tv Specified) ty -- | Like 'mkForAllTys', but assumes all variables are dependent and -- 'Specified', a common case mkSpecForAllTys :: [TyVar] -> Type -> Type mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs -- | Like mkForAllTys, but assumes all variables are dependent and visible mkVisForAllTys :: [TyVar] -> Type -> Type mkVisForAllTys tvs = ASSERT( all isTyVar tvs ) -- covar is always Inferred, so all inputs should be tyvar mkForAllTys [ Bndr tv Required | tv <- tvs ] mkLamType :: Var -> Type -> Type -- ^ Makes a @(->)@ type or an implicit forall type, depending -- on whether it is given a type variable or a term variable. -- This is used, for example, when producing the type of a lambda. -- Always uses Inferred binders. mkLamTypes :: [Var] -> Type -> Type -- ^ 'mkLamType' for multiple type or value arguments mkLamType v body_ty | isTyVar v = ForAllTy (Bndr v Inferred) body_ty | isCoVar v , v `elemVarSet` tyCoVarsOfType body_ty = ForAllTy (Bndr v Required) body_ty | isPredTy arg_ty -- See Note [mkLamType: dictionary arguments] = mkInvisFunTy arg_ty body_ty | otherwise = mkVisFunTy arg_ty body_ty where arg_ty = varType v mkLamTypes vs ty = foldr mkLamType ty vs {- Note [mkLamType: dictionary arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have (\ (d :: Ord a). blah), we want to give it type (Ord a => blah_ty) with a fat arrow; that is, using mkInvisFunTy, not mkVisFunTy. Why? After all, we are in Core, where (=>) and (->) behave the same. Yes, but the /specialiser/ does treat dictionary arguments specially. Suppose we do w/w on 'foo' in module A, thus (#11272, #6056) foo :: Ord a => Int -> blah foo a d x = case x of I# x' -> $wfoo @a d x' $wfoo :: Ord a => Int# -> blah Now in module B we see (foo @Int dOrdInt). The specialiser will specialise this to $sfoo, where $sfoo :: Int -> blah $sfoo x = case x of I# x' -> $wfoo @Int dOrdInt x' Now we /must/ also specialise $wfoo! But it wasn't user-written, and has a type built with mkLamTypes. Conclusion: the easiest thing is to make mkLamType build (c => ty) when the argument is a predicate type. See TyCoRep Note [Types for coercions, predicates, and evidence] -} -- | Given a list of type-level vars and the free vars of a result kind, -- makes TyCoBinders, preferring anonymous binders -- if the variable is, in fact, not dependent. -- e.g. mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k) -- We want (k:*) Named, (b:k) Anon, (c:k) Anon -- -- All non-coercion binders are /visible/. mkTyConBindersPreferAnon :: [TyVar] -- ^ binders -> TyCoVarSet -- ^ free variables of result -> [TyConBinder] mkTyConBindersPreferAnon vars inner_tkvs = ASSERT( all isTyVar vars) fst (go vars) where go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars go [] = ([], inner_tkvs) go (v:vs) | v `elemVarSet` fvs = ( Bndr v (NamedTCB Required) : binders , fvs `delVarSet` v `unionVarSet` kind_vars ) | otherwise = ( Bndr v (AnonTCB VisArg) : binders , fvs `unionVarSet` kind_vars ) where (binders, fvs) = go vs kind_vars = tyCoVarsOfType $ tyVarKind v -- | Take a ForAllTy apart, returning the list of tycovars and the result type. -- This always succeeds, even if it returns only an empty list. Note that the -- result type returned may have free variables that were bound by a forall. splitForAllTys :: Type -> ([TyCoVar], Type) splitForAllTys ty = split ty ty [] where split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs split _ (ForAllTy (Bndr tv _) ty) tvs = split ty ty (tv:tvs) split orig_ty _ tvs = (reverse tvs, orig_ty) -- | Like 'splitForAllTys', but only splits a 'ForAllTy' if -- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility -- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided -- as an argument to this function. splitForAllTysSameVis :: ArgFlag -> Type -> ([TyCoVar], Type) splitForAllTysSameVis supplied_argf ty = split ty ty [] where split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs split _ (ForAllTy (Bndr tv argf) ty) tvs | argf `sameVis` supplied_argf = split ty ty (tv:tvs) split orig_ty _ tvs = (reverse tvs, orig_ty) -- | Like splitForAllTys, but split only for tyvars. -- This always succeeds, even if it returns only an empty list. Note that the -- result type returned may have free variables that were bound by a forall. splitTyVarForAllTys :: Type -> ([TyVar], Type) splitTyVarForAllTys ty = split ty ty [] where split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs) split orig_ty _ tvs = (reverse tvs, orig_ty) -- | Checks whether this is a proper forall (with a named binder) isForAllTy :: Type -> Bool isForAllTy ty | Just ty' <- coreView ty = isForAllTy ty' isForAllTy (ForAllTy {}) = True isForAllTy _ = False -- | Like `isForAllTy`, but returns True only if it is a tyvar binder isForAllTy_ty :: Type -> Bool isForAllTy_ty ty | Just ty' <- coreView ty = isForAllTy_ty ty' isForAllTy_ty (ForAllTy (Bndr tv _) _) | isTyVar tv = True isForAllTy_ty _ = False -- | Like `isForAllTy`, but returns True only if it is a covar binder isForAllTy_co :: Type -> Bool isForAllTy_co ty | Just ty' <- coreView ty = isForAllTy_co ty' isForAllTy_co (ForAllTy (Bndr tv _) _) | isCoVar tv = True isForAllTy_co _ = False -- | Is this a function or forall? isPiTy :: Type -> Bool isPiTy ty | Just ty' <- coreView ty = isPiTy ty' isPiTy (ForAllTy {}) = True isPiTy (FunTy {}) = True isPiTy _ = False -- | Is this a function? isFunTy :: Type -> Bool isFunTy ty | Just ty' <- coreView ty = isFunTy ty' isFunTy (FunTy {}) = True isFunTy _ = False -- | Take a forall type apart, or panics if that is not possible. splitForAllTy :: Type -> (TyCoVar, Type) splitForAllTy ty | Just answer <- splitForAllTy_maybe ty = answer | otherwise = pprPanic "splitForAllTy" (ppr ty) -- | Drops all ForAllTys dropForAlls :: Type -> Type dropForAlls ty = go ty where go ty | Just ty' <- coreView ty = go ty' go (ForAllTy _ res) = go res go res = res -- | Attempts to take a forall type apart, but only if it's a proper forall, -- with a named binder splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type) splitForAllTy_maybe ty = go ty where go ty | Just ty' <- coreView ty = go ty' go (ForAllTy (Bndr tv _) ty) = Just (tv, ty) go _ = Nothing -- | Like splitForAllTy_maybe, but only returns Just if it is a tyvar binder. splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type) splitForAllTy_ty_maybe ty = go ty where go ty | Just ty' <- coreView ty = go ty' go (ForAllTy (Bndr tv _) ty) | isTyVar tv = Just (tv, ty) go _ = Nothing -- | Like splitForAllTy_maybe, but only returns Just if it is a covar binder. splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type) splitForAllTy_co_maybe ty = go ty where go ty | Just ty' <- coreView ty = go ty' go (ForAllTy (Bndr tv _) ty) | isCoVar tv = Just (tv, ty) go _ = Nothing -- | Attempts to take a forall type apart; works with proper foralls and -- functions splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type) splitPiTy_maybe ty = go ty where go ty | Just ty' <- coreView ty = go ty' go (ForAllTy bndr ty) = Just (Named bndr, ty) go (FunTy { ft_af = af, ft_arg = arg, ft_res = res}) = Just (Anon af arg, res) go _ = Nothing -- | Takes a forall type apart, or panics splitPiTy :: Type -> (TyCoBinder, Type) splitPiTy ty | Just answer <- splitPiTy_maybe ty = answer | otherwise = pprPanic "splitPiTy" (ppr ty) -- | Split off all TyCoBinders to a type, splitting both proper foralls -- and functions splitPiTys :: Type -> ([TyCoBinder], Type) splitPiTys ty = split ty ty [] where split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs split _ (ForAllTy b res) bs = split res res (Named b : bs) split _ (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) bs = split res res (Anon af arg : bs) split orig_ty _ bs = (reverse bs, orig_ty) -- | Like 'splitPiTys' but split off only /named/ binders -- and returns TyCoVarBinders rather than TyCoBinders splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type) splitForAllVarBndrs ty = split ty ty [] where split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs split _ (ForAllTy b res) bs = split res res (b:bs) split orig_ty _ bs = (reverse bs, orig_ty) {-# INLINE splitForAllVarBndrs #-} invisibleTyBndrCount :: Type -> Int -- Returns the number of leading invisible forall'd binders in the type -- Includes invisible predicate arguments; e.g. for -- e.g. forall {k}. (k ~ *) => k -> k -- returns 2 not 1 invisibleTyBndrCount ty = length (fst (splitPiTysInvisible ty)) -- Like splitPiTys, but returns only *invisible* binders, including constraints -- Stops at the first visible binder splitPiTysInvisible :: Type -> ([TyCoBinder], Type) splitPiTysInvisible ty = split ty ty [] where split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs split _ (ForAllTy b res) bs | Bndr _ vis <- b , isInvisibleArgFlag vis = split res res (Named b : bs) split _ (FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res }) bs = split res res (Anon InvisArg arg : bs) split orig_ty _ bs = (reverse bs, orig_ty) splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type) -- Same as splitPiTysInvisible, but stop when -- - you have found 'n' TyCoBinders, -- - or you run out of invisible binders splitPiTysInvisibleN n ty = split n ty ty [] where split n orig_ty ty bs | n == 0 = (reverse bs, orig_ty) | Just ty' <- coreView ty = split n orig_ty ty' bs | ForAllTy b res <- ty , Bndr _ vis <- b , isInvisibleArgFlag vis = split (n-1) res res (Named b : bs) | FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res } <- ty = split (n-1) res res (Anon InvisArg arg : bs) | otherwise = (reverse bs, orig_ty) -- | Given a 'TyCon' and a list of argument types, filter out any invisible -- (i.e., 'Inferred' or 'Specified') arguments. filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys -- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred' -- arguments. filterOutInferredTypes :: TyCon -> [Type] -> [Type] filterOutInferredTypes tc tys = filterByList (map (/= Inferred) $ tyConArgFlags tc tys) tys -- | Given a 'TyCon' and a list of argument types, partition the arguments -- into: -- -- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and -- -- 2. 'Required' (i.e., visible) arguments partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) partitionInvisibleTypes tc tys = partitionByList (map isInvisibleArgFlag $ tyConArgFlags tc tys) tys -- | Given a list of things paired with their visibilities, partition the -- things into (invisible things, visible things). partitionInvisibles :: [(a, ArgFlag)] -> ([a], [a]) partitionInvisibles = partitionWith pick_invis where pick_invis :: (a, ArgFlag) -> Either a a pick_invis (thing, vis) | isInvisibleArgFlag vis = Left thing | otherwise = Right thing -- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is -- applied, determine each argument's visibility -- ('Inferred', 'Specified', or 'Required'). -- -- Wrinkle: consider the following scenario: -- -- > T :: forall k. k -> k -- > tyConArgFlags T [forall m. m -> m -> m, S, R, Q] -- -- After substituting, we get -- -- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n -- -- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again, -- and @Q@ is visible. tyConArgFlags :: TyCon -> [Type] -> [ArgFlag] tyConArgFlags tc = fun_kind_arg_flags (tyConKind tc) -- | Given a 'Type' and a list of argument types to which the 'Type' is -- applied, determine each argument's visibility -- ('Inferred', 'Specified', or 'Required'). -- -- Most of the time, the arguments will be 'Required', but not always. Consider -- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is -- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely -- this sort of higher-rank situation in which 'appTyArgFlags' comes in handy, -- since @f Type Bool@ would be represented in Core using 'AppTy's. -- (See also #15792). appTyArgFlags :: Type -> [Type] -> [ArgFlag] appTyArgFlags ty = fun_kind_arg_flags (typeKind ty) -- | Given a function kind and a list of argument types (where each argument's -- kind aligns with the corresponding position in the argument kind), determine -- each argument's visibility ('Inferred', 'Specified', or 'Required'). fun_kind_arg_flags :: Kind -> [Type] -> [ArgFlag] fun_kind_arg_flags = go emptyTCvSubst where go subst ki arg_tys | Just ki' <- coreView ki = go subst ki' arg_tys go _ _ [] = [] go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys) = argf : go subst' res_ki arg_tys where subst' = extendTvSubst subst tv arg_ty go subst (TyVarTy tv) arg_tys | Just ki <- lookupTyVar subst tv = go subst ki arg_tys -- This FunTy case is important to handle kinds with nested foralls, such -- as this kind (inspired by #16518): -- -- forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type -- -- Here, we want to get the following ArgFlags: -- -- [Inferred, Specified, Required, Required, Specified, Required] -- forall {k1}. forall k2. k1 -> k2 -> forall k3. k3 -> Type go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys) = argf : go subst res_ki arg_tys where argf = case af of VisArg -> Required InvisArg -> Inferred go _ _ arg_tys = map (const Required) arg_tys -- something is ill-kinded. But this can happen -- when printing errors. Assume everything is Required. -- @isTauTy@ tests if a type has no foralls isTauTy :: Type -> Bool isTauTy ty | Just ty' <- coreView ty = isTauTy ty' isTauTy (TyVarTy _) = True isTauTy (LitTy {}) = True isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc isTauTy (AppTy a b) = isTauTy a && isTauTy b isTauTy (FunTy _ a b) = isTauTy a && isTauTy b isTauTy (ForAllTy {}) = False isTauTy (CastTy ty _) = isTauTy ty isTauTy (CoercionTy _) = False -- Not sure about this {- %************************************************************************ %* * TyCoBinders %* * %************************************************************************ -} -- | Make an anonymous binder mkAnonBinder :: AnonArgFlag -> Type -> TyCoBinder mkAnonBinder = Anon -- | Does this binder bind a variable that is /not/ erased? Returns -- 'True' for anonymous binders. isAnonTyCoBinder :: TyCoBinder -> Bool isAnonTyCoBinder (Named {}) = False isAnonTyCoBinder (Anon {}) = True tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyCoVar tyCoBinderVar_maybe (Named tv) = Just $ binderVar tv tyCoBinderVar_maybe _ = Nothing tyCoBinderType :: TyCoBinder -> Type tyCoBinderType (Named tvb) = binderType tvb tyCoBinderType (Anon _ ty) = ty tyBinderType :: TyBinder -> Type tyBinderType (Named (Bndr tv _)) = ASSERT( isTyVar tv ) tyVarKind tv tyBinderType (Anon _ ty) = ty -- | Extract a relevant type, if there is one. binderRelevantType_maybe :: TyCoBinder -> Maybe Type binderRelevantType_maybe (Named {}) = Nothing binderRelevantType_maybe (Anon _ ty) = Just ty ------------- Closing over kinds ----------------- -- | Add the kind variables free in the kinds of the tyvars in the given set. -- Returns a non-deterministic set. closeOverKinds :: TyVarSet -> TyVarSet closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet -- It's OK to use nonDetEltsUniqSet here because we immediately forget -- about the ordering by returning a set. -- | Given a list of tyvars returns a deterministic FV computation that -- returns the given tyvars with the kind variables free in the kinds of the -- given tyvars. closeOverKindsFV :: [TyVar] -> FV closeOverKindsFV tvs = mapUnionFV (tyCoFVsOfType . tyVarKind) tvs `unionFV` mkFVs tvs -- | Add the kind variables free in the kinds of the tyvars in the given set. -- Returns a deterministically ordered list. closeOverKindsList :: [TyVar] -> [TyVar] closeOverKindsList tvs = fvVarList $ closeOverKindsFV tvs -- | Add the kind variables free in the kinds of the tyvars in the given set. -- Returns a deterministic set. closeOverKindsDSet :: DTyVarSet -> DTyVarSet closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems {- ************************************************************************ * * \subsection{Type families} * * ************************************************************************ -} mkFamilyTyConApp :: TyCon -> [Type] -> Type -- ^ Given a family instance TyCon and its arg types, return the -- corresponding family type. E.g: -- -- > data family T a -- > data instance T (Maybe b) = MkT b -- -- Where the instance tycon is :RTL, so: -- -- > mkFamilyTyConApp :RTL Int = T (Maybe Int) mkFamilyTyConApp tc tys | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc , let tvs = tyConTyVars tc fam_subst = ASSERT2( tvs `equalLength` tys, ppr tc <+> ppr tys ) zipTvSubst tvs tys = mkTyConApp fam_tc (substTys fam_subst fam_tys) | otherwise = mkTyConApp tc tys -- | Get the type on the LHS of a coercion induced by a type/data -- family instance. coAxNthLHS :: CoAxiom br -> Int -> Type coAxNthLHS ax ind = mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind)) isFamFreeTy :: Type -> Bool isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty' isFamFreeTy (TyVarTy _) = True isFamFreeTy (LitTy {}) = True isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc isFamFreeTy (AppTy a b) = isFamFreeTy a && isFamFreeTy b isFamFreeTy (FunTy _ a b) = isFamFreeTy a && isFamFreeTy b isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty isFamFreeTy (CastTy ty _) = isFamFreeTy ty isFamFreeTy (CoercionTy _) = False -- Not sure about this -- | Does this type classify a core (unlifted) Coercion? -- At either role nominal or representational -- (t1 ~# t2) or (t1 ~R# t2) -- See Note [Types for coercions, predicates, and evidence] in TyCoRep isCoVarType :: Type -> Bool -- ToDo: should we check saturation? isCoVarType ty | Just tc <- tyConAppTyCon_maybe ty = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey | otherwise = False {- ************************************************************************ * * \subsection{Liftedness} * * ************************************************************************ -} -- | Returns Just True if this type is surely lifted, Just False -- if it is surely unlifted, Nothing if we can't be sure (i.e., it is -- levity polymorphic), and panics if the kind does not have the shape -- TYPE r. isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool isLiftedType_maybe ty = go (getRuntimeRep ty) where go rr | Just rr' <- coreView rr = go rr' | isLiftedRuntimeRep rr = Just True | TyConApp {} <- rr = Just False -- Everything else is unlifted | otherwise = Nothing -- levity polymorphic -- | See "Type#type_classification" for what an unlifted type is. -- Panics on levity polymorphic types; See 'mightBeUnliftedType' for -- a more approximate predicate that behaves better in the presence of -- levity polymorphism. isUnliftedType :: HasDebugCallStack => Type -> Bool -- isUnliftedType returns True for forall'd unlifted types: -- x :: forall a. Int# -- I found bindings like these were getting floated to the top level. -- They are pretty bogus types, mind you. It would be better never to -- construct them isUnliftedType ty = not (isLiftedType_maybe ty `orElse` pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))) -- | Returns: -- -- * 'False' if the type is /guaranteed/ lifted or -- * 'True' if it is unlifted, OR we aren't sure (e.g. in a levity-polymorphic case) mightBeUnliftedType :: Type -> Bool mightBeUnliftedType ty = case isLiftedType_maybe ty of Just is_lifted -> not is_lifted Nothing -> True -- | Is this a type of kind RuntimeRep? (e.g. LiftedRep) isRuntimeRepKindedTy :: Type -> Bool isRuntimeRepKindedTy = isRuntimeRepTy . typeKind -- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g. -- dropping 'LiftedRep arguments of unboxed tuple TyCon applications: -- -- dropRuntimeRepArgs [ 'LiftedRep, 'IntRep -- , String, Int# ] == [String, Int#] -- dropRuntimeRepArgs :: [Type] -> [Type] dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy -- | Extract the RuntimeRep classifier of a type. For instance, -- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not -- possible. getRuntimeRep_maybe :: HasDebugCallStack => Type -> Maybe Type getRuntimeRep_maybe = kindRep_maybe . typeKind -- | Extract the RuntimeRep classifier of a type. For instance, -- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible. getRuntimeRep :: HasDebugCallStack => Type -> Type getRuntimeRep ty = case getRuntimeRep_maybe ty of Just r -> r Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty)) isUnboxedTupleType :: Type -> Bool isUnboxedTupleType ty = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey -- NB: Do not use typePrimRep, as that can't tell the difference between -- unboxed tuples and unboxed sums isUnboxedSumType :: Type -> Bool isUnboxedSumType ty = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey -- | See "Type#type_classification" for what an algebraic type is. -- Should only be applied to /types/, as opposed to e.g. partially -- saturated type constructors isAlgType :: Type -> Bool isAlgType ty = case splitTyConApp_maybe ty of Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) isAlgTyCon tc _other -> False -- | Check whether a type is a data family type isDataFamilyAppType :: Type -> Bool isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of Just tc -> isDataFamilyTyCon tc _ -> False -- | Computes whether an argument (or let right hand side) should -- be computed strictly or lazily, based only on its type. -- Currently, it's just 'isUnliftedType'. Panics on levity-polymorphic types. isStrictType :: HasDebugCallStack => Type -> Bool isStrictType = isUnliftedType isPrimitiveType :: Type -> Bool -- ^ Returns true of types that are opaque to Haskell. isPrimitiveType ty = case splitTyConApp_maybe ty of Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) isPrimTyCon tc _ -> False {- ************************************************************************ * * \subsection{Join points} * * ************************************************************************ -} -- | Determine whether a type could be the type of a join point of given total -- arity, according to the polymorphism rule. A join point cannot be polymorphic -- in its return type, since given -- join j @a @b x y z = e1 in e2, -- the types of e1 and e2 must be the same, and a and b are not in scope for e2. -- (See Note [The polymorphism rule of join points] in CoreSyn.) Returns False -- also if the type simply doesn't have enough arguments. -- -- Note that we need to know how many arguments (type *and* value) the putative -- join point takes; for instance, if -- j :: forall a. a -> Int -- then j could be a binary join point returning an Int, but it could *not* be a -- unary join point returning a -> Int. -- -- TODO: See Note [Excess polymorphism and join points] isValidJoinPointType :: JoinArity -> Type -> Bool isValidJoinPointType arity ty = valid_under emptyVarSet arity ty where valid_under tvs arity ty | arity == 0 = isEmptyVarSet (tvs `intersectVarSet` tyCoVarsOfType ty) | Just (t, ty') <- splitForAllTy_maybe ty = valid_under (tvs `extendVarSet` t) (arity-1) ty' | Just (_, res_ty) <- splitFunTy_maybe ty = valid_under tvs (arity-1) res_ty | otherwise = False {- Note [Excess polymorphism and join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In principle, if a function would be a join point except that it fails the polymorphism rule (see Note [The polymorphism rule of join points] in CoreSyn), it can still be made a join point with some effort. This is because all tail calls must return the same type (they return to the same context!), and thus if the return type depends on an argument, that argument must always be the same. For instance, consider: let f :: forall a. a -> Char -> [a] f @a x c = ... f @a y 'a' ... in ... f @Int 1 'b' ... f @Int 2 'c' ... (where the calls are tail calls). `f` fails the polymorphism rule because its return type is [a], where [a] is bound. But since the type argument is always 'Int', we can rewrite it as: let f' :: Int -> Char -> [Int] f' x c = ... f' y 'a' ... in ... f' 1 'b' ... f 2 'c' ... and now we can make f' a join point: join f' :: Int -> Char -> [Int] f' x c = ... jump f' y 'a' ... in ... jump f' 1 'b' ... jump f' 2 'c' ... It's not clear that this comes up often, however. TODO: Measure how often and add this analysis if necessary. See #14620. ************************************************************************ * * \subsection{Sequencing on types} * * ************************************************************************ -} seqType :: Type -> () seqType (LitTy n) = n `seq` () seqType (TyVarTy tv) = tv `seq` () seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 seqType (FunTy _ t1 t2) = seqType t1 `seq` seqType t2 seqType (TyConApp tc tys) = tc `seq` seqTypes tys seqType (ForAllTy (Bndr tv _) ty) = seqType (varType tv) `seq` seqType ty seqType (CastTy ty co) = seqType ty `seq` seqCo co seqType (CoercionTy co) = seqCo co seqTypes :: [Type] -> () seqTypes [] = () seqTypes (ty:tys) = seqType ty `seq` seqTypes tys {- ************************************************************************ * * Comparison for types (We don't use instances so that we know where it happens) * * ************************************************************************ Note [Equality on AppTys] ~~~~~~~~~~~~~~~~~~~~~~~~~ In our cast-ignoring equality, we want to say that the following two are equal: (Maybe |> co) (Int |> co') ~? Maybe Int But the left is an AppTy while the right is a TyConApp. The solution is to use repSplitAppTy_maybe to break up the TyConApp into its pieces and then continue. Easy to do, but also easy to forget to do. -} eqType :: Type -> Type -> Bool -- ^ Type equality on source types. Does not look through @newtypes@ or -- 'PredType's, but it does look through type synonyms. -- This first checks that the kinds of the types are equal and then -- checks whether the types are equal, ignoring casts and coercions. -- (The kind check is a recursive call, but since all kinds have type -- @Type@, there is no need to check the types of kinds.) -- See also Note [Non-trivial definitional equality] in TyCoRep. eqType t1 t2 = isEqual $ nonDetCmpType t1 t2 -- It's OK to use nonDetCmpType here and eqType is deterministic, -- nonDetCmpType does equality deterministically -- | Compare types with respect to a (presumably) non-empty 'RnEnv2'. eqTypeX :: RnEnv2 -> Type -> Type -> Bool eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2 -- It's OK to use nonDetCmpType here and eqTypeX is deterministic, -- nonDetCmpTypeX does equality deterministically -- | Type equality on lists of types, looking through type synonyms -- but not newtypes. eqTypes :: [Type] -> [Type] -> Bool eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2 -- It's OK to use nonDetCmpType here and eqTypes is deterministic, -- nonDetCmpTypes does equality deterministically eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2 -- Check that the var lists are the same length -- and have matching kinds; if so, extend the RnEnv2 -- Returns Nothing if they don't match eqVarBndrs env [] [] = Just env eqVarBndrs env (tv1:tvs1) (tv2:tvs2) | eqTypeX env (varType tv1) (varType tv2) = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 eqVarBndrs _ _ _= Nothing -- Now here comes the real worker {- Note [nonDetCmpType nondeterminism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for ordering leads to nondeterminism. We hit the same problem in the TyVarTy case, comparing type variables is nondeterministic, note the call to nonDetCmpVar in nonDetCmpTypeX. See Note [Unique Determinism] for more details. -} nonDetCmpType :: Type -> Type -> Ordering nonDetCmpType t1 t2 -- we know k1 and k2 have the same kind, because they both have kind *. = nonDetCmpTypeX rn_env t1 t2 where rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) nonDetCmpTypes :: [Type] -> [Type] -> Ordering nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2 where rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2))) -- | An ordering relation between two 'Type's (known below as @t1 :: k1@ -- and @t2 :: k2@) data TypeOrdering = TLT -- ^ @t1 < t2@ | TEQ -- ^ @t1 ~ t2@ and there are no casts in either, -- therefore we can conclude @k1 ~ k2@ | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so -- they may differ in kind. | TGT -- ^ @t1 > t2@ deriving (Eq, Ord, Enum, Bounded) nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse -- See Note [Non-trivial definitional equality] in TyCoRep nonDetCmpTypeX env orig_t1 orig_t2 = case go env orig_t1 orig_t2 of -- If there are casts then we also need to do a comparison of the kinds of -- the types being compared TEQX -> toOrdering $ go env k1 k2 ty_ordering -> toOrdering ty_ordering where k1 = typeKind orig_t1 k2 = typeKind orig_t2 toOrdering :: TypeOrdering -> Ordering toOrdering TLT = LT toOrdering TEQ = EQ toOrdering TEQX = EQ toOrdering TGT = GT liftOrdering :: Ordering -> TypeOrdering liftOrdering LT = TLT liftOrdering EQ = TEQ liftOrdering GT = TGT thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering thenCmpTy TEQ rel = rel thenCmpTy TEQX rel = hasCast rel thenCmpTy rel _ = rel hasCast :: TypeOrdering -> TypeOrdering hasCast TEQ = TEQX hasCast rel = rel -- Returns both the resulting ordering relation between the two types -- and whether either contains a cast. go :: RnEnv2 -> Type -> Type -> TypeOrdering go env t1 t2 | Just t1' <- coreView t1 = go env t1' t2 | Just t2' <- coreView t2 = go env t1 t2' go env (TyVarTy tv1) (TyVarTy tv2) = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2 go env (ForAllTy (Bndr tv1 _) t1) (ForAllTy (Bndr tv2 _) t2) = go env (varType tv1) (varType tv2) `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 -- See Note [Equality on AppTys] go env (AppTy s1 t1) ty2 | Just (s2, t2) <- repSplitAppTy_maybe ty2 = go env s1 s2 `thenCmpTy` go env t1 t2 go env ty1 (AppTy s2 t2) | Just (s1, t1) <- repSplitAppTy_maybe ty1 = go env s1 s2 `thenCmpTy` go env t1 t2 go env (FunTy _ s1 t1) (FunTy _ s2 t2) = go env s1 s2 `thenCmpTy` go env t1 t2 go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 go _ (LitTy l1) (LitTy l2) = liftOrdering (compare l1 l2) go env (CastTy t1 _) t2 = hasCast $ go env t1 t2 go env t1 (CastTy t2 _) = hasCast $ go env t1 t2 go _ (CoercionTy {}) (CoercionTy {}) = TEQ -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy go _ ty1 ty2 = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2) where get_rank :: Type -> Int get_rank (CastTy {}) = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2]) get_rank (TyVarTy {}) = 0 get_rank (CoercionTy {}) = 1 get_rank (AppTy {}) = 3 get_rank (LitTy {}) = 4 get_rank (TyConApp {}) = 5 get_rank (FunTy {}) = 6 get_rank (ForAllTy {}) = 7 gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering gos _ [] [] = TEQ gos _ [] _ = TLT gos _ _ [] = TGT gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2 ------------- nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering nonDetCmpTypesX _ [] [] = EQ nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 `thenCmp` nonDetCmpTypesX env tys1 tys2 nonDetCmpTypesX _ [] _ = LT nonDetCmpTypesX _ _ [] = GT ------------- -- | Compare two 'TyCon's. NB: This should /never/ see 'Constraint' (as -- recognized by Kind.isConstraintKindCon) which is considered a synonym for -- 'Type' in Core. -- See Note [Kind Constraint and kind Type] in Kind. -- See Note [nonDetCmpType nondeterminism] nonDetCmpTc :: TyCon -> TyCon -> Ordering nonDetCmpTc tc1 tc2 = ASSERT( not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2) ) u1 `nonDetCmpUnique` u2 where u1 = tyConUnique tc1 u2 = tyConUnique tc2 {- ************************************************************************ * * The kind of a type * * ************************************************************************ Note [typeKind vs tcTypeKind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have two functions to get the kind of a type * typeKind ignores the distinction between Constraint and * * tcTypeKind respects the distinction between Constraint and * tcTypeKind is used by the type inference engine, for which Constraint and * are different; after that we use typeKind. See also Note [coreView vs tcView] Note [Kinding rules for types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In typeKind we consider Constraint and (TYPE LiftedRep) to be identical. We then have t1 : TYPE rep1 t2 : TYPE rep2 (FUN) ---------------- t1 -> t2 : Type ty : TYPE rep `a` is not free in rep (FORALL) ----------------------- forall a. ty : TYPE rep In tcTypeKind we consider Constraint and (TYPE LiftedRep) to be distinct: t1 : TYPE rep1 t2 : TYPE rep2 (FUN) ---------------- t1 -> t2 : Type t1 : Constraint t2 : TYPE rep (PRED1) ---------------- t1 => t2 : Type t1 : Constraint t2 : Constraint (PRED2) --------------------- t1 => t2 : Constraint ty : TYPE rep `a` is not free in rep (FORALL1) ----------------------- forall a. ty : TYPE rep ty : Constraint (FORALL2) ------------------------- forall a. ty : Constraint Note that: * The only way we distinguish '->' from '=>' is by the fact that the argument is a PredTy. Both are FunTys Note [Phantom type variables in kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider type K (r :: RuntimeRep) = Type -- Note 'r' is unused data T r :: K r -- T :: forall r -> K r foo :: forall r. T r The body of the forall in foo's type has kind (K r), and normally it would make no sense to have forall r. (ty :: K r) because the kind of the forall would escape the binding of 'r'. But in this case it's fine because (K r) exapands to Type, so we expliclity /permit/ the type forall r. T r To accommodate such a type, in typeKind (forall a.ty) we use occCheckExpand to expand any type synonyms in the kind of 'ty' to eliminate 'a'. See kinding rule (FORALL) in Note [Kinding rules for types] And in TcValidity.checkEscapingKind, we use also use occCheckExpand, for the same reason. -} ----------------------------- typeKind :: HasDebugCallStack => Type -> Kind -- No need to expand synonyms typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys typeKind (LitTy l) = typeLiteralKind l typeKind (FunTy {}) = liftedTypeKind typeKind (TyVarTy tyvar) = tyVarKind tyvar typeKind (CastTy _ty co) = pSnd $ coercionKind co typeKind (CoercionTy co) = coercionType co typeKind (AppTy fun arg) = go fun [arg] where -- Accumulate the type arugments, so we can call piResultTys, -- rather than a succession of calls to piResultTy (which is -- asymptotically costly as the number of arguments increases) go (AppTy fun arg) args = go fun (arg:args) go fun args = piResultTys (typeKind fun) args typeKind ty@(ForAllTy {}) = case occCheckExpand tvs body_kind of -- We must make sure tv does not occur in kind -- As it is already out of scope! -- See Note [Phantom type variables in kinds] Just k' -> k' Nothing -> pprPanic "typeKind" (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) where (tvs, body) = splitTyVarForAllTys ty body_kind = typeKind body --------------------------------------------- -- Utilities to be used in Unify, which uses "tc" functions --------------------------------------------- tcTypeKind :: HasDebugCallStack => Type -> Kind -- No need to expand synonyms tcTypeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys tcTypeKind (LitTy l) = typeLiteralKind l tcTypeKind (TyVarTy tyvar) = tyVarKind tyvar tcTypeKind (CastTy _ty co) = pSnd $ coercionKind co tcTypeKind (CoercionTy co) = coercionType co tcTypeKind (FunTy { ft_af = af, ft_res = res }) | InvisArg <- af , tcIsConstraintKind (tcTypeKind res) = constraintKind -- Eq a => Ord a :: Constraint | otherwise -- Eq a => a -> a :: TYPE LiftedRep = liftedTypeKind -- Eq a => Array# Int :: Type LiftedRep (not TYPE PtrRep) tcTypeKind (AppTy fun arg) = go fun [arg] where -- Accumulate the type arugments, so we can call piResultTys, -- rather than a succession of calls to piResultTy (which is -- asymptotically costly as the number of arguments increases) go (AppTy fun arg) args = go fun (arg:args) go fun args = piResultTys (tcTypeKind fun) args tcTypeKind ty@(ForAllTy {}) | tcIsConstraintKind body_kind = constraintKind | otherwise = case occCheckExpand tvs body_kind of -- We must make sure tv does not occur in kind -- As it is already out of scope! -- See Note [Phantom type variables in kinds] Just k' -> k' Nothing -> pprPanic "tcTypeKind" (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) where (tvs, body) = splitTyVarForAllTys ty body_kind = tcTypeKind body isPredTy :: HasDebugCallStack => Type -> Bool -- See Note [Types for coercions, predicates, and evidence] in TyCoRep isPredTy ty = tcIsConstraintKind (tcTypeKind ty) -- tcIsConstraintKind stuff only makes sense in the typechecker -- After that Constraint = Type -- See Note [coreView vs tcView] -- Defined here because it is used in isPredTy and tcRepSplitAppTy_maybe (sigh) tcIsConstraintKind :: Kind -> Bool tcIsConstraintKind ty | Just (tc, args) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here , isConstraintKindCon tc = ASSERT2( null args, ppr ty ) True | otherwise = False -- | Is this kind equivalent to @*@? -- -- This considers 'Constraint' to be distinct from @*@. For a version that -- treats them as the same type, see 'isLiftedTypeKind'. tcIsLiftedTypeKind :: Kind -> Bool tcIsLiftedTypeKind ty | Just (tc, [arg]) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here , tc `hasKey` tYPETyConKey = isLiftedRuntimeRep arg | otherwise = False -- | Is this kind equivalent to @TYPE r@ (for some unknown r)? -- -- This considers 'Constraint' to be distinct from @*@. tcIsRuntimeTypeKind :: Kind -> Bool tcIsRuntimeTypeKind ty | Just (tc, _) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here , tc `hasKey` tYPETyConKey = True | otherwise = False tcReturnsConstraintKind :: Kind -> Bool -- True <=> the Kind ultimately returns a Constraint -- E.g. * -> Constraint -- forall k. k -> Constraint tcReturnsConstraintKind kind | Just kind' <- tcView kind = tcReturnsConstraintKind kind' tcReturnsConstraintKind (ForAllTy _ ty) = tcReturnsConstraintKind ty tcReturnsConstraintKind (FunTy { ft_res = ty }) = tcReturnsConstraintKind ty tcReturnsConstraintKind (TyConApp tc _) = isConstraintKindCon tc tcReturnsConstraintKind _ = False -------------------------- typeLiteralKind :: TyLit -> Kind typeLiteralKind (NumTyLit {}) = typeNatKind typeLiteralKind (StrTyLit {}) = typeSymbolKind -- | Returns True if a type is levity polymorphic. Should be the same -- as (isKindLevPoly . typeKind) but much faster. -- Precondition: The type has kind (TYPE blah) isTypeLevPoly :: Type -> Bool isTypeLevPoly = go where go ty@(TyVarTy {}) = check_kind ty go ty@(AppTy {}) = check_kind ty go ty@(TyConApp tc _) | not (isTcLevPoly tc) = False | otherwise = check_kind ty go (ForAllTy _ ty) = go ty go (FunTy {}) = False go (LitTy {}) = False go ty@(CastTy {}) = check_kind ty go ty@(CoercionTy {}) = pprPanic "isTypeLevPoly co" (ppr ty) check_kind = isKindLevPoly . typeKind -- | Looking past all pi-types, is the end result potentially levity polymorphic? -- Example: True for (forall r (a :: TYPE r). String -> a) -- Example: False for (forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type) resultIsLevPoly :: Type -> Bool resultIsLevPoly = isTypeLevPoly . snd . splitPiTys {- ********************************************************************** * * Occurs check expansion %* * %********************************************************************* -} {- Note [Occurs check expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (occurCheckExpand tv xi) expands synonyms in xi just enough to get rid of occurrences of tv outside type function arguments, if that is possible; otherwise, it returns Nothing. For example, suppose we have type F a b = [a] Then occCheckExpand b (F Int b) = Just [Int] but occCheckExpand a (F a Int) = Nothing We don't promise to do the absolute minimum amount of expanding necessary, but we try not to do expansions we don't need to. We prefer doing inner expansions first. For example, type F a b = (a, Int, a, [a]) type G b = Char We have occCheckExpand b (F (G b)) = Just (F Char) even though we could also expand F to get rid of b. -} occCheckExpand :: [Var] -> Type -> Maybe Type -- See Note [Occurs check expansion] -- We may have needed to do some type synonym unfolding in order to -- get rid of the variable (or forall), so we also return the unfolded -- version of the type, which is guaranteed to be syntactically free -- of the given type variable. If the type is already syntactically -- free of the variable, then the same type is returned. occCheckExpand vs_to_avoid ty | null vs_to_avoid -- Efficient shortcut = Just ty -- Can happen, eg. CoreUtils.mkSingleAltCase | otherwise = go (mkVarSet vs_to_avoid, emptyVarEnv) ty where go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type -- The VarSet is the set of variables we are trying to avoid -- The VarEnv carries mappings necessary -- because of kind expansion go cxt@(as, env) (TyVarTy tv') | tv' `elemVarSet` as = Nothing | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'') | otherwise = do { tv'' <- go_var cxt tv' ; return (mkTyVarTy tv'') } go _ ty@(LitTy {}) = return ty go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1 ; ty2' <- go cxt ty2 ; return (mkAppTy ty1' ty2') } go cxt ty@(FunTy _ ty1 ty2) = do { ty1' <- go cxt ty1 ; ty2' <- go cxt ty2 ; return (ty { ft_arg = ty1', ft_res = ty2' }) } go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty) = do { ki' <- go cxt (varType tv) ; let tv' = setVarType tv ki' env' = extendVarEnv env tv tv' as' = as `delVarSet` tv ; body' <- go (as', env') body_ty ; return (ForAllTy (Bndr tv' vis) body') } -- For a type constructor application, first try expanding away the -- offending variable from the arguments. If that doesn't work, next -- see if the type constructor is a type synonym, and if so, expand -- it and try again. go cxt ty@(TyConApp tc tys) = case mapM (go cxt) tys of Just tys' -> return (mkTyConApp tc tys') Nothing | Just ty' <- tcView ty -> go cxt ty' | otherwise -> Nothing -- Failing that, try to expand a synonym go cxt (CastTy ty co) = do { ty' <- go cxt ty ; co' <- go_co cxt co ; return (mkCastTy ty' co') } go cxt (CoercionTy co) = do { co' <- go_co cxt co ; return (mkCoercionTy co') } ------------------ go_var cxt v = do { k' <- go cxt (varType v) ; return (setVarType v k') } -- Works for TyVar and CoVar -- See Note [Occurrence checking: look inside kinds] ------------------ go_mco _ MRefl = return MRefl go_mco ctx (MCo co) = MCo <$> go_co ctx co ------------------ go_co cxt (Refl ty) = do { ty' <- go cxt ty ; return (mkNomReflCo ty') } go_co cxt (GRefl r ty mco) = do { mco' <- go_mco cxt mco ; ty' <- go cxt ty ; return (mkGReflCo r ty' mco') } -- Note: Coercions do not contain type synonyms go_co cxt (TyConAppCo r tc args) = do { args' <- mapM (go_co cxt) args ; return (mkTyConAppCo r tc args') } go_co cxt (AppCo co arg) = do { co' <- go_co cxt co ; arg' <- go_co cxt arg ; return (mkAppCo co' arg') } go_co cxt@(as, env) (ForAllCo tv kind_co body_co) = do { kind_co' <- go_co cxt kind_co ; let tv' = setVarType tv $ pFst (coercionKind kind_co') env' = extendVarEnv env tv tv' as' = as `delVarSet` tv ; body' <- go_co (as', env') body_co ; return (ForAllCo tv' kind_co' body') } go_co cxt (FunCo r co1 co2) = do { co1' <- go_co cxt co1 ; co2' <- go_co cxt co2 ; return (mkFunCo r co1' co2') } go_co cxt@(as,env) (CoVarCo c) | c `elemVarSet` as = Nothing | Just c' <- lookupVarEnv env c = return (mkCoVarCo c') | otherwise = do { c' <- go_var cxt c ; return (mkCoVarCo c') } go_co cxt (HoleCo h) = do { c' <- go_var cxt (ch_co_var h) ; return (HoleCo (h { ch_co_var = c' })) } go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args ; return (mkAxiomInstCo ax ind args') } go_co cxt (UnivCo p r ty1 ty2) = do { p' <- go_prov cxt p ; ty1' <- go cxt ty1 ; ty2' <- go cxt ty2 ; return (mkUnivCo p' r ty1' ty2') } go_co cxt (SymCo co) = do { co' <- go_co cxt co ; return (mkSymCo co') } go_co cxt (TransCo co1 co2) = do { co1' <- go_co cxt co1 ; co2' <- go_co cxt co2 ; return (mkTransCo co1' co2') } go_co cxt (NthCo r n co) = do { co' <- go_co cxt co ; return (mkNthCo r n co') } go_co cxt (LRCo lr co) = do { co' <- go_co cxt co ; return (mkLRCo lr co') } go_co cxt (InstCo co arg) = do { co' <- go_co cxt co ; arg' <- go_co cxt arg ; return (mkInstCo co' arg') } go_co cxt (KindCo co) = do { co' <- go_co cxt co ; return (mkKindCo co') } go_co cxt (SubCo co) = do { co' <- go_co cxt co ; return (mkSubCo co') } go_co cxt (AxiomRuleCo ax cs) = do { cs' <- mapM (go_co cxt) cs ; return (mkAxiomRuleCo ax cs') } ------------------ go_prov _ UnsafeCoerceProv = return UnsafeCoerceProv go_prov cxt (PhantomProv co) = PhantomProv <$> go_co cxt co go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co go_prov _ p@(PluginProv _) = return p {- %************************************************************************ %* * Miscellaneous functions %* * %************************************************************************ -} -- | All type constructors occurring in the type; looking through type -- synonyms, but not newtypes. -- When it finds a Class, it returns the class TyCon. tyConsOfType :: Type -> UniqSet TyCon tyConsOfType ty = go ty where go :: Type -> UniqSet TyCon -- The UniqSet does duplicate elim go ty | Just ty' <- coreView ty = go ty' go (TyVarTy {}) = emptyUniqSet go (LitTy {}) = emptyUniqSet go (TyConApp tc tys) = go_tc tc `unionUniqSets` go_s tys go (AppTy a b) = go a `unionUniqSets` go b go (FunTy _ a b) = go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon go (ForAllTy (Bndr tv _) ty) = go ty `unionUniqSets` go (varType tv) go (CastTy ty co) = go ty `unionUniqSets` go_co co go (CoercionTy co) = go_co co go_co (Refl ty) = go ty go_co (GRefl _ ty mco) = go ty `unionUniqSets` go_mco mco go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co go_co (FunCo _ co1 co2) = go_co co1 `unionUniqSets` go_co co2 go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args go_co (UnivCo p _ t1 t2) = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2 go_co (CoVarCo {}) = emptyUniqSet go_co (HoleCo {}) = emptyUniqSet go_co (SymCo co) = go_co co go_co (TransCo co1 co2) = go_co co1 `unionUniqSets` go_co co2 go_co (NthCo _ _ co) = go_co co go_co (LRCo _ co) = go_co co go_co (InstCo co arg) = go_co co `unionUniqSets` go_co arg go_co (KindCo co) = go_co co go_co (SubCo co) = go_co co go_co (AxiomRuleCo _ cs) = go_cos cs go_mco MRefl = emptyUniqSet go_mco (MCo co) = go_co co go_prov UnsafeCoerceProv = emptyUniqSet go_prov (PhantomProv co) = go_co co go_prov (ProofIrrelProv co) = go_co co go_prov (PluginProv _) = emptyUniqSet -- this last case can happen from the tyConsOfType used from -- checkTauTvUpdate go_s tys = foldr (unionUniqSets . go) emptyUniqSet tys go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos go_tc tc = unitUniqSet tc go_ax ax = go_tc $ coAxiomTyCon ax -- | Find the result 'Kind' of a type synonym, -- after applying it to its 'arity' number of type variables -- Actually this function works fine on data types too, -- but they'd always return '*', so we never need to ask synTyConResKind :: TyCon -> Kind synTyConResKind tycon = piResultTys (tyConKind tycon) (mkTyVarTys (tyConTyVars tycon)) -- | Retrieve the free variables in this type, splitting them based -- on whether they are used visibly or invisibly. Invisible ones come -- first. splitVisVarsOfType :: Type -> Pair TyCoVarSet splitVisVarsOfType orig_ty = Pair invis_vars vis_vars where Pair invis_vars1 vis_vars = go orig_ty invis_vars = invis_vars1 `minusVarSet` vis_vars go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) go (AppTy t1 t2) = go t1 `mappend` go t2 go (TyConApp tc tys) = go_tc tc tys go (FunTy _ t1 t2) = go t1 `mappend` go t2 go (ForAllTy (Bndr tv _) ty) = ((`delVarSet` tv) <$> go ty) `mappend` (invisible (tyCoVarsOfType $ varType tv)) go (LitTy {}) = mempty go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co) go (CoercionTy co) = invisible $ tyCoVarsOfCo co invisible vs = Pair vs emptyVarSet go_tc tc tys = let (invis, vis) = partitionInvisibleTypes tc tys in invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet splitVisVarsOfTypes = foldMap splitVisVarsOfType modifyJoinResTy :: Int -- Number of binders to skip -> (Type -> Type) -- Function to apply to result type -> Type -- Type of join point -> Type -- New type -- INVARIANT: If any of the first n binders are foralls, those tyvars cannot -- appear in the original result type. See isValidJoinPointType. modifyJoinResTy orig_ar f orig_ty = go orig_ar orig_ty where go 0 ty = f ty go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty = mkPiTy arg_bndr (go (n-1) res_ty) | otherwise = pprPanic "modifyJoinResTy" (ppr orig_ar <+> ppr orig_ty) setJoinResTy :: Int -- Number of binders to skip -> Type -- New result type -> Type -- Type of join point -> Type -- New type -- INVARIANT: Same as for modifyJoinResTy setJoinResTy ar new_res_ty ty = modifyJoinResTy ar (const new_res_ty) ty {- ************************************************************************ * * Functions over Kinds * * ************************************************************************ Note [Kind Constraint and kind Type] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The kind Constraint is the kind of classes and other type constraints. The special thing about types of kind Constraint is that * They are displayed with double arrow: f :: Ord a => a -> a * They are implicitly instantiated at call sites; so the type inference engine inserts an extra argument of type (Ord a) at every call site to f. However, once type inference is over, there is *no* distinction between Constraint and Type. Indeed we can have coercions between the two. Consider class C a where op :: a -> a For this single-method class we may generate a newtype, which in turn generates an axiom witnessing C a ~ (a -> a) so on the left we have Constraint, and on the right we have Type. See #7451. Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with distinct uniques, they are treated as equal at all times except during type inference. -} isConstraintKindCon :: TyCon -> Bool isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey -- | Tests whether the given kind (which should look like @TYPE x@) -- is something other than a constructor tree (that is, constructors at every node). -- E.g. True of TYPE k, TYPE (F Int) -- False of TYPE 'LiftedRep isKindLevPoly :: Kind -> Bool isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k ) -- the isLiftedTypeKind check is necessary b/c of Constraint go k where go ty | Just ty' <- coreView ty = go ty' go TyVarTy{} = True go AppTy{} = True -- it can't be a TyConApp go (TyConApp tc tys) = isFamilyTyCon tc || any go tys go ForAllTy{} = True go (FunTy _ t1 t2) = go t1 || go t2 go LitTy{} = False go CastTy{} = True go CoercionTy{} = True _is_type = classifiesTypeWithValues k ----------------------------------------- -- Subkinding -- The tc variants are used during type-checking, where ConstraintKind -- is distinct from all other kinds -- After type-checking (in core), Constraint and liftedTypeKind are -- indistinguishable -- | Does this classify a type allowed to have values? Responds True to things -- like *, #, TYPE Lifted, TYPE v, Constraint. classifiesTypeWithValues :: Kind -> Bool -- ^ True of any sub-kind of OpenTypeKind classifiesTypeWithValues k = isJust (kindRep_maybe k) {- %************************************************************************ %* * Pretty-printing %* * %************************************************************************ Most pretty-printing is either in TyCoRep or IfaceType. -} -- | Does a 'TyCon' (that is applied to some number of arguments) need to be -- ascribed with an explicit kind signature to resolve ambiguity if rendered as -- a source-syntax type? -- (See @Note [When does a tycon application need an explicit kind signature?]@ -- for a full explanation of what this function checks for.) tyConAppNeedsKindSig :: Bool -- ^ Should specified binders count towards injective positions in -- the kind of the TyCon? (If you're using visible kind -- applications, then you want True here. -> TyCon -> Int -- ^ The number of args the 'TyCon' is applied to. -> Bool -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the -- number of arguments) tyConAppNeedsKindSig spec_inj_pos tc n_args | LT <- listLengthCmp tc_binders n_args = False | otherwise = let (dropped_binders, remaining_binders) = splitAt n_args tc_binders result_kind = mkTyConKind remaining_binders tc_res_kind result_vars = tyCoVarsOfType result_kind dropped_vars = fvVarSet $ mapUnionFV injective_vars_of_binder dropped_binders in not (subVarSet result_vars dropped_vars) where tc_binders = tyConBinders tc tc_res_kind = tyConResKind tc -- Returns the variables that would be fixed by knowing a TyConBinder. See -- Note [When does a tycon application need an explicit kind signature?] -- for a more detailed explanation of what this function does. injective_vars_of_binder :: TyConBinder -> FV injective_vars_of_binder (Bndr tv vis) = case vis of AnonTCB VisArg -> injectiveVarsOfType False -- conservative choice (varType tv) NamedTCB argf | source_of_injectivity argf -> unitFV tv `unionFV` injectiveVarsOfType False (varType tv) _ -> emptyFV source_of_injectivity Required = True source_of_injectivity Specified = spec_inj_pos source_of_injectivity Inferred = False {- Note [When does a tycon application need an explicit kind signature?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are a couple of places in GHC where we convert Core Types into forms that more closely resemble user-written syntax. These include: 1. Template Haskell Type reification (see, for instance, TcSplice.reify_tc_app) 2. Converting Types to LHsTypes (in GHC.Hs.Utils.typeToLHsType, or in Haddock) This conversion presents a challenge: how do we ensure that the resulting type has enough kind information so as not to be ambiguous? To better motivate this question, consider the following Core type: -- Foo :: Type -> Type type Foo = Proxy Type There is nothing ambiguous about the RHS of Foo in Core. But if we were to, say, reify it into a TH Type, then it's tempting to just drop the invisible Type argument and simply return `Proxy`. But now we've lost crucial kind information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool` or `Proxy Int` or something else! We've inadvertently introduced ambiguity. Unlike in other situations in GHC, we can't just turn on -fprint-explicit-kinds, as we need to produce something which has the same structure as a source-syntax type. Moreover, we can't rely on visible kind application, since the first kind argument to Proxy is inferred, not specified. Our solution is to annotate certain tycons with their kinds whenever they appear in applied form in order to resolve the ambiguity. For instance, we would reify the RHS of Foo like so: type Foo = (Proxy :: Type -> Type) We need to devise an algorithm that determines precisely which tycons need these explicit kind signatures. We certainly don't want to annotate _every_ tycon with a kind signature, or else we might end up with horribly bloated types like the following: (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type) We only want to annotate tycons that absolutely require kind signatures in order to resolve some sort of ambiguity, and nothing more. Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type require a kind signature? It might require it when we need to fill in any of T's omitted arguments. By "omitted argument", we mean one that is dropped when reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and specified arguments (e.g., TH reification in TcSplice), and sometimes the omitted arguments are only the inferred ones (e.g., in GHC.Hs.Utils.typeToLHsType, which reifies specified arguments through visible kind application). Regardless, the key idea is that _some_ arguments are going to be omitted after reification, and the only mechanism we have at our disposal for filling them in is through explicit kind signatures. What do we mean by "fill in"? Let's consider this small example: T :: forall {k}. Type -> (k -> Type) -> k Moreover, we have this application of T: T @{j} Int aty When we reify this type, we omit the inferred argument @{j}. Is it fixed by the other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then we'll generate an equality constraint (kappa -> Type) and, assuming we can solve it, that will fix `kappa`. (Here, `kappa` is the unification variable that we instantiate `k` with.) Therefore, for any application of a tycon T to some arguments, the Question We Must Answer is: * Given the first n arguments of T, do the kinds of the non-omitted arguments fill in the omitted arguments? (This is still a bit hand-wavey, but we'll refine this question incrementally as we explain more of the machinery underlying this process.) Answering this question is precisely the role that the `injectiveVarsOfType` and `injective_vars_of_binder` functions exist to serve. If an omitted argument `a` appears in the set returned by `injectiveVarsOfType ty`, then knowing `ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a bit.) More formally, if `a` is in `injectiveVarsOfType ty` and S1(ty) ~ S2(ty), then S1(a) ~ S2(a), where S1 and S2 are arbitrary substitutions. For example, is `F` is a non-injective type family, then injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c} Now that we know what this function does, here is a second attempt at the Question We Must Answer: * Given the first n arguments of T (ty_1 ... ty_n), consider the binders of T that are instantiated by non-omitted arguments. Do the injective variables of these binders fill in the remainder of T's kind? Alright, we're getting closer. Next, we need to clarify what the injective variables of a tycon binder are. This the role that the `injective_vars_of_binder` function serves. Here is what this function does for each form of tycon binder: * Anonymous binders are injective positions. For example, in the promoted data constructor '(:): '(:) :: forall a. a -> [a] -> [a] The second and third tyvar binders (of kinds `a` and `[a]`) are both anonymous, so if we had '(:) 'True '[], then the kinds of 'True and '[] would contribute to the kind of '(:) 'True '[]. Therefore, injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}. (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.) * Named binders: - Inferred binders are never injective positions. For example, in this data type: data Proxy a Proxy :: forall {k}. k -> Type If we had Proxy 'True, then the kind of 'True would not contribute to the kind of Proxy 'True. Therefore, injective_vars_of_binder(forall {k}. ...) = {}. - Required binders are injective positions. For example, in this data type: data Wurble k (a :: k) :: k Wurble :: forall k -> k -> k The first tyvar binder (of kind `forall k`) has required visibility, so if we had Wurble (Maybe a) Nothing, then the kind of Maybe a would contribute to the kind of Wurble (Maybe a) Nothing. Hence, injective_vars_of_binder(forall a -> ...) = {a}. - Specified binders /might/ be injective positions, depending on how you approach things. Continuing the '(:) example: '(:) :: forall a. a -> [a] -> [a] Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind of '(:) 'True '[], since it's not explicitly instantiated by the user. But if visible kind application is enabled, then this is possible, since the user can write '(:) @Bool 'True '[]. (In that case, injective_vars_of_binder(forall a. ...) = {a}.) There are some situations where using visible kind application is appropriate (e.g., GHC.Hs.Utils.typeToLHsType) and others where it is not (e.g., TH reification), so the `injective_vars_of_binder` function is parametrized by a Bool which decides if specified binders should be counted towards injective positions or not. Now that we've defined injective_vars_of_binder, we can refine the Question We Must Answer once more: * Given the first n arguments of T (ty_1 ... ty_n), consider the binders of T that are instantiated by non-omitted arguments. For each such binder b_i, take the union of all injective_vars_of_binder(b_i). Is this set a superset of the free variables of the remainder of T's kind? If the answer to this question is "no", then (T ty_1 ... ty_n) needs an explicit kind signature, since T's kind has kind variables leftover that aren't fixed by the non-omitted arguments. One last sticking point: what does "the remainder of T's kind" mean? You might be tempted to think that it corresponds to all of the arguments in the kind of T that would normally be instantiated by omitted arguments. But this isn't quite right, strictly speaking. Consider the following (silly) example: S :: forall {k}. Type -> Type And suppose we have this application of S: S Int Bool The Int argument would be omitted, and injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which might suggest that (S Bool) needs an explicit kind signature. But (S Bool :: Type) doesn't actually fix `k`! This is because the kind signature only affects the /result/ of the application, not all of the individual arguments. So adding a kind signature here won't make a difference. Therefore, the fourth (and final) iteration of the Question We Must Answer is: * Given the first n arguments of T (ty_1 ... ty_n), consider the binders of T that are instantiated by non-omitted arguments. For each such binder b_i, take the union of all injective_vars_of_binder(b_i). Is this set a superset of the free variables of the kind of (T ty_1 ... ty_n)? Phew, that was a lot of work! How can be sure that this is correct? That is, how can we be sure that in the event that we leave off a kind annotation, that one could infer the kind of the tycon application from its arguments? It's essentially a proof by induction: if we can infer the kinds of every subtree of a type, then the whole tycon application will have an inferrable kind--unless, of course, the remainder of the tycon application's kind has uninstantiated kind variables. What happens if T is oversaturated? That is, if T's kind has fewer than n arguments, in the case that the concrete application instantiates a result kind variable with an arrow kind? If we run out of arguments, we do not attach a kind annotation. This should be a rare case, indeed. Here is an example: data T1 :: k1 -> k2 -> * data T2 :: k1 -> k2 -> * type family G (a :: k) :: k type instance G T1 = T2 type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above Here G's kind is (forall k. k -> k), and the desugared RHS of that last instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to the algorithm above, there are 3 arguments to G so we should peel off 3 arguments in G's kind. But G's kind has only two arguments. This is the rare special case, and we choose not to annotate the application of G with a kind signature. After all, we needn't do this, since that instance would be reified as: type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool So the kind of G isn't ambiguous anymore due to the explicit kind annotation on its argument. See #8953 and test th/T8953. -} ghc-lib-parser-8.10.2.20200808/compiler/prelude/TysPrim.hs0000644000000000000000000012767113713635745020742 0ustar0000000000000000{- (c) The AQUA Project, Glasgow University, 1994-1998 \section[TysPrim]{Wired-in knowledge about primitive types} -} {-# LANGUAGE CPP #-} -- | This module defines TyCons that can't be expressed in Haskell. -- They are all, therefore, wired-in TyCons. C.f module TysWiredIn module TysPrim( mkPrimTyConName, -- For implicit parameters in TysWiredIn only mkTemplateKindVars, mkTemplateTyVars, mkTemplateTyVarsFrom, mkTemplateKiTyVars, mkTemplateKiTyVar, mkTemplateTyConBinders, mkTemplateKindTyConBinders, mkTemplateAnonTyConBinders, alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, alphaTys, alphaTy, betaTy, gammaTy, deltaTy, alphaTyVarsUnliftedRep, alphaTyVarUnliftedRep, alphaTysUnliftedRep, alphaTyUnliftedRep, runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty, openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, -- Kind constructors... tYPETyCon, tYPETyConName, -- Kinds tYPE, primRepToRuntimeRep, funTyCon, funTyConName, unexposedPrimTyCons, exposedPrimTyCons, primTyCons, charPrimTyCon, charPrimTy, charPrimTyConName, intPrimTyCon, intPrimTy, intPrimTyConName, wordPrimTyCon, wordPrimTy, wordPrimTyConName, addrPrimTyCon, addrPrimTy, addrPrimTyConName, floatPrimTyCon, floatPrimTy, floatPrimTyConName, doublePrimTyCon, doublePrimTy, doublePrimTyConName, voidPrimTyCon, voidPrimTy, statePrimTyCon, mkStatePrimTy, realWorldTyCon, realWorldTy, realWorldStatePrimTy, proxyPrimTyCon, mkProxyPrimTy, arrayPrimTyCon, mkArrayPrimTy, byteArrayPrimTyCon, byteArrayPrimTy, arrayArrayPrimTyCon, mkArrayArrayPrimTy, smallArrayPrimTyCon, mkSmallArrayPrimTy, mutableArrayPrimTyCon, mkMutableArrayPrimTy, mutableByteArrayPrimTyCon, mkMutableByteArrayPrimTy, mutableArrayArrayPrimTyCon, mkMutableArrayArrayPrimTy, smallMutableArrayPrimTyCon, mkSmallMutableArrayPrimTy, mutVarPrimTyCon, mkMutVarPrimTy, mVarPrimTyCon, mkMVarPrimTy, tVarPrimTyCon, mkTVarPrimTy, stablePtrPrimTyCon, mkStablePtrPrimTy, stableNamePrimTyCon, mkStableNamePrimTy, compactPrimTyCon, compactPrimTy, bcoPrimTyCon, bcoPrimTy, weakPrimTyCon, mkWeakPrimTy, threadIdPrimTyCon, threadIdPrimTy, int8PrimTyCon, int8PrimTy, int8PrimTyConName, word8PrimTyCon, word8PrimTy, word8PrimTyConName, int16PrimTyCon, int16PrimTy, int16PrimTyConName, word16PrimTyCon, word16PrimTy, word16PrimTyConName, int32PrimTyCon, int32PrimTy, int32PrimTyConName, word32PrimTyCon, word32PrimTy, word32PrimTyConName, int64PrimTyCon, int64PrimTy, int64PrimTyConName, word64PrimTyCon, word64PrimTy, word64PrimTyConName, eqPrimTyCon, -- ty1 ~# ty2 eqReprPrimTyCon, -- ty1 ~R# ty2 (at role Representational) eqPhantPrimTyCon, -- ty1 ~P# ty2 (at role Phantom) equalityTyCon, -- * SIMD #include "primop-vector-tys-exports.hs-incl" ) where #include "GhclibHsVersions.h" import GhcPrelude import {-# SOURCE #-} TysWiredIn ( runtimeRepTy, unboxedTupleKind, liftedTypeKind , vecRepDataConTyCon, tupleRepDataConTyCon , liftedRepDataConTy, unliftedRepDataConTy , intRepDataConTy , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy , wordRepDataConTy , word16RepDataConTy, word8RepDataConTy, word32RepDataConTy, word64RepDataConTy , addrRepDataConTy , floatRepDataConTy, doubleRepDataConTy , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy , vec64DataConTy , int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy , doubleElemRepDataConTy , mkPromotedListTy ) import Var ( TyVar, mkTyVar ) import Name import TyCon import SrcLoc import Unique import PrelNames import FastString import Outputable import TyCoRep -- Doesn't need special access, but this is easier to avoid -- import loops which show up if you import Type instead import Data.Char {- ************************************************************************ * * \subsection{Primitive type constructors} * * ************************************************************************ -} primTyCons :: [TyCon] primTyCons = unexposedPrimTyCons ++ exposedPrimTyCons -- | Primitive 'TyCon's that are defined in "GHC.Prim" but not exposed. -- It's important to keep these separate as we don't want users to be able to -- write them (see #15209) or see them in GHCi's @:browse@ output -- (see #12023). unexposedPrimTyCons :: [TyCon] unexposedPrimTyCons = [ eqPrimTyCon , eqReprPrimTyCon , eqPhantPrimTyCon ] -- | Primitive 'TyCon's that are defined in, and exported from, "GHC.Prim". exposedPrimTyCons :: [TyCon] exposedPrimTyCons = [ addrPrimTyCon , arrayPrimTyCon , byteArrayPrimTyCon , arrayArrayPrimTyCon , smallArrayPrimTyCon , charPrimTyCon , doublePrimTyCon , floatPrimTyCon , intPrimTyCon , int8PrimTyCon , int16PrimTyCon , int32PrimTyCon , int64PrimTyCon , bcoPrimTyCon , weakPrimTyCon , mutableArrayPrimTyCon , mutableByteArrayPrimTyCon , mutableArrayArrayPrimTyCon , smallMutableArrayPrimTyCon , mVarPrimTyCon , tVarPrimTyCon , mutVarPrimTyCon , realWorldTyCon , stablePtrPrimTyCon , stableNamePrimTyCon , compactPrimTyCon , statePrimTyCon , voidPrimTyCon , proxyPrimTyCon , threadIdPrimTyCon , wordPrimTyCon , word8PrimTyCon , word16PrimTyCon , word32PrimTyCon , word64PrimTyCon , tYPETyCon #include "primop-vector-tycons.hs-incl" ] mkPrimTc :: FastString -> Unique -> TyCon -> Name mkPrimTc fs unique tycon = mkWiredInName gHC_PRIM (mkTcOccFS fs) unique (ATyCon tycon) -- Relevant TyCon UserSyntax mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name mkBuiltInPrimTc fs unique tycon = mkWiredInName gHC_PRIM (mkTcOccFS fs) unique (ATyCon tycon) -- Relevant TyCon BuiltInSyntax charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int8PrimTyConName = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon int16PrimTyConName = mkPrimTc (fsLit "Int16#") int16PrimTyConKey int16PrimTyCon int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon int64PrimTyConName = mkPrimTc (fsLit "Int64#") int64PrimTyConKey int64PrimTyCon wordPrimTyConName = mkPrimTc (fsLit "Word#") wordPrimTyConKey wordPrimTyCon word8PrimTyConName = mkPrimTc (fsLit "Word8#") word8PrimTyConKey word8PrimTyCon word16PrimTyConName = mkPrimTc (fsLit "Word16#") word16PrimTyConKey word16PrimTyCon word32PrimTyConName = mkPrimTc (fsLit "Word32#") word32PrimTyConKey word32PrimTyCon word64PrimTyConName = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word64PrimTyCon addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon voidPrimTyConName = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPrimTyCon proxyPrimTyConName = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon eqReprPrimTyConName = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon eqPhantPrimTyConName = mkBuiltInPrimTc (fsLit "~P#") eqPhantPrimTyConKey eqPhantPrimTyCon realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon arrayArrayPrimTyConName = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon smallArrayPrimTyConName = mkPrimTc (fsLit "SmallArray#") smallArrayPrimTyConKey smallArrayPrimTyCon mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon mutableArrayArrayPrimTyConName= mkPrimTc (fsLit "MutableArrayArray#") mutableArrayArrayPrimTyConKey mutableArrayArrayPrimTyCon smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon mutVarPrimTyConName = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon mVarPrimTyConName = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon bcoPrimTyConName = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon {- ************************************************************************ * * \subsection{Support code} * * ************************************************************************ alphaTyVars is a list of type variables for use in templates: ["a", "b", ..., "z", "t1", "t2", ... ] -} mkTemplateKindVar :: Kind -> TyVar mkTemplateKindVar = mkTyVar (mk_tv_name 0 "k") mkTemplateKindVars :: [Kind] -> [TyVar] -- k0 with unique (mkAlphaTyVarUnique 0) -- k1 with unique (mkAlphaTyVarUnique 1) -- ... etc mkTemplateKindVars [kind] = [mkTemplateKindVar kind] -- Special case for one kind: just "k" mkTemplateKindVars kinds = [ mkTyVar (mk_tv_name u ('k' : show u)) kind | (kind, u) <- kinds `zip` [0..] ] mk_tv_name :: Int -> String -> Name mk_tv_name u s = mkInternalName (mkAlphaTyVarUnique u) (mkTyVarOccFS (mkFastString s)) noSrcSpan mkTemplateTyVarsFrom :: Int -> [Kind] -> [TyVar] -- a with unique (mkAlphaTyVarUnique n) -- b with unique (mkAlphaTyVarUnique n+1) -- ... etc -- Typically called as -- mkTemplateTyVarsFrom (length kv_bndrs) kinds -- where kv_bndrs are the kind-level binders of a TyCon mkTemplateTyVarsFrom n kinds = [ mkTyVar name kind | (kind, index) <- zip kinds [0..], let ch_ord = index + ord 'a' name_str | ch_ord <= ord 'z' = [chr ch_ord] | otherwise = 't':show index name = mk_tv_name (index + n) name_str ] mkTemplateTyVars :: [Kind] -> [TyVar] mkTemplateTyVars = mkTemplateTyVarsFrom 1 mkTemplateTyConBinders :: [Kind] -- [k1, .., kn] Kinds of kind-forall'd vars -> ([Kind] -> [Kind]) -- Arg is [kv1:k1, ..., kvn:kn] -- same length as first arg -- Result is anon arg kinds -> [TyConBinder] mkTemplateTyConBinders kind_var_kinds mk_anon_arg_kinds = kv_bndrs ++ tv_bndrs where kv_bndrs = mkTemplateKindTyConBinders kind_var_kinds anon_kinds = mk_anon_arg_kinds (mkTyVarTys (binderVars kv_bndrs)) tv_bndrs = mkTemplateAnonTyConBindersFrom (length kv_bndrs) anon_kinds mkTemplateKiTyVars :: [Kind] -- [k1, .., kn] Kinds of kind-forall'd vars -> ([Kind] -> [Kind]) -- Arg is [kv1:k1, ..., kvn:kn] -- same length as first arg -- Result is anon arg kinds [ak1, .., akm] -> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] -- Example: if you want the tyvars for -- forall (r:RuntimeRep) (a:TYPE r) (b:*). blah -- call mkTemplateKiTyVars [RuntimeRep] (\[r] -> [TYPE r, *]) mkTemplateKiTyVars kind_var_kinds mk_arg_kinds = kv_bndrs ++ tv_bndrs where kv_bndrs = mkTemplateKindVars kind_var_kinds anon_kinds = mk_arg_kinds (mkTyVarTys kv_bndrs) tv_bndrs = mkTemplateTyVarsFrom (length kv_bndrs) anon_kinds mkTemplateKiTyVar :: Kind -- [k1, .., kn] Kind of kind-forall'd var -> (Kind -> [Kind]) -- Arg is kv1:k1 -- Result is anon arg kinds [ak1, .., akm] -> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] -- Example: if you want the tyvars for -- forall (r:RuntimeRep) (a:TYPE r) (b:*). blah -- call mkTemplateKiTyVar RuntimeRep (\r -> [TYPE r, *]) mkTemplateKiTyVar kind mk_arg_kinds = kv_bndr : tv_bndrs where kv_bndr = mkTemplateKindVar kind anon_kinds = mk_arg_kinds (mkTyVarTy kv_bndr) tv_bndrs = mkTemplateTyVarsFrom 1 anon_kinds mkTemplateKindTyConBinders :: [Kind] -> [TyConBinder] -- Makes named, Specified binders mkTemplateKindTyConBinders kinds = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds] mkTemplateAnonTyConBinders :: [Kind] -> [TyConBinder] mkTemplateAnonTyConBinders kinds = mkAnonTyConBinders VisArg (mkTemplateTyVars kinds) mkTemplateAnonTyConBindersFrom :: Int -> [Kind] -> [TyConBinder] mkTemplateAnonTyConBindersFrom n kinds = mkAnonTyConBinders VisArg (mkTemplateTyVarsFrom n kinds) alphaTyVars :: [TyVar] alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar :: TyVar (alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars alphaTys :: [Type] alphaTys = mkTyVarTys alphaTyVars alphaTy, betaTy, gammaTy, deltaTy :: Type (alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys alphaTyVarsUnliftedRep :: [TyVar] alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat (tYPE unliftedRepDataConTy) alphaTyVarUnliftedRep :: TyVar (alphaTyVarUnliftedRep:_) = alphaTyVarsUnliftedRep alphaTysUnliftedRep :: [Type] alphaTysUnliftedRep = mkTyVarTys alphaTyVarsUnliftedRep alphaTyUnliftedRep :: Type (alphaTyUnliftedRep:_) = alphaTysUnliftedRep runtimeRep1TyVar, runtimeRep2TyVar :: TyVar (runtimeRep1TyVar : runtimeRep2TyVar : _) = drop 16 (mkTemplateTyVars (repeat runtimeRepTy)) -- selects 'q','r' runtimeRep1Ty, runtimeRep2Ty :: Type runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar openAlphaTyVar, openBetaTyVar :: TyVar [openAlphaTyVar,openBetaTyVar] = mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty] openAlphaTy, openBetaTy :: Type openAlphaTy = mkTyVarTy openAlphaTyVar openBetaTy = mkTyVarTy openBetaTyVar {- ************************************************************************ * * FunTyCon * * ************************************************************************ -} funTyConName :: Name funTyConName = mkPrimTyConName (fsLit "->") funTyConKey funTyCon -- | The @(->)@ type constructor. -- -- @ -- (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep). -- TYPE rep1 -> TYPE rep2 -> * -- @ funTyCon :: TyCon funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm where tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar , mkNamedTyConBinder Inferred runtimeRep2TyVar ] ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty , tYPE runtimeRep2Ty ] tc_rep_nm = mkPrelTyConRepName funTyConName {- ************************************************************************ * * Kinds * * ************************************************************************ Note [TYPE and RuntimeRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~ All types that classify values have a kind of the form (TYPE rr), where data RuntimeRep -- Defined in ghc-prim:GHC.Types = LiftedRep | UnliftedRep | IntRep | FloatRep .. etc .. rr :: RuntimeRep TYPE :: RuntimeRep -> TYPE 'LiftedRep -- Built in So for example: Int :: TYPE 'LiftedRep Array# Int :: TYPE 'UnliftedRep Int# :: TYPE 'IntRep Float# :: TYPE 'FloatRep Maybe :: TYPE 'LiftedRep -> TYPE 'LiftedRep (# , #) :: TYPE r1 -> TYPE r2 -> TYPE (TupleRep [r1, r2]) We abbreviate '*' specially: type * = TYPE 'LiftedRep The 'rr' parameter tells us how the value is represented at runime. Generally speaking, you can't be polymorphic in 'rr'. E.g f :: forall (rr:RuntimeRep) (a:TYPE rr). a -> [a] f = /\(rr:RuntimeRep) (a:rr) \(a:rr). ... This is no good: we could not generate code code for 'f', because the calling convention for 'f' varies depending on whether the argument is a a Int, Int#, or Float#. (You could imagine generating specialised code, one for each instantiation of 'rr', but we don't do that.) Certain functions CAN be runtime-rep-polymorphic, because the code generator never has to manipulate a value of type 'a :: TYPE rr'. * error :: forall (rr:RuntimeRep) (a:TYPE rr). String -> a Code generator never has to manipulate the return value. * unsafeCoerce#, defined in MkId.unsafeCoerceId: Always inlined to be a no-op unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a :: TYPE r1) (b :: TYPE r2). a -> b * Unboxed tuples, and unboxed sums, defined in TysWiredIn Always inlined, and hence specialised to the call site (#,#) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a :: TYPE r1) (b :: TYPE r2). a -> b -> TYPE ('TupleRep '[r1, r2]) Note [PrimRep and kindPrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As part of its source code, in TyCon, GHC has data PrimRep = LiftedRep | UnliftedRep | IntRep | FloatRep | ...etc... Notice that * RuntimeRep is part of the syntax tree of the program being compiled (defined in a library: ghc-prim:GHC.Types) * PrimRep is part of GHC's source code. (defined in TyCon) We need to get from one to the other; that is what kindPrimRep does. Suppose we have a value (v :: t) where (t :: k) Given this kind k = TyConApp "TYPE" [rep] GHC needs to be able to figure out how 'v' is represented at runtime. It expects 'rep' to be form TyConApp rr_dc args where 'rr_dc' is a promoteed data constructor from RuntimeRep. So now we need to go from 'dc' to the corresponding PrimRep. We store this PrimRep in the promoted data constructor itself: see TyCon.promDcRepInfo. -} tYPETyCon :: TyCon tYPETyConName :: Name tYPETyCon = mkKindTyCon tYPETyConName (mkTemplateAnonTyConBinders [runtimeRepTy]) liftedTypeKind [Nominal] (mkPrelTyConRepName tYPETyConName) -------------------------- -- ... and now their names -- If you edit these, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.hs tYPETyConName = mkPrimTyConName (fsLit "TYPE") tYPETyConKey tYPETyCon mkPrimTyConName :: FastString -> Unique -> TyCon -> Name mkPrimTyConName = mkPrimTcName BuiltInSyntax -- All of the super kinds and kinds are defined in Prim, -- and use BuiltInSyntax, because they are never in scope in the source mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name mkPrimTcName built_in_syntax occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (ATyCon tycon) built_in_syntax ----------------------------- -- | Given a RuntimeRep, applies TYPE to it. -- see Note [TYPE and RuntimeRep] tYPE :: Type -> Type tYPE rr = TyConApp tYPETyCon [rr] {- ************************************************************************ * * \subsection[TysPrim-basic]{Basic primitive types (@Char#@, @Int#@, etc.)} * * ************************************************************************ -} -- only used herein pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon pcPrimTyCon name roles rep = mkPrimTyCon name binders result_kind roles where binders = mkTemplateAnonTyConBinders (map (const liftedTypeKind) roles) result_kind = tYPE (primRepToRuntimeRep rep) -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep -- Defined here to avoid (more) module loops primRepToRuntimeRep :: PrimRep -> Type primRepToRuntimeRep rep = case rep of VoidRep -> TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []] LiftedRep -> liftedRepDataConTy UnliftedRep -> unliftedRepDataConTy IntRep -> intRepDataConTy Int8Rep -> int8RepDataConTy Int16Rep -> int16RepDataConTy Int32Rep -> int32RepDataConTy Int64Rep -> int64RepDataConTy WordRep -> wordRepDataConTy Word8Rep -> word8RepDataConTy Word16Rep -> word16RepDataConTy Word32Rep -> word32RepDataConTy Word64Rep -> word64RepDataConTy AddrRep -> addrRepDataConTy FloatRep -> floatRepDataConTy DoubleRep -> doubleRepDataConTy VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem'] where n' = case n of 2 -> vec2DataConTy 4 -> vec4DataConTy 8 -> vec8DataConTy 16 -> vec16DataConTy 32 -> vec32DataConTy 64 -> vec64DataConTy _ -> pprPanic "Disallowed VecCount" (ppr n) elem' = case elem of Int8ElemRep -> int8ElemRepDataConTy Int16ElemRep -> int16ElemRepDataConTy Int32ElemRep -> int32ElemRepDataConTy Int64ElemRep -> int64ElemRepDataConTy Word8ElemRep -> word8ElemRepDataConTy Word16ElemRep -> word16ElemRepDataConTy Word32ElemRep -> word32ElemRepDataConTy Word64ElemRep -> word64ElemRepDataConTy FloatElemRep -> floatElemRepDataConTy DoubleElemRep -> doubleElemRepDataConTy pcPrimTyCon0 :: Name -> PrimRep -> TyCon pcPrimTyCon0 name rep = pcPrimTyCon name [] rep charPrimTy :: Type charPrimTy = mkTyConTy charPrimTyCon charPrimTyCon :: TyCon charPrimTyCon = pcPrimTyCon0 charPrimTyConName WordRep intPrimTy :: Type intPrimTy = mkTyConTy intPrimTyCon intPrimTyCon :: TyCon intPrimTyCon = pcPrimTyCon0 intPrimTyConName IntRep int8PrimTy :: Type int8PrimTy = mkTyConTy int8PrimTyCon int8PrimTyCon :: TyCon int8PrimTyCon = pcPrimTyCon0 int8PrimTyConName Int8Rep int16PrimTy :: Type int16PrimTy = mkTyConTy int16PrimTyCon int16PrimTyCon :: TyCon int16PrimTyCon = pcPrimTyCon0 int16PrimTyConName Int16Rep int32PrimTy :: Type int32PrimTy = mkTyConTy int32PrimTyCon int32PrimTyCon :: TyCon int32PrimTyCon = pcPrimTyCon0 int32PrimTyConName Int32Rep int64PrimTy :: Type int64PrimTy = mkTyConTy int64PrimTyCon int64PrimTyCon :: TyCon int64PrimTyCon = pcPrimTyCon0 int64PrimTyConName Int64Rep wordPrimTy :: Type wordPrimTy = mkTyConTy wordPrimTyCon wordPrimTyCon :: TyCon wordPrimTyCon = pcPrimTyCon0 wordPrimTyConName WordRep word8PrimTy :: Type word8PrimTy = mkTyConTy word8PrimTyCon word8PrimTyCon :: TyCon word8PrimTyCon = pcPrimTyCon0 word8PrimTyConName Word8Rep word16PrimTy :: Type word16PrimTy = mkTyConTy word16PrimTyCon word16PrimTyCon :: TyCon word16PrimTyCon = pcPrimTyCon0 word16PrimTyConName Word16Rep word32PrimTy :: Type word32PrimTy = mkTyConTy word32PrimTyCon word32PrimTyCon :: TyCon word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName Word32Rep word64PrimTy :: Type word64PrimTy = mkTyConTy word64PrimTyCon word64PrimTyCon :: TyCon word64PrimTyCon = pcPrimTyCon0 word64PrimTyConName Word64Rep addrPrimTy :: Type addrPrimTy = mkTyConTy addrPrimTyCon addrPrimTyCon :: TyCon addrPrimTyCon = pcPrimTyCon0 addrPrimTyConName AddrRep floatPrimTy :: Type floatPrimTy = mkTyConTy floatPrimTyCon floatPrimTyCon :: TyCon floatPrimTyCon = pcPrimTyCon0 floatPrimTyConName FloatRep doublePrimTy :: Type doublePrimTy = mkTyConTy doublePrimTyCon doublePrimTyCon :: TyCon doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName DoubleRep {- ************************************************************************ * * \subsection[TysPrim-state]{The @State#@ type (and @_RealWorld@ types)} * * ************************************************************************ Note [The equality types story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC sports a veritable menagerie of equality types: Type or Lifted? Hetero? Role Built in Defining module class? L/U TyCon ----------------------------------------------------------------------------------------- ~# T U hetero nominal eqPrimTyCon GHC.Prim ~~ C L hetero nominal heqTyCon GHC.Types ~ C L homo nominal eqTyCon GHC.Types :~: T L homo nominal (not built-in) Data.Type.Equality :~~: T L hetero nominal (not built-in) Data.Type.Equality ~R# T U hetero repr eqReprPrimTy GHC.Prim Coercible C L homo repr coercibleTyCon GHC.Types Coercion T L homo repr (not built-in) Data.Type.Coercion ~P# T U hetero phantom eqPhantPrimTyCon GHC.Prim Recall that "hetero" means the equality can related types of different kinds. Knowing that (t1 ~# t2) or (t1 ~R# t2) or even that (t1 ~P# t2) also means that (k1 ~# k2), where (t1 :: k1) and (t2 :: k2). To produce less confusion for end users, when not dumping and without -fprint-equality-relations, each of these groups is printed as the bottommost listed equality. That is, (~#) and (~~) are both rendered as (~) in error messages, and (~R#) is rendered as Coercible. Let's take these one at a time: -------------------------- (~#) :: forall k1 k2. k1 -> k2 -> # -------------------------- This is The Type Of Equality in GHC. It classifies nominal coercions. This type is used in the solver for recording equality constraints. It responds "yes" to Type.isEqPrimPred and classifies as an EqPred in Type.classifyPredType. All wanted constraints of this type are built with coercion holes. (See Note [Coercion holes] in TyCoRep.) But see also Note [Deferred errors for coercion holes] in TcErrors to see how equality constraints are deferred. Within GHC, ~# is called eqPrimTyCon, and it is defined in TysPrim. -------------------------- (~~) :: forall k1 k2. k1 -> k2 -> Constraint -------------------------- This is (almost) an ordinary class, defined as if by class a ~# b => a ~~ b instance a ~# b => a ~~ b Here's what's unusual about it: * We can't actually declare it that way because we don't have syntax for ~#. And ~# isn't a constraint, so even if we could write it, it wouldn't kind check. * Users cannot write instances of it. * It is "naturally coherent". This means that the solver won't hesitate to solve a goal of type (a ~~ b) even if there is, say (Int ~~ c) in the context. (Normally, it waits to learn more, just in case the given influences what happens next.) See Note [Naturally coherent classes] in TcInteract. * It always terminates. That is, in the UndecidableInstances checks, we don't worry if a (~~) constraint is too big, as we know that solving equality terminates. On the other hand, this behaves just like any class w.r.t. eager superclass unpacking in the solver. So a lifted equality given quickly becomes an unlifted equality given. This is good, because the solver knows all about unlifted equalities. There is some special-casing in TcInteract.matchClassInst to pretend that there is an instance of this class, as we can't write the instance in Haskell. Within GHC, ~~ is called heqTyCon, and it is defined in TysWiredIn. -------------------------- (~) :: forall k. k -> k -> Constraint -------------------------- This is /exactly/ like (~~), except with a homogeneous kind. It is an almost-ordinary class defined as if by class a ~# b => (a :: k) ~ (b :: k) instance a ~# b => a ~ b * All the bullets for (~~) apply * In addition (~) is magical syntax, as ~ is a reserved symbol. It cannot be exported or imported. Within GHC, ~ is called eqTyCon, and it is defined in TysWiredIn. Historical note: prior to July 18 (~) was defined as a more-ordinary class with (~~) as a superclass. But that made it special in different ways; and the extra superclass selections to get from (~) to (~#) via (~~) were tiresome. Now it's defined uniformly with (~~) and Coercible; much nicer.) -------------------------- (:~:) :: forall k. k -> k -> * (:~~:) :: forall k1 k2. k1 -> k2 -> * -------------------------- These are perfectly ordinary GADTs, wrapping (~) and (~~) resp. They are not defined within GHC at all. -------------------------- (~R#) :: forall k1 k2. k1 -> k2 -> # -------------------------- The is the representational analogue of ~#. This is the type of representational equalities that the solver works on. All wanted constraints of this type are built with coercion holes. Within GHC, ~R# is called eqReprPrimTyCon, and it is defined in TysPrim. -------------------------- Coercible :: forall k. k -> k -> Constraint -------------------------- This is quite like (~~) in the way it's defined and treated within GHC, but it's homogeneous. Homogeneity helps with type inference (as GHC can solve one kind from the other) and, in my (Richard's) estimation, will be more intuitive for users. An alternative design included HCoercible (like (~~)) and Coercible (like (~)). One annoyance was that we want `coerce :: Coercible a b => a -> b`, and we need the type of coerce to be fully wired-in. So the HCoercible/Coercible split required that both types be fully wired-in. Instead of doing this, I just got rid of HCoercible, as I'm not sure who would use it, anyway. Within GHC, Coercible is called coercibleTyCon, and it is defined in TysWiredIn. -------------------------- Coercion :: forall k. k -> k -> * -------------------------- This is a perfectly ordinary GADT, wrapping Coercible. It is not defined within GHC at all. -------------------------- (~P#) :: forall k1 k2. k1 -> k2 -> # -------------------------- This is the phantom analogue of ~# and it is barely used at all. (The solver has no idea about this one.) Here is the motivation: data Phant a = MkPhant type role Phant phantom Phant _P :: Phant Int ~P# Phant Bool We just need to have something to put on that last line. You probably don't need to worry about it. Note [The State# TyCon] ~~~~~~~~~~~~~~~~~~~~~~~ State# is the primitive, unlifted type of states. It has one type parameter, thus State# RealWorld or State# s where s is a type variable. The only purpose of the type parameter is to keep different state threads separate. It is represented by nothing at all. The type parameter to State# is intended to keep separate threads separate. Even though this parameter is not used in the definition of State#, it is given role Nominal to enforce its intended use. -} mkStatePrimTy :: Type -> Type mkStatePrimTy ty = TyConApp statePrimTyCon [ty] statePrimTyCon :: TyCon -- See Note [The State# TyCon] statePrimTyCon = pcPrimTyCon statePrimTyConName [Nominal] VoidRep {- RealWorld is deeply magical. It is *primitive*, but it is not *unlifted* (hence ptrArg). We never manipulate values of type RealWorld; it's only used in the type system, to parameterise State#. -} realWorldTyCon :: TyCon realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName [] liftedTypeKind [] realWorldTy :: Type realWorldTy = mkTyConTy realWorldTyCon realWorldStatePrimTy :: Type realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld -- Note: the ``state-pairing'' types are not truly primitive, -- so they are defined in \tr{TysWiredIn.hs}, not here. voidPrimTy :: Type voidPrimTy = TyConApp voidPrimTyCon [] voidPrimTyCon :: TyCon voidPrimTyCon = pcPrimTyCon voidPrimTyConName [] VoidRep mkProxyPrimTy :: Type -> Type -> Type mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] proxyPrimTyCon :: TyCon proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Phantom] where -- Kind: forall k. k -> TYPE (Tuple '[]) binders = mkTemplateTyConBinders [liftedTypeKind] id res_kind = unboxedTupleKind [] {- ********************************************************************* * * Primitive equality constraints See Note [The equality types story] * * ********************************************************************* -} eqPrimTyCon :: TyCon -- The representation type for equality predicates -- See Note [The equality types story] eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles where -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[]) binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id res_kind = unboxedTupleKind [] roles = [Nominal, Nominal, Nominal, Nominal] -- like eqPrimTyCon, but the type for *Representational* coercions -- this should only ever appear as the type of a covar. Its role is -- interpreted in coercionRole eqReprPrimTyCon :: TyCon -- See Note [The equality types story] eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles where -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[]) binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id res_kind = unboxedTupleKind [] roles = [Nominal, Nominal, Representational, Representational] -- like eqPrimTyCon, but the type for *Phantom* coercions. -- This is only used to make higher-order equalities. Nothing -- should ever actually have this type! eqPhantPrimTyCon :: TyCon eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles where -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[]) binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id res_kind = unboxedTupleKind [] roles = [Nominal, Nominal, Phantom, Phantom] -- | Given a Role, what TyCon is the type of equality predicates at that role? equalityTyCon :: Role -> TyCon equalityTyCon Nominal = eqPrimTyCon equalityTyCon Representational = eqReprPrimTyCon equalityTyCon Phantom = eqPhantPrimTyCon {- ********************************************************************* * * The primitive array types * * ********************************************************************* -} arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon, byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon, smallArrayPrimTyCon, smallMutableArrayPrimTyCon :: TyCon arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName [Representational] UnliftedRep mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName [Nominal, Representational] UnliftedRep mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName [Nominal] UnliftedRep byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName UnliftedRep arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName UnliftedRep mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] UnliftedRep smallArrayPrimTyCon = pcPrimTyCon smallArrayPrimTyConName [Representational] UnliftedRep smallMutableArrayPrimTyCon = pcPrimTyCon smallMutableArrayPrimTyConName [Nominal, Representational] UnliftedRep mkArrayPrimTy :: Type -> Type mkArrayPrimTy elt = TyConApp arrayPrimTyCon [elt] byteArrayPrimTy :: Type byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon mkArrayArrayPrimTy :: Type mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon mkSmallArrayPrimTy :: Type -> Type mkSmallArrayPrimTy elt = TyConApp smallArrayPrimTyCon [elt] mkMutableArrayPrimTy :: Type -> Type -> Type mkMutableArrayPrimTy s elt = TyConApp mutableArrayPrimTyCon [s, elt] mkMutableByteArrayPrimTy :: Type -> Type mkMutableByteArrayPrimTy s = TyConApp mutableByteArrayPrimTyCon [s] mkMutableArrayArrayPrimTy :: Type -> Type mkMutableArrayArrayPrimTy s = TyConApp mutableArrayArrayPrimTyCon [s] mkSmallMutableArrayPrimTy :: Type -> Type -> Type mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [s, elt] {- ********************************************************************* * * The mutable variable type * * ********************************************************************* -} mutVarPrimTyCon :: TyCon mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] UnliftedRep mkMutVarPrimTy :: Type -> Type -> Type mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt] {- ************************************************************************ * * \subsection[TysPrim-synch-var]{The synchronizing variable type} * * ************************************************************************ -} mVarPrimTyCon :: TyCon mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] UnliftedRep mkMVarPrimTy :: Type -> Type -> Type mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [s, elt] {- ************************************************************************ * * \subsection[TysPrim-stm-var]{The transactional variable type} * * ************************************************************************ -} tVarPrimTyCon :: TyCon tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] UnliftedRep mkTVarPrimTy :: Type -> Type -> Type mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt] {- ************************************************************************ * * \subsection[TysPrim-stable-ptrs]{The stable-pointer type} * * ************************************************************************ -} stablePtrPrimTyCon :: TyCon stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName [Representational] AddrRep mkStablePtrPrimTy :: Type -> Type mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty] {- ************************************************************************ * * \subsection[TysPrim-stable-names]{The stable-name type} * * ************************************************************************ -} stableNamePrimTyCon :: TyCon stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Phantom] UnliftedRep mkStableNamePrimTy :: Type -> Type mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty] {- ************************************************************************ * * \subsection[TysPrim-compact-nfdata]{The Compact NFData (CNF) type} * * ************************************************************************ -} compactPrimTyCon :: TyCon compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName UnliftedRep compactPrimTy :: Type compactPrimTy = mkTyConTy compactPrimTyCon {- ************************************************************************ * * \subsection[TysPrim-BCOs]{The ``bytecode object'' type} * * ************************************************************************ -} bcoPrimTy :: Type bcoPrimTy = mkTyConTy bcoPrimTyCon bcoPrimTyCon :: TyCon bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep {- ************************************************************************ * * \subsection[TysPrim-Weak]{The ``weak pointer'' type} * * ************************************************************************ -} weakPrimTyCon :: TyCon weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] UnliftedRep mkWeakPrimTy :: Type -> Type mkWeakPrimTy v = TyConApp weakPrimTyCon [v] {- ************************************************************************ * * \subsection[TysPrim-thread-ids]{The ``thread id'' type} * * ************************************************************************ A thread id is represented by a pointer to the TSO itself, to ensure that they are always unique and we can always find the TSO for a given thread id. However, this has the unfortunate consequence that a ThreadId# for a given thread is treated as a root by the garbage collector and can keep TSOs around for too long. Hence the programmer API for thread manipulation uses a weak pointer to the thread id internally. -} threadIdPrimTy :: Type threadIdPrimTy = mkTyConTy threadIdPrimTyCon threadIdPrimTyCon :: TyCon threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName UnliftedRep {- ************************************************************************ * * \subsection{SIMD vector types} * * ************************************************************************ -} #include "primop-vector-tys.hs-incl" ghc-lib-parser-8.10.2.20200808/compiler/prelude/TysWiredIn.hs0000644000000000000000000020111213713635745021353 0ustar0000000000000000{- (c) The GRASP Project, Glasgow University, 1994-1998 \section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types} -} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | This module is about types that can be defined in Haskell, but which -- must be wired into the compiler nonetheless. C.f module TysPrim module TysWiredIn ( -- * Helper functions defined here mkWiredInTyConName, -- This is used in TcTypeNats to define the -- built-in functions for evaluation. mkWiredInIdName, -- used in MkId -- * All wired in things wiredInTyCons, isBuiltInOcc_maybe, -- * Bool boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, trueDataCon, trueDataConId, true_RDR, falseDataCon, falseDataConId, false_RDR, promotedFalseDataCon, promotedTrueDataCon, -- * Ordering orderingTyCon, ordLTDataCon, ordLTDataConId, ordEQDataCon, ordEQDataConId, ordGTDataCon, ordGTDataConId, promotedLTDataCon, promotedEQDataCon, promotedGTDataCon, -- * Boxing primitive types boxingDataCon_maybe, -- * Char charTyCon, charDataCon, charTyCon_RDR, charTy, stringTy, charTyConName, -- * Double doubleTyCon, doubleDataCon, doubleTy, doubleTyConName, -- * Float floatTyCon, floatDataCon, floatTy, floatTyConName, -- * Int intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName, intTy, -- * Word wordTyCon, wordDataCon, wordTyConName, wordTy, -- * Word8 word8TyCon, word8DataCon, word8TyConName, word8Ty, -- * List listTyCon, listTyCon_RDR, listTyConName, listTyConKey, nilDataCon, nilDataConName, nilDataConKey, consDataCon_RDR, consDataCon, consDataConName, promotedNilDataCon, promotedConsDataCon, mkListTy, mkPromotedListTy, -- * Maybe maybeTyCon, maybeTyConName, nothingDataCon, nothingDataConName, promotedNothingDataCon, justDataCon, justDataConName, promotedJustDataCon, -- * Tuples mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr, tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName, promotedTupleDataCon, unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, pairTyCon, unboxedUnitTyCon, unboxedUnitDataCon, unboxedTupleKind, unboxedSumKind, -- ** Constraint tuples cTupleTyConName, cTupleTyConNames, isCTupleTyConName, cTupleTyConNameArity_maybe, cTupleDataConName, cTupleDataConNames, -- * Any anyTyCon, anyTy, anyTypeOfKind, -- * Recovery TyCon makeRecoveryTyCon, -- * Sums mkSumTy, sumTyCon, sumDataCon, -- * Kinds typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind, isLiftedTypeKindTyConName, liftedTypeKind, typeToTypeKind, constraintKind, liftedTypeKindTyCon, constraintKindTyCon, constraintKindTyConName, liftedTypeKindTyConName, -- * Equality predicates heqTyCon, heqTyConName, heqClass, heqDataCon, eqTyCon, eqTyConName, eqClass, eqDataCon, eqTyCon_RDR, coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass, -- * RuntimeRep and friends runtimeRepTyCon, vecCountTyCon, vecElemTyCon, runtimeRepTy, liftedRepTy, liftedRepDataCon, liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, wordRepDataConTy, word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy, vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, vec64DataConTy, int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, doubleElemRepDataConTy ) where #include "GhclibHsVersions.h" import GhcPrelude import {-# SOURCE #-} MkId( mkDataConWorkId, mkDictSelId ) -- friends: import PrelNames import TysPrim import {-# SOURCE #-} KnownUniques -- others: import CoAxiom import Id import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) import Module ( Module ) import Type import RepType import DataCon import {-# SOURCE #-} ConLike import TyCon import Class ( Class, mkClass ) import RdrName import Name import NameEnv ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF ) import NameSet ( NameSet, mkNameSet, elemNameSet ) import BasicTypes ( Arity, Boxity(..), TupleSort(..), ConTagZ, SourceText(..) ) import ForeignCall import SrcLoc ( noSrcSpan ) import Unique import Data.Array import FastString import Outputable import Util import BooleanFormula ( mkAnd ) import qualified Data.ByteString.Char8 as BS import Data.List ( elemIndex ) alpha_tyvar :: [TyVar] alpha_tyvar = [alphaTyVar] alpha_ty :: [Type] alpha_ty = [alphaTy] {- Note [Wiring in RuntimeRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors, making it a pain to wire in. To ease the pain somewhat, we use lists of the different bits, like Uniques, Names, DataCons. These lists must be kept in sync with each other. The rule is this: use the order as declared in GHC.Types. All places where such lists exist should contain a reference to this Note, so a search for this Note's name should find all the lists. See also Note [Getting from RuntimeRep to PrimRep] in RepType. ************************************************************************ * * \subsection{Wired in type constructors} * * ************************************************************************ If you change which things are wired in, make sure you change their names in PrelNames, so they use wTcQual, wDataQual, etc -} -- This list is used only to define PrelInfo.wiredInThings. That in turn -- is used to initialise the name environment carried around by the renamer. -- This means that if we look up the name of a TyCon (or its implicit binders) -- that occurs in this list that name will be assigned the wired-in key we -- define here. -- -- Because of their infinite nature, this list excludes -- * tuples, including boxed, unboxed and constraint tuples --- (mkTupleTyCon, unitTyCon, pairTyCon) -- * unboxed sums (sumTyCon) -- See Note [Infinite families of known-key names] in GHC.Builtin.Names -- -- See also Note [Known-key names] wiredInTyCons :: [TyCon] wiredInTyCons = [ -- Units are not treated like other tuples, because they -- are defined in GHC.Base, and there's only a few of them. We -- put them in wiredInTyCons so that they will pre-populate -- the name cache, so the parser in isBuiltInOcc_maybe doesn't -- need to look out for them. unitTyCon , unboxedUnitTyCon , anyTyCon , boolTyCon , charTyCon , doubleTyCon , floatTyCon , intTyCon , wordTyCon , word8TyCon , listTyCon , orderingTyCon , maybeTyCon , heqTyCon , eqTyCon , coercibleTyCon , typeNatKindCon , typeSymbolKindCon , runtimeRepTyCon , vecCountTyCon , vecElemTyCon , constraintKindTyCon , liftedTypeKindTyCon ] mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name mkWiredInTyConName built_in modu fs unique tycon = mkWiredInName modu (mkTcOccFS fs) unique (ATyCon tycon) -- Relevant TyCon built_in mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name mkWiredInDataConName built_in modu fs unique datacon = mkWiredInName modu (mkDataOccFS fs) unique (AConLike (RealDataCon datacon)) -- Relevant DataCon built_in mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name mkWiredInIdName mod fs uniq id = mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax -- See Note [Kind-changing of (~) and Coercible] -- in libraries/ghc-prim/GHC/Types.hs eqTyConName, eqDataConName, eqSCSelIdName :: Name eqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~") eqTyConKey eqTyCon eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId eqTyCon_RDR :: RdrName eqTyCon_RDR = nameRdrName eqTyConName -- See Note [Kind-changing of (~) and Coercible] -- in libraries/ghc-prim/GHC/Types.hs heqTyConName, heqDataConName, heqSCSelIdName :: Name heqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~~") heqTyConKey heqTyCon heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "HEq#") heqDataConKey heqDataCon heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "heq_sel") heqSCSelIdKey heqSCSelId -- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name coercibleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Coercible") coercibleTyConKey coercibleTyCon coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "coercible_sel") coercibleSCSelIdKey coercibleSCSelId charTyConName, charDataConName, intTyConName, intDataConName :: Name charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon charDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon intTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Int") intTyConKey intTyCon intDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#") intDataConKey intDataCon boolTyConName, falseDataConName, trueDataConName :: Name boolTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon falseDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon trueDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True") trueDataConKey trueDataCon listTyConName, nilDataConName, consDataConName :: Name listTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon maybeTyConName, nothingDataConName, justDataConName :: Name maybeTyConName = mkWiredInTyConName UserSyntax gHC_MAYBE (fsLit "Maybe") maybeTyConKey maybeTyCon nothingDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Nothing") nothingDataConKey nothingDataCon justDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Just") justDataConKey justDataCon wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name wordTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Word") wordTyConKey wordTyCon wordDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#") wordDataConKey wordDataCon word8TyConName = mkWiredInTyConName UserSyntax gHC_WORD (fsLit "Word8") word8TyConKey word8TyCon word8DataConName = mkWiredInDataConName UserSyntax gHC_WORD (fsLit "W8#") word8DataConKey word8DataCon floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name floatTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Float") floatTyConKey floatTyCon floatDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floatDataConKey floatDataCon doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon -- Any {- Note [Any types] ~~~~~~~~~~~~~~~~ The type constructor Any, type family Any :: k where { } It has these properties: * Note that 'Any' is kind polymorphic since in some program we may need to use Any to fill in a type variable of some kind other than * (see #959 for examples). Its kind is thus `forall k. k``. * It is defined in module GHC.Types, and exported so that it is available to users. For this reason it's treated like any other wired-in type: - has a fixed unique, anyTyConKey, - lives in the global name cache * It is a *closed* type family, with no instances. This means that if ty :: '(k1, k2) we add a given coercion g :: ty ~ (Fst ty, Snd ty) If Any was a *data* type, then we'd get inconsistency because 'ty' could be (Any '(k1,k2)) and then we'd have an equality with Any on one side and '(,) on the other. See also #9097 and #9636. * When instantiated at a lifted type it is inhabited by at least one value, namely bottom * You can safely coerce any /lifted/ type to Any, and back with unsafeCoerce. * It does not claim to be a *data* type, and that's important for the code generator, because the code gen may *enter* a data value but never enters a function value. * It is wired-in so we can easily refer to it where we don't have a name environment (e.g. see Rules.matchRule for one example) * If (Any k) is the type of a value, it must be a /lifted/ value. So if we have (Any @(TYPE rr)) then rr must be 'LiftedRep. See Note [TYPE and RuntimeRep] in TysPrim. This is a convenient invariant, and makes isUnliftedTyCon well-defined; otherwise what would (isUnliftedTyCon Any) be? It's used to instantiate un-constrained type variables after type checking. For example, 'length' has type length :: forall a. [a] -> Int and the list datacon for the empty list has type [] :: forall a. [a] In order to compose these two terms as @length []@ a type application is required, but there is no constraint on the choice. In this situation GHC uses 'Any', > length (Any *) ([] (Any *)) Above, we print kinds explicitly, as if with --fprint-explicit-kinds. The Any tycon used to be quite magic, but we have since been able to implement it merely with an empty kind polymorphic type family. See #10886 for a bit of history. -} anyTyConName :: Name anyTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon anyTyCon :: TyCon anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing (ClosedSynFamilyTyCon Nothing) Nothing NotInjective where binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind] res_kind = mkTyVarTy (binderVar kv) anyTy :: Type anyTy = mkTyConTy anyTyCon anyTypeOfKind :: Kind -> Type anyTypeOfKind kind = mkTyConApp anyTyCon [kind] -- | Make a fake, recovery 'TyCon' from an existing one. -- Used when recovering from errors in type declarations makeRecoveryTyCon :: TyCon -> TyCon makeRecoveryTyCon tc = mkTcTyCon (tyConName tc) bndrs res_kind noTcTyConScopedTyVars True -- Fully generalised flavour -- Keep old flavour where flavour = tyConFlavour tc [kv] = mkTemplateKindVars [liftedTypeKind] (bndrs, res_kind) = case flavour of PromotedDataConFlavour -> ([mkNamedTyConBinder Inferred kv], mkTyVarTy kv) _ -> (tyConBinders tc, tyConResKind tc) -- For data types we have already validated their kind, so it -- makes sense to keep it. For promoted data constructors we haven't, -- so we recover with kind (forall k. k). Otherwise consider -- data T a where { MkT :: Show a => T a } -- If T is for some reason invalid, we don't want to fall over -- at (promoted) use-sites of MkT. -- Kinds typeNatKindConName, typeSymbolKindConName :: Name typeNatKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Nat") typeNatKindConNameKey typeNatKindCon typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon constraintKindTyConName :: Name constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon liftedTypeKindTyConName :: Name liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName :: Name runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon tupleRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") sumRepDataConKey sumRepDataCon -- See Note [Wiring in RuntimeRep] runtimeRepSimpleDataConNames :: [Name] runtimeRepSimpleDataConNames = zipWith3Lazy mk_special_dc_name [ fsLit "LiftedRep", fsLit "UnliftedRep" , fsLit "IntRep" , fsLit "Int8Rep", fsLit "Int16Rep", fsLit "Int32Rep", fsLit "Int64Rep" , fsLit "WordRep" , fsLit "Word8Rep", fsLit "Word16Rep", fsLit "Word32Rep", fsLit "Word64Rep" , fsLit "AddrRep" , fsLit "FloatRep", fsLit "DoubleRep" ] runtimeRepSimpleDataConKeys runtimeRepSimpleDataCons vecCountTyConName :: Name vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon -- See Note [Wiring in RuntimeRep] vecCountDataConNames :: [Name] vecCountDataConNames = zipWith3Lazy mk_special_dc_name [ fsLit "Vec2", fsLit "Vec4", fsLit "Vec8" , fsLit "Vec16", fsLit "Vec32", fsLit "Vec64" ] vecCountDataConKeys vecCountDataCons vecElemTyConName :: Name vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon -- See Note [Wiring in RuntimeRep] vecElemDataConNames :: [Name] vecElemDataConNames = zipWith3Lazy mk_special_dc_name [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep" , fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16ElemRep" , fsLit "Word32ElemRep", fsLit "Word64ElemRep" , fsLit "FloatElemRep", fsLit "DoubleElemRep" ] vecElemDataConKeys vecElemDataCons mk_special_dc_name :: FastString -> Unique -> DataCon -> Name mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName boolTyCon_RDR = nameRdrName boolTyConName false_RDR = nameRdrName falseDataConName true_RDR = nameRdrName trueDataConName intTyCon_RDR = nameRdrName intTyConName charTyCon_RDR = nameRdrName charTyConName intDataCon_RDR = nameRdrName intDataConName listTyCon_RDR = nameRdrName listTyConName consDataCon_RDR = nameRdrName consDataConName {- ************************************************************************ * * \subsection{mkWiredInTyCon} * * ************************************************************************ -} -- This function assumes that the types it creates have all parameters at -- Representational role, and that there is no kind polymorphism. pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon pcTyCon name cType tyvars cons = mkAlgTyCon name (mkAnonTyConBinders VisArg tyvars) liftedTypeKind (map (const Representational) tyvars) cType [] -- No stupid theta (mkDataTyConRhs cons) (VanillaAlgTyCon (mkPrelTyConRepName name)) False -- Not in GADT syntax pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon pcDataCon n univs = pcDataConWithFixity False n univs [] -- no ex_tvs univs -- the univs are precisely the user-written tyvars pcDataConWithFixity :: Bool -- ^ declared infix? -> Name -- ^ datacon name -> [TyVar] -- ^ univ tyvars -> [TyCoVar] -- ^ ex tycovars -> [TyCoVar] -- ^ user-written tycovars -> [Type] -- ^ args -> TyCon -> DataCon pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (nameUnique n)) NoRRI -- The Name's unique is the first of two free uniques; -- the first is used for the datacon itself, -- the second is used for the "worker name" -- -- To support this the mkPreludeDataConUnique function "allocates" -- one DataCon unique per pair of Ints. pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo -> [TyVar] -> [TyCoVar] -> [TyCoVar] -> [Type] -> TyCon -> DataCon -- The Name should be in the DataName name space; it's the name -- of the DataCon itself. pcDataConWithFixity' declared_infix dc_name wrk_key rri tyvars ex_tyvars user_tyvars arg_tys tycon = data_con where tag_map = mkTyConTagMap tycon -- This constructs the constructor Name to ConTag map once per -- constructor, which is quadratic. It's OK here, because it's -- only called for wired in data types that don't have a lot of -- constructors. It's also likely that GHC will lift tag_map, since -- we call pcDataConWithFixity' with static TyCons in the same module. -- See Note [Constructor tag allocation] and #14657 data_con = mkDataCon dc_name declared_infix prom_info (map (const no_bang) arg_tys) [] -- No labelled fields tyvars ex_tyvars (mkTyCoVarBinders Specified user_tyvars) [] -- No equality spec [] -- No theta arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) rri tycon (lookupNameEnv_NF tag_map dc_name) [] -- No stupid theta (mkDataConWorkId wrk_name data_con) NoDataConRep -- Wired-in types are too simple to need wrappers no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict wrk_name = mkDataConWorkerName data_con wrk_key prom_info = mkPrelTyConRepName dc_name mkDataConWorkerName :: DataCon -> Unique -> Name mkDataConWorkerName data_con wrk_key = mkWiredInName modu wrk_occ wrk_key (AnId (dataConWorkId data_con)) UserSyntax where modu = ASSERT( isExternalName dc_name ) nameModule dc_name dc_name = dataConName data_con dc_occ = nameOccName dc_name wrk_occ = mkDataConWorkerOcc dc_occ -- used for RuntimeRep and friends pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon pcSpecialDataCon dc_name arg_tys tycon rri = pcDataConWithFixity' False dc_name (dataConWorkerUnique (nameUnique dc_name)) rri [] [] [] arg_tys tycon {- ************************************************************************ * * Kinds * * ************************************************************************ -} typeNatKindCon, typeSymbolKindCon :: TyCon -- data Nat -- data Symbol typeNatKindCon = pcTyCon typeNatKindConName Nothing [] [] typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] [] typeNatKind, typeSymbolKind :: Kind typeNatKind = mkTyConTy typeNatKindCon typeSymbolKind = mkTyConTy typeSymbolKindCon constraintKindTyCon :: TyCon constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] [] liftedTypeKind, typeToTypeKind, constraintKind :: Kind liftedTypeKind = tYPE liftedRepTy typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind constraintKind = mkTyConApp constraintKindTyCon [] {- ************************************************************************ * * Stuff for dealing with tuples * * ************************************************************************ Note [How tuples work] See also Note [Known-key names] in PrelNames ~~~~~~~~~~~~~~~~~~~~~~ * There are three families of tuple TyCons and corresponding DataCons, expressed by the type BasicTypes.TupleSort: data TupleSort = BoxedTuple | UnboxedTuple | ConstraintTuple * All three families are AlgTyCons, whose AlgTyConRhs is TupleTyCon * BoxedTuples - A wired-in type - Data type declarations in GHC.Tuple - The data constructors really have an info table * UnboxedTuples - A wired-in type - Have a pretend DataCon, defined in GHC.Prim, but no actual declaration and no info table * ConstraintTuples - Are known-key rather than wired-in. Reason: it's awkward to have all the superclass selectors wired-in. - Declared as classes in GHC.Classes, e.g. class (c1,c2) => (c1,c2) - Given constraints: the superclasses automatically become available - Wanted constraints: there is a built-in instance instance (c1,c2) => (c1,c2) See TcInteract.matchCTuple - Currently just go up to 62; beyond that you have to use manual nesting - Their OccNames look like (%,,,%), so they can easily be distinguished from term tuples. But (following Haskell) we pretty-print saturated constraint tuples with round parens; see BasicTypes.tupleParens. * In quite a lot of places things are restrcted just to BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish E.g. tupleTyCon has a Boxity argument * When looking up an OccName in the original-name cache (IfaceEnv.lookupOrigNameCache), we spot the tuple OccName to make sure we get the right wired-in name. This guy can't tell the difference between BoxedTuple and ConstraintTuple (same OccName!), so tuples are not serialised into interface files using OccNames at all. * Serialization to interface files works via the usual mechanism for known-key things: instead of serializing the OccName we just serialize the key. During deserialization we lookup the Name associated with the unique with the logic in KnownUniques. See Note [Symbol table representation of names] for details. Note [One-tuples] ~~~~~~~~~~~~~~~~~ GHC supports both boxed and unboxed one-tuples: - Unboxed one-tuples are sometimes useful when returning a single value after CPR analysis - A boxed one-tuple is used by DsUtils.mkSelectorBinds, when there is just one binder Basically it keeps everythig uniform. However the /naming/ of the type/data constructors for one-tuples is a bit odd: 3-tuples: (,,) (,,)# 2-tuples: (,) (,)# 1-tuples: ?? 0-tuples: () ()# Zero-tuples have used up the logical name. So we use 'Unit' and 'Unit#' for one-tuples. So in ghc-prim:GHC.Tuple we see the declarations: data () = () data Unit a = Unit a data (a,b) = (a,b) There is no way to write a boxed one-tuple in Haskell using tuple syntax. They can, however, be written using other methods: 1. They can be written directly by importing them from GHC.Tuple. 2. They can be generated by way of Template Haskell or in `deriving` code. There is nothing special about one-tuples in Core; in particular, they have no custom pretty-printing, just using `Unit`. Note that there is *not* a unary constraint tuple, unlike for other forms of tuples. See [Ignore unary constraint tuples] in TcHsType for more details. See also Note [Flattening one-tuples] in MkCore and Note [Don't flatten tuples from HsSyn] in MkCore. ----- -- Wrinkle: Make boxed one-tuple names have known keys ----- We make boxed one-tuple names have known keys so that `data Unit a = Unit a`, defined in GHC.Tuple, will be used when one-tuples are spliced in through Template Haskell. This program (from #18097) crucially relies on this: case $( tupE [ [| "ok" |] ] ) of Unit x -> putStrLn x Unless Unit has a known key, the type of `$( tupE [ [| "ok" |] ] )` (an ExplicitTuple of length 1) will not match the type of Unit (an ordinary data constructor used in a pattern). Making Unit known-key allows GHC to make this connection. Unlike Unit, every other tuple is /not/ known-key (see Note [Infinite families of known-key names] in GHC.Builtin.Names). The main reason for this exception is that other tuples are written with special syntax, and as a result, they are renamed using a special `isBuiltInOcc_maybe` function (see Note [Built-in syntax and the OrigNameCache] in GHC.Types.Name.Cache). In contrast, Unit is just an ordinary data type with no special syntax, so it doesn't really make sense to handle it in `isBuiltInOcc_maybe`. Making Unit known-key is the next-best way to teach the internals of the compiler about it. -} -- | Built-in syntax isn't "in scope" so these OccNames map to wired-in Names -- with BuiltInSyntax. However, this should only be necessary while resolving -- names produced by Template Haskell splices since we take care to encode -- built-in syntax names specially in interface files. See -- Note [Symbol table representation of names]. -- -- Moreover, there is no need to include names of things that the user can't -- write (e.g. type representation bindings like $tc(,,,)). isBuiltInOcc_maybe :: OccName -> Maybe Name isBuiltInOcc_maybe occ = case name of "[]" -> Just $ choose_ns listTyConName nilDataConName ":" -> Just consDataConName -- equality tycon "~" -> Just eqTyConName -- function tycon "->" -> Just funTyConName -- boxed tuple data/tycon -- We deliberately exclude Unit (the boxed 1-tuple). -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys) "()" -> Just $ tup_name Boxed 0 _ | Just rest <- "(" `BS.stripPrefix` name , (commas, rest') <- BS.span (==',') rest , ")" <- rest' -> Just $ tup_name Boxed (1+BS.length commas) -- unboxed tuple data/tycon "(##)" -> Just $ tup_name Unboxed 0 "Unit#" -> Just $ tup_name Unboxed 1 _ | Just rest <- "(#" `BS.stripPrefix` name , (commas, rest') <- BS.span (==',') rest , "#)" <- rest' -> Just $ tup_name Unboxed (1+BS.length commas) -- unboxed sum tycon _ | Just rest <- "(#" `BS.stripPrefix` name , (pipes, rest') <- BS.span (=='|') rest , "#)" <- rest' -> Just $ tyConName $ sumTyCon (1+BS.length pipes) -- unboxed sum datacon _ | Just rest <- "(#" `BS.stripPrefix` name , (pipes1, rest') <- BS.span (=='|') rest , Just rest'' <- "_" `BS.stripPrefix` rest' , (pipes2, rest''') <- BS.span (=='|') rest'' , "#)" <- rest''' -> let arity = BS.length pipes1 + BS.length pipes2 + 1 alt = BS.length pipes1 + 1 in Just $ dataConName $ sumDataCon alt arity _ -> Nothing where name = bytesFS $ occNameFS occ choose_ns :: Name -> Name -> Name choose_ns tc dc | isTcClsNameSpace ns = tc | isDataConNameSpace ns = dc | otherwise = pprPanic "tup_name" (ppr occ) where ns = occNameSpace occ tup_name boxity arity = choose_ns (getName (tupleTyCon boxity arity)) (getName (tupleDataCon boxity arity)) mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName -- No need to cache these, the caching is done in mk_tuple mkTupleOcc ns Boxed ar = mkOccName ns (mkBoxedTupleStr ar) mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ar) mkCTupleOcc :: NameSpace -> Arity -> OccName mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar) mkTupleStr :: Boxity -> Arity -> String mkTupleStr Boxed = mkBoxedTupleStr mkTupleStr Unboxed = mkUnboxedTupleStr mkBoxedTupleStr :: Arity -> String mkBoxedTupleStr 0 = "()" mkBoxedTupleStr 1 = "Unit" -- See Note [One-tuples] mkBoxedTupleStr ar = '(' : commas ar ++ ")" mkUnboxedTupleStr :: Arity -> String mkUnboxedTupleStr 0 = "(##)" mkUnboxedTupleStr 1 = "Unit#" -- See Note [One-tuples] mkUnboxedTupleStr ar = "(#" ++ commas ar ++ "#)" mkConstraintTupleStr :: Arity -> String mkConstraintTupleStr 0 = "(%%)" mkConstraintTupleStr 1 = "Unit%" -- See Note [One-tuples] mkConstraintTupleStr ar = "(%" ++ commas ar ++ "%)" commas :: Arity -> String commas ar = take (ar-1) (repeat ',') cTupleTyConName :: Arity -> Name cTupleTyConName arity = mkExternalName (mkCTupleTyConUnique arity) gHC_CLASSES (mkCTupleOcc tcName arity) noSrcSpan cTupleTyConNames :: [Name] cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE]) cTupleTyConNameSet :: NameSet cTupleTyConNameSet = mkNameSet cTupleTyConNames isCTupleTyConName :: Name -> Bool -- Use Type.isCTupleClass where possible isCTupleTyConName n = ASSERT2( isExternalName n, ppr n ) nameModule n == gHC_CLASSES && n `elemNameSet` cTupleTyConNameSet -- | If the given name is that of a constraint tuple, return its arity. -- Note that this is inefficient. cTupleTyConNameArity_maybe :: Name -> Maybe Arity cTupleTyConNameArity_maybe n | not (isCTupleTyConName n) = Nothing | otherwise = fmap adjustArity (n `elemIndex` cTupleTyConNames) where -- Since `cTupleTyConNames` jumps straight from the `0` to the `2` -- case, we have to adjust accordingly our calculated arity. adjustArity a = if a > 0 then a + 1 else a cTupleDataConName :: Arity -> Name cTupleDataConName arity = mkExternalName (mkCTupleDataConUnique arity) gHC_CLASSES (mkCTupleOcc dataName arity) noSrcSpan cTupleDataConNames :: [Name] cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE]) tupleTyCon :: Boxity -> Arity -> TyCon tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially tupleTyCon Boxed i = fst (boxedTupleArr ! i) tupleTyCon Unboxed i = fst (unboxedTupleArr ! i) tupleTyConName :: TupleSort -> Arity -> Name tupleTyConName ConstraintTuple a = cTupleTyConName a tupleTyConName BoxedTuple a = tyConName (tupleTyCon Boxed a) tupleTyConName UnboxedTuple a = tyConName (tupleTyCon Unboxed a) promotedTupleDataCon :: Boxity -> Arity -> TyCon promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i) tupleDataCon :: Boxity -> Arity -> DataCon tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially tupleDataCon Boxed i = snd (boxedTupleArr ! i) tupleDataCon Unboxed i = snd (unboxedTupleArr ! i) tupleDataConName :: Boxity -> Arity -> Name tupleDataConName sort i = dataConName (tupleDataCon sort i) boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]] unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] -- | Given the TupleRep/SumRep tycon and list of RuntimeReps of the unboxed -- tuple/sum arguments, produces the return kind of an unboxed tuple/sum type -- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep -- [IntRep, LiftedRep])@ unboxedTupleSumKind :: TyCon -> [Type] -> Kind unboxedTupleSumKind tc rr_tys = tYPE (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys]) -- | Specialization of 'unboxedTupleSumKind' for tuples unboxedTupleKind :: [Type] -> Kind unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon mk_tuple :: Boxity -> Int -> (TyCon,DataCon) mk_tuple Boxed arity = (tycon, tuple_con) where tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con BoxedTuple flavour tc_binders = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind) tc_res_kind = liftedTypeKind tc_arity = arity flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) dc_tvs = binderVars tc_binders dc_arg_tys = mkTyVarTys dc_tvs tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon boxity = Boxed modu = gHC_TUPLE tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq (ATyCon tycon) BuiltInSyntax dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq (AConLike (RealDataCon tuple_con)) BuiltInSyntax tc_uniq = mkTupleTyConUnique boxity arity dc_uniq = mkTupleDataConUnique boxity arity mk_tuple Unboxed arity = (tycon, tuple_con) where tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con UnboxedTuple flavour -- See Note [Unboxed tuple RuntimeRep vars] in TyCon -- Kind: forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> # tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) (\ks -> map tYPE ks) tc_res_kind = unboxedTupleKind rr_tys tc_arity = arity * 2 flavour = UnboxedAlgTyCon $ Just (mkPrelTyConRepName tc_name) dc_tvs = binderVars tc_binders (rr_tys, dc_arg_tys) = splitAt arity (mkTyVarTys dc_tvs) tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon boxity = Unboxed modu = gHC_PRIM tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq (ATyCon tycon) BuiltInSyntax dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq (AConLike (RealDataCon tuple_con)) BuiltInSyntax tc_uniq = mkTupleTyConUnique boxity arity dc_uniq = mkTupleDataConUnique boxity arity unitTyCon :: TyCon unitTyCon = tupleTyCon Boxed 0 unitTyConKey :: Unique unitTyConKey = getUnique unitTyCon unitDataCon :: DataCon unitDataCon = head (tyConDataCons unitTyCon) unitDataConId :: Id unitDataConId = dataConWorkId unitDataCon pairTyCon :: TyCon pairTyCon = tupleTyCon Boxed 2 unboxedUnitTyCon :: TyCon unboxedUnitTyCon = tupleTyCon Unboxed 0 unboxedUnitDataCon :: DataCon unboxedUnitDataCon = tupleDataCon Unboxed 0 {- ********************************************************************* * * Unboxed sums * * ********************************************************************* -} -- | OccName for n-ary unboxed sum type constructor. mkSumTyConOcc :: Arity -> OccName mkSumTyConOcc n = mkOccName tcName str where -- No need to cache these, the caching is done in mk_sum str = '(' : '#' : bars ++ "#)" bars = replicate (n-1) '|' -- | OccName for i-th alternative of n-ary unboxed sum data constructor. mkSumDataConOcc :: ConTag -> Arity -> OccName mkSumDataConOcc alt n = mkOccName dataName str where -- No need to cache these, the caching is done in mk_sum str = '(' : '#' : bars alt ++ '_' : bars (n - alt - 1) ++ "#)" bars i = replicate i '|' -- | Type constructor for n-ary unboxed sum. sumTyCon :: Arity -> TyCon sumTyCon arity | arity > mAX_SUM_SIZE = fst (mk_sum arity) -- Build one specially | arity < 2 = panic ("sumTyCon: Arity starts from 2. (arity: " ++ show arity ++ ")") | otherwise = fst (unboxedSumArr ! arity) -- | Data constructor for i-th alternative of a n-ary unboxed sum. sumDataCon :: ConTag -- Alternative -> Arity -- Arity -> DataCon sumDataCon alt arity | alt > arity = panic ("sumDataCon: index out of bounds: alt: " ++ show alt ++ " > arity " ++ show arity) | alt <= 0 = panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt ++ ", arity: " ++ show arity ++ ")") | arity < 2 = panic ("sumDataCon: Arity starts from 2. (alt: " ++ show alt ++ ", arity: " ++ show arity ++ ")") | arity > mAX_SUM_SIZE = snd (mk_sum arity) ! (alt - 1) -- Build one specially | otherwise = snd (unboxedSumArr ! arity) ! (alt - 1) -- | Cached type and data constructors for sums. The outer array is -- indexed by the arity of the sum and the inner array is indexed by -- the alternative. unboxedSumArr :: Array Int (TyCon, Array Int DataCon) unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]] -- | Specialization of 'unboxedTupleSumKind' for sums unboxedSumKind :: [Type] -> Kind unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon -- | Create type constructor and data constructors for n-ary unboxed sum. mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon) mk_sum arity = (tycon, sum_cons) where tycon = mkSumTyCon tc_name tc_binders tc_res_kind (arity * 2) tyvars (elems sum_cons) (UnboxedAlgTyCon rep_name) -- Unboxed sums are currently not Typeable due to efficiency concerns. See #13276. rep_name = Nothing -- Just $ mkPrelTyConRepName tc_name tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) (\ks -> map tYPE ks) tyvars = binderVars tc_binders tc_res_kind = unboxedSumKind rr_tys (rr_tys, tyvar_tys) = splitAt arity (mkTyVarTys tyvars) tc_name = mkWiredInName gHC_PRIM (mkSumTyConOcc arity) tc_uniq (ATyCon tycon) BuiltInSyntax sum_cons = listArray (0,arity-1) [sum_con i | i <- [0..arity-1]] sum_con i = let dc = pcDataCon dc_name tyvars -- univ tyvars [tyvar_tys !! i] -- arg types tycon dc_name = mkWiredInName gHC_PRIM (mkSumDataConOcc i arity) (dc_uniq i) (AConLike (RealDataCon dc)) BuiltInSyntax in dc tc_uniq = mkSumTyConUnique arity dc_uniq i = mkSumDataConUnique i arity {- ************************************************************************ * * Equality types and classes * * ********************************************************************* -} -- See Note [The equality types story] in TysPrim -- ((~~) :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint) -- -- It's tempting to put functional dependencies on (~~), but it's not -- necessary because the functional-dependency coverage check looks -- through superclasses, and (~#) is handled in that check. eqTyCon, heqTyCon, coercibleTyCon :: TyCon eqClass, heqClass, coercibleClass :: Class eqDataCon, heqDataCon, coercibleDataCon :: DataCon eqSCSelId, heqSCSelId, coercibleSCSelId :: Id (eqTyCon, eqClass, eqDataCon, eqSCSelId) = (tycon, klass, datacon, sc_sel_id) where tycon = mkClassTyCon eqTyConName binders roles rhs klass (mkPrelTyConRepName eqTyConName) klass = mk_class tycon sc_pred sc_sel_id datacon = pcDataCon eqDataConName tvs [sc_pred] tycon -- Kind: forall k. k -> k -> Constraint binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) roles = [Nominal, Nominal, Nominal] rhs = mkDataTyConRhs [datacon] tvs@[k,a,b] = binderVars binders sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys [k,k,a,b]) sc_sel_id = mkDictSelId eqSCSelIdName klass (heqTyCon, heqClass, heqDataCon, heqSCSelId) = (tycon, klass, datacon, sc_sel_id) where tycon = mkClassTyCon heqTyConName binders roles rhs klass (mkPrelTyConRepName heqTyConName) klass = mk_class tycon sc_pred sc_sel_id datacon = pcDataCon heqDataConName tvs [sc_pred] tycon -- Kind: forall k1 k2. k1 -> k2 -> Constraint binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id roles = [Nominal, Nominal, Nominal, Nominal] rhs = mkDataTyConRhs [datacon] tvs = binderVars binders sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys tvs) sc_sel_id = mkDictSelId heqSCSelIdName klass (coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId) = (tycon, klass, datacon, sc_sel_id) where tycon = mkClassTyCon coercibleTyConName binders roles rhs klass (mkPrelTyConRepName coercibleTyConName) klass = mk_class tycon sc_pred sc_sel_id datacon = pcDataCon coercibleDataConName tvs [sc_pred] tycon -- Kind: forall k. k -> k -> Constraint binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) roles = [Nominal, Representational, Representational] rhs = mkDataTyConRhs [datacon] tvs@[k,a,b] = binderVars binders sc_pred = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b]) sc_sel_id = mkDictSelId coercibleSCSelIdName klass mk_class :: TyCon -> PredType -> Id -> Class mk_class tycon sc_pred sc_sel_id = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id] [] [] (mkAnd []) tycon {- ********************************************************************* * * Kinds and RuntimeRep * * ********************************************************************* -} -- For information about the usage of the following type, -- see Note [TYPE and RuntimeRep] in module TysPrim runtimeRepTy :: Type runtimeRepTy = mkTyConTy runtimeRepTyCon -- Type synonyms; see Note [TYPE and RuntimeRep] in TysPrim -- type Type = tYPE 'LiftedRep liftedTypeKindTyCon :: TyCon liftedTypeKindTyCon = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] (tYPE liftedRepTy) runtimeRepTyCon :: TyCon runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing [] (vecRepDataCon : tupleRepDataCon : sumRepDataCon : runtimeRepSimpleDataCons) vecRepDataCon :: DataCon vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon , mkTyConTy vecElemTyCon ] runtimeRepTyCon (RuntimeRep prim_rep_fun) where -- See Note [Getting from RuntimeRep to PrimRep] in RepType prim_rep_fun [count, elem] | VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count) , VecElem e <- tyConRuntimeRepInfo (tyConAppTyCon elem) = [VecRep n e] prim_rep_fun args = pprPanic "vecRepDataCon" (ppr args) vecRepDataConTyCon :: TyCon vecRepDataConTyCon = promoteDataCon vecRepDataCon tupleRepDataCon :: DataCon tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun) where -- See Note [Getting from RuntimeRep to PrimRep] in RepType prim_rep_fun [rr_ty_list] = concatMap (runtimeRepPrimRep doc) rr_tys where rr_tys = extractPromotedList rr_ty_list doc = text "tupleRepDataCon" <+> ppr rr_tys prim_rep_fun args = pprPanic "tupleRepDataCon" (ppr args) tupleRepDataConTyCon :: TyCon tupleRepDataConTyCon = promoteDataCon tupleRepDataCon sumRepDataCon :: DataCon sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun) where -- See Note [Getting from RuntimeRep to PrimRep] in RepType prim_rep_fun [rr_ty_list] = map slotPrimRep (ubxSumRepType prim_repss) where rr_tys = extractPromotedList rr_ty_list doc = text "sumRepDataCon" <+> ppr rr_tys prim_repss = map (runtimeRepPrimRep doc) rr_tys prim_rep_fun args = pprPanic "sumRepDataCon" (ppr args) sumRepDataConTyCon :: TyCon sumRepDataConTyCon = promoteDataCon sumRepDataCon -- See Note [Wiring in RuntimeRep] -- See Note [Getting from RuntimeRep to PrimRep] in RepType runtimeRepSimpleDataCons :: [DataCon] liftedRepDataCon :: DataCon runtimeRepSimpleDataCons@(liftedRepDataCon : _) = zipWithLazy mk_runtime_rep_dc [ LiftedRep, UnliftedRep , IntRep , Int8Rep, Int16Rep, Int32Rep, Int64Rep , WordRep , Word8Rep, Word16Rep, Word32Rep, Word64Rep , AddrRep , FloatRep, DoubleRep ] runtimeRepSimpleDataConNames where mk_runtime_rep_dc primrep name = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep])) -- See Note [Wiring in RuntimeRep] liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, wordRepDataConTy, word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type [liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, wordRepDataConTy, word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy ] = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons vecCountTyCon :: TyCon vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons -- See Note [Wiring in RuntimeRep] vecCountDataCons :: [DataCon] vecCountDataCons = zipWithLazy mk_vec_count_dc [ 2, 4, 8, 16, 32, 64 ] vecCountDataConNames where mk_vec_count_dc n name = pcSpecialDataCon name [] vecCountTyCon (VecCount n) -- See Note [Wiring in RuntimeRep] vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, vec64DataConTy :: Type [vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons vecElemTyCon :: TyCon vecElemTyCon = pcTyCon vecElemTyConName Nothing [] vecElemDataCons -- See Note [Wiring in RuntimeRep] vecElemDataCons :: [DataCon] vecElemDataCons = zipWithLazy mk_vec_elem_dc [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep , FloatElemRep, DoubleElemRep ] vecElemDataConNames where mk_vec_elem_dc elem name = pcSpecialDataCon name [] vecElemTyCon (VecElem elem) -- See Note [Wiring in RuntimeRep] int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, doubleElemRepDataConTy :: Type [int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon) vecElemDataCons liftedRepDataConTyCon :: TyCon liftedRepDataConTyCon = promoteDataCon liftedRepDataCon -- The type ('LiftedRep) liftedRepTy :: Type liftedRepTy = liftedRepDataConTy {- ********************************************************************* * * The boxed primitive types: Char, Int, etc * * ********************************************************************* -} boxingDataCon_maybe :: TyCon -> Maybe DataCon -- boxingDataCon_maybe Char# = C# -- boxingDataCon_maybe Int# = I# -- ... etc ... -- See Note [Boxing primitive types] boxingDataCon_maybe tc = lookupNameEnv boxing_constr_env (tyConName tc) boxing_constr_env :: NameEnv DataCon boxing_constr_env = mkNameEnv [(charPrimTyConName , charDataCon ) ,(intPrimTyConName , intDataCon ) ,(wordPrimTyConName , wordDataCon ) ,(floatPrimTyConName , floatDataCon ) ,(doublePrimTyConName, doubleDataCon) ] {- Note [Boxing primitive types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For a handful of primitive types (Int, Char, Word, Flaot, Double), we can readily box and an unboxed version (Int#, Char# etc) using the corresponding data constructor. This is useful in a couple of places, notably let-floating -} charTy :: Type charTy = mkTyConTy charTyCon charTyCon :: TyCon charTyCon = pcTyCon charTyConName (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsChar"))) [] [charDataCon] charDataCon :: DataCon charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon stringTy :: Type stringTy = mkListTy charTy -- convenience only intTy :: Type intTy = mkTyConTy intTyCon intTyCon :: TyCon intTyCon = pcTyCon intTyConName (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt"))) [] [intDataCon] intDataCon :: DataCon intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon wordTy :: Type wordTy = mkTyConTy wordTyCon wordTyCon :: TyCon wordTyCon = pcTyCon wordTyConName (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord"))) [] [wordDataCon] wordDataCon :: DataCon wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon word8Ty :: Type word8Ty = mkTyConTy word8TyCon word8TyCon :: TyCon word8TyCon = pcTyCon word8TyConName (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord8"))) [] [word8DataCon] word8DataCon :: DataCon word8DataCon = pcDataCon word8DataConName [] [wordPrimTy] word8TyCon floatTy :: Type floatTy = mkTyConTy floatTyCon floatTyCon :: TyCon floatTyCon = pcTyCon floatTyConName (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsFloat"))) [] [floatDataCon] floatDataCon :: DataCon floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon doubleTy :: Type doubleTy = mkTyConTy doubleTyCon doubleTyCon :: TyCon doubleTyCon = pcTyCon doubleTyConName (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsDouble"))) [] [doubleDataCon] doubleDataCon :: DataCon doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon {- ************************************************************************ * * The Bool type * * ************************************************************************ An ordinary enumeration type, but deeply wired in. There are no magical operations on @Bool@ (just the regular Prelude code). {\em BEGIN IDLE SPECULATION BY SIMON} This is not the only way to encode @Bool@. A more obvious coding makes @Bool@ just a boxed up version of @Bool#@, like this: \begin{verbatim} type Bool# = Int# data Bool = MkBool Bool# \end{verbatim} Unfortunately, this doesn't correspond to what the Report says @Bool@ looks like! Furthermore, we get slightly less efficient code (I think) with this coding. @gtInt@ would look like this: \begin{verbatim} gtInt :: Int -> Int -> Bool gtInt x y = case x of I# x# -> case y of I# y# -> case (gtIntPrim x# y#) of b# -> MkBool b# \end{verbatim} Notice that the result of the @gtIntPrim@ comparison has to be turned into an integer (here called @b#@), and returned in a @MkBool@ box. The @if@ expression would compile to this: \begin{verbatim} case (gtInt x y) of MkBool b# -> case b# of { 1# -> e1; 0# -> e2 } \end{verbatim} I think this code is a little less efficient than the previous code, but I'm not certain. At all events, corresponding with the Report is important. The interesting thing is that the language is expressive enough to describe more than one alternative; and that a type doesn't necessarily need to be a straightforwardly boxed version of its primitive counterpart. {\em END IDLE SPECULATION BY SIMON} -} boolTy :: Type boolTy = mkTyConTy boolTyCon boolTyCon :: TyCon boolTyCon = pcTyCon boolTyConName (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsBool"))) [] [falseDataCon, trueDataCon] falseDataCon, trueDataCon :: DataCon falseDataCon = pcDataCon falseDataConName [] [] boolTyCon trueDataCon = pcDataCon trueDataConName [] [] boolTyCon falseDataConId, trueDataConId :: Id falseDataConId = dataConWorkId falseDataCon trueDataConId = dataConWorkId trueDataCon orderingTyCon :: TyCon orderingTyCon = pcTyCon orderingTyConName Nothing [] [ordLTDataCon, ordEQDataCon, ordGTDataCon] ordLTDataCon, ordEQDataCon, ordGTDataCon :: DataCon ordLTDataCon = pcDataCon ordLTDataConName [] [] orderingTyCon ordEQDataCon = pcDataCon ordEQDataConName [] [] orderingTyCon ordGTDataCon = pcDataCon ordGTDataConName [] [] orderingTyCon ordLTDataConId, ordEQDataConId, ordGTDataConId :: Id ordLTDataConId = dataConWorkId ordLTDataCon ordEQDataConId = dataConWorkId ordEQDataCon ordGTDataConId = dataConWorkId ordGTDataCon {- ************************************************************************ * * The List type Special syntax, deeply wired in, but otherwise an ordinary algebraic data type * * ************************************************************************ data [] a = [] | a : (List a) -} mkListTy :: Type -> Type mkListTy ty = mkTyConApp listTyCon [ty] listTyCon :: TyCon listTyCon = buildAlgTyCon listTyConName alpha_tyvar [Representational] Nothing [] (mkDataTyConRhs [nilDataCon, consDataCon]) False (VanillaAlgTyCon $ mkPrelTyConRepName listTyConName) -- See also Note [Empty lists] in GHC.Hs.Expr. nilDataCon :: DataCon nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon consDataCon :: DataCon consDataCon = pcDataConWithFixity True {- Declared infix -} consDataConName alpha_tyvar [] alpha_tyvar [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon -- Interesting: polymorphic recursion would help here. -- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy -- gets the over-specific type (Type -> Type) -- Wired-in type Maybe maybeTyCon :: TyCon maybeTyCon = pcTyCon maybeTyConName Nothing alpha_tyvar [nothingDataCon, justDataCon] nothingDataCon :: DataCon nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon justDataCon :: DataCon justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon {- ** ********************************************************************* * * The tuple types * * ************************************************************************ The tuple types are definitely magic, because they form an infinite family. \begin{itemize} \item They have a special family of type constructors, of type @TyCon@ These contain the tycon arity, but don't require a Unique. \item They have a special family of constructors, of type @Id@. Again these contain their arity but don't need a Unique. \item There should be a magic way of generating the info tables and entry code for all tuples. But at the moment we just compile a Haskell source file\srcloc{lib/prelude/...} containing declarations like: \begin{verbatim} data Tuple0 = Tup0 data Tuple2 a b = Tup2 a b data Tuple3 a b c = Tup3 a b c data Tuple4 a b c d = Tup4 a b c d ... \end{verbatim} The print-names associated with the magic @Id@s for tuple constructors ``just happen'' to be the same as those generated by these declarations. \item The instance environment should have a magic way to know that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and so on. \ToDo{Not implemented yet.} \item There should also be a way to generate the appropriate code for each of these instances, but (like the info tables and entry code) it is done by enumeration\srcloc{lib/prelude/InTup?.hs}. \end{itemize} -} -- | Make a tuple type. The list of types should /not/ include any -- RuntimeRep specifications. Boxed 1-tuples are flattened. -- See Note [One-tuples] mkTupleTy :: Boxity -> [Type] -> Type -- Special case for *boxed* 1-tuples, which are represented by the type itself mkTupleTy Boxed [ty] = ty mkTupleTy boxity tys = mkTupleTy1 boxity tys -- | Make a tuple type. The list of types should /not/ include any -- RuntimeRep specifications. Boxed 1-tuples are *not* flattened. -- See Note [One-tuples] and Note [Don't flatten tuples from HsSyn] -- in MkCore mkTupleTy1 :: Boxity -> [Type] -> Type mkTupleTy1 Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys mkTupleTy1 Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys)) (map getRuntimeRep tys ++ tys) -- | Build the type of a small tuple that holds the specified type of thing -- Flattens 1-tuples. See Note [One-tuples]. mkBoxedTupleTy :: [Type] -> Type mkBoxedTupleTy tys = mkTupleTy Boxed tys unitTy :: Type unitTy = mkTupleTy Boxed [] {- ********************************************************************* * * The sum types * * ************************************************************************ -} mkSumTy :: [Type] -> Type mkSumTy tys = mkTyConApp (sumTyCon (length tys)) (map getRuntimeRep tys ++ tys) -- Promoted Booleans promotedFalseDataCon, promotedTrueDataCon :: TyCon promotedTrueDataCon = promoteDataCon trueDataCon promotedFalseDataCon = promoteDataCon falseDataCon -- Promoted Maybe promotedNothingDataCon, promotedJustDataCon :: TyCon promotedNothingDataCon = promoteDataCon nothingDataCon promotedJustDataCon = promoteDataCon justDataCon -- Promoted Ordering promotedLTDataCon , promotedEQDataCon , promotedGTDataCon :: TyCon promotedLTDataCon = promoteDataCon ordLTDataCon promotedEQDataCon = promoteDataCon ordEQDataCon promotedGTDataCon = promoteDataCon ordGTDataCon -- Promoted List promotedConsDataCon, promotedNilDataCon :: TyCon promotedConsDataCon = promoteDataCon consDataCon promotedNilDataCon = promoteDataCon nilDataCon -- | Make a *promoted* list. mkPromotedListTy :: Kind -- ^ of the elements of the list -> [Type] -- ^ elements -> Type mkPromotedListTy k tys = foldr cons nil tys where cons :: Type -- element -> Type -- list -> Type cons elt list = mkTyConApp promotedConsDataCon [k, elt, list] nil :: Type nil = mkTyConApp promotedNilDataCon [k] -- | Extract the elements of a promoted list. Panics if the type is not a -- promoted list extractPromotedList :: Type -- ^ The promoted list -> [Type] extractPromotedList tys = go tys where go list_ty | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty = ASSERT( tc `hasKey` consDataConKey ) t : go ts | Just (tc, [_k]) <- splitTyConApp_maybe list_ty = ASSERT( tc `hasKey` nilDataConKey ) [] | otherwise = pprPanic "extractPromotedList" (ppr tys) ghc-lib-parser-8.10.2.20200808/compiler/types/Unify.hs0000644000000000000000000017171413713635745020126 0ustar0000000000000000-- (c) The University of Glasgow 2006 {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} module Unify ( tcMatchTy, tcMatchTyKi, tcMatchTys, tcMatchTyKis, tcMatchTyX, tcMatchTysX, tcMatchTyKisX, tcMatchTyX_BM, ruleMatchTyKiX, -- * Rough matching roughMatchTcs, instanceCantMatch, typesCantMatch, -- Side-effect free unification tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis, tcUnifyTysFG, tcUnifyTyWithTFs, BindFlag(..), UnifyResult, UnifyResultM(..), -- Matching a type against a lifted type (coercion) liftCoMatch ) where #include "GhclibHsVersions.h" import GhcPrelude import Var import VarEnv import VarSet import Name( Name ) import Type hiding ( getTvSubstEnv ) import Coercion hiding ( getCvSubstEnv ) import TyCon import TyCoRep import TyCoFVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) import TyCoSubst ( mkTvSubst ) import FV( FV, fvVarSet, fvVarList ) import Util import Pair import Outputable import UniqFM import UniqSet import Control.Monad import qualified Control.Monad.Fail as MonadFail import Control.Applicative hiding ( empty ) import qualified Control.Applicative {- Unification is much tricker than you might think. 1. The substitution we generate binds the *template type variables* which are given to us explicitly. 2. We want to match in the presence of foralls; e.g (forall a. t1) ~ (forall b. t2) That is what the RnEnv2 is for; it does the alpha-renaming that makes it as if a and b were the same variable. Initialising the RnEnv2, so that it can generate a fresh binder when necessary, entails knowing the free variables of both types. 3. We must be careful not to bind a template type variable to a locally bound variable. E.g. (forall a. x) ~ (forall b. b) where x is the template type variable. Then we do not want to bind x to a/b! This is a kind of occurs check. The necessary locals accumulate in the RnEnv2. Note [tcMatchTy vs tcMatchTyKi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This module offers two variants of matching: with kinds and without. The TyKi variant takes two types, of potentially different kinds, and matches them. Along the way, it necessarily also matches their kinds. The Ty variant instead assumes that the kinds are already eqType and so skips matching up the kinds. How do you choose between them? 1. If you know that the kinds of the two types are eqType, use the Ty variant. It is more efficient, as it does less work. 2. If the kinds of variables in the template type might mention type families, use the Ty variant (and do other work to make sure the kinds work out). These pure unification functions do a straightforward syntactic unification and do no complex reasoning about type families. Note that the types of the variables in instances can indeed mention type families, so instance lookup must use the Ty variant. (Nothing goes terribly wrong -- no panics -- if there might be type families in kinds in the TyKi variant. You just might get match failure even though a reducing a type family would lead to success.) 3. Otherwise, if you're sure that the variable kinds do not mention type families and you're not already sure that the kind of the template equals the kind of the target, then use the TyKi version. -} -- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1)) -- @s@ such that @s(t1)@ equals @t2@. -- The returned substitution might bind coercion variables, -- if the variable is an argument to a GADT constructor. -- -- Precondition: typeKind ty1 `eqType` typeKind ty2 -- -- We don't pass in a set of "template variables" to be bound -- by the match, because tcMatchTy (and similar functions) are -- always used on top-level types, so we can bind any of the -- free variables of the LHS. -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTy :: Type -> Type -> Maybe TCvSubst tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] tcMatchTyX_BM :: (TyVar -> BindFlag) -> TCvSubst -> Type -> Type -> Maybe TCvSubst tcMatchTyX_BM bind_me subst ty1 ty2 = tc_match_tys_x bind_me False subst [ty1] [ty2] -- | Like 'tcMatchTy', but allows the kinds of the types to differ, -- and thus matches them as well. -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTyKi :: Type -> Type -> Maybe TCvSubst tcMatchTyKi ty1 ty2 = tc_match_tys (const BindMe) True [ty1] [ty2] -- | This is similar to 'tcMatchTy', but extends a substitution -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTyX :: TCvSubst -- ^ Substitution to extend -> Type -- ^ Template -> Type -- ^ Target -> Maybe TCvSubst tcMatchTyX subst ty1 ty2 = tc_match_tys_x (const BindMe) False subst [ty1] [ty2] -- | Like 'tcMatchTy' but over a list of types. -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTys :: [Type] -- ^ Template -> [Type] -- ^ Target -> Maybe TCvSubst -- ^ One-shot; in principle the template -- variables could be free in the target tcMatchTys tys1 tys2 = tc_match_tys (const BindMe) False tys1 tys2 -- | Like 'tcMatchTyKi' but over a list of types. -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTyKis :: [Type] -- ^ Template -> [Type] -- ^ Target -> Maybe TCvSubst -- ^ One-shot substitution tcMatchTyKis tys1 tys2 = tc_match_tys (const BindMe) True tys1 tys2 -- | Like 'tcMatchTys', but extending a substitution -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTysX :: TCvSubst -- ^ Substitution to extend -> [Type] -- ^ Template -> [Type] -- ^ Target -> Maybe TCvSubst -- ^ One-shot substitution tcMatchTysX subst tys1 tys2 = tc_match_tys_x (const BindMe) False subst tys1 tys2 -- | Like 'tcMatchTyKis', but extending a substitution -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTyKisX :: TCvSubst -- ^ Substitution to extend -> [Type] -- ^ Template -> [Type] -- ^ Target -> Maybe TCvSubst -- ^ One-shot substitution tcMatchTyKisX subst tys1 tys2 = tc_match_tys_x (const BindMe) True subst tys1 tys2 -- | Same as tc_match_tys_x, but starts with an empty substitution tc_match_tys :: (TyVar -> BindFlag) -> Bool -- ^ match kinds? -> [Type] -> [Type] -> Maybe TCvSubst tc_match_tys bind_me match_kis tys1 tys2 = tc_match_tys_x bind_me match_kis (mkEmptyTCvSubst in_scope) tys1 tys2 where in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) -- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX' tc_match_tys_x :: (TyVar -> BindFlag) -> Bool -- ^ match kinds? -> TCvSubst -> [Type] -> [Type] -> Maybe TCvSubst tc_match_tys_x bind_me match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2 = case tc_unify_tys bind_me False -- Matching, not unifying False -- Not an injectivity check match_kis (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of Unifiable (tv_env', cv_env') -> Just $ TCvSubst in_scope tv_env' cv_env' _ -> Nothing -- | This one is called from the expression matcher, -- which already has a MatchEnv in hand ruleMatchTyKiX :: TyCoVarSet -- ^ template variables -> RnEnv2 -> TvSubstEnv -- ^ type substitution to extend -> Type -- ^ Template -> Type -- ^ Target -> Maybe TvSubstEnv ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target -- See Note [Kind coercions in Unify] = case tc_unify_tys (matchBindFun tmpl_tvs) False False True -- <-- this means to match the kinds rn_env tenv emptyCvSubstEnv [tmpl] [target] of Unifiable (tenv', _) -> Just tenv' _ -> Nothing matchBindFun :: TyCoVarSet -> TyVar -> BindFlag matchBindFun tvs tv = if tv `elemVarSet` tvs then BindMe else Skolem {- ********************************************************************* * * Rough matching * * ********************************************************************* -} -- See Note [Rough match] field in InstEnv roughMatchTcs :: [Type] -> [Maybe Name] roughMatchTcs tys = map rough tys where rough ty | Just (ty', _) <- splitCastTy_maybe ty = rough ty' | Just (tc,_) <- splitTyConApp_maybe ty = Just (tyConName tc) | otherwise = Nothing instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool -- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot -- possibly be instantiated to actual, nor vice versa; -- False is non-committal instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as instanceCantMatch _ _ = False -- Safe itemCantMatch :: Maybe Name -> Maybe Name -> Bool itemCantMatch (Just t) (Just a) = t /= a itemCantMatch _ _ = False {- ************************************************************************ * * GADTs * * ************************************************************************ Note [Pruning dead case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T a where T1 :: T Int T2 :: T a newtype X = MkX Int newtype Y = MkY Char type family F a type instance F Bool = Int Now consider case x of { T1 -> e1; T2 -> e2 } The question before the house is this: if I know something about the type of x, can I prune away the T1 alternative? Suppose x::T Char. It's impossible to construct a (T Char) using T1, Answer = YES we can prune the T1 branch (clearly) Suppose x::T (F a), where 'a' is in scope. Then 'a' might be instantiated to 'Bool', in which case x::T Int, so ANSWER = NO (clearly) We see here that we want precisely the apartness check implemented within tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely apart. Note that since we are simply dropping dead code, a conservative test suffices. -} -- | Given a list of pairs of types, are any two members of a pair surely -- apart, even after arbitrary type function evaluation and substitution? typesCantMatch :: [(Type,Type)] -> Bool -- See Note [Pruning dead case alternatives] typesCantMatch prs = any (uncurry cant_match) prs where cant_match :: Type -> Type -> Bool cant_match t1 t2 = case tcUnifyTysFG (const BindMe) [t1] [t2] of SurelyApart -> True _ -> False {- ************************************************************************ * * Unification * * ************************************************************************ Note [Fine-grained unification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" -- no substitution to finite types makes these match. But, a substitution to *infinite* types can unify these two types: [x |-> [[[...]]], y |-> [[[...]]] ]. Why do we care? Consider these two type family instances: type instance F x x = Int type instance F [y] y = Bool If we also have type instance Looper = [Looper] then the instances potentially overlap. The solution is to use unification over infinite terms. This is possible (see [1] for lots of gory details), but a full algorithm is a little more power than we need. Instead, we make a conservative approximation and just omit the occurs check. [1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf tcUnifyTys considers an occurs-check problem as the same as general unification failure. tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check failure ("MaybeApart"), or general failure ("SurelyApart"). See also #8162. It's worth noting that unification in the presence of infinite types is not complete. This means that, sometimes, a closed type family does not reduce when it should. See test case indexed-types/should_fail/Overlap15 for an example. Note [The substitution in MaybeApart] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why? Because consider unifying these: (a, a, Int) ~ (b, [b], Bool) If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we apply the subst we have so far and discover that we need [b |-> [b]]. Because this fails the occurs check, we say that the types are MaybeApart (see above Note [Fine-grained unification]). But, we can't stop there! Because if we continue, we discover that Int is SurelyApart from Bool, and therefore the types are apart. This has practical consequences for the ability for closed type family applications to reduce. See test case indexed-types/should_compile/Overlap14. Note [Unifying with skolems] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we discover that two types unify if and only if a skolem variable is substituted, we can't properly unify the types. But, that skolem variable may later be instantiated with a unifyable type. So, we return maybeApart in these cases. -} -- | Simple unification of two types; all type variables are bindable -- Precondition: the kinds are already equal tcUnifyTy :: Type -> Type -- All tyvars are bindable -> Maybe TCvSubst -- A regular one-shot (idempotent) substitution tcUnifyTy t1 t2 = tcUnifyTys (const BindMe) [t1] [t2] -- | Like 'tcUnifyTy', but also unifies the kinds tcUnifyTyKi :: Type -> Type -> Maybe TCvSubst tcUnifyTyKi t1 t2 = tcUnifyTyKis (const BindMe) [t1] [t2] -- | Unify two types, treating type family applications as possibly unifying -- with anything and looking through injective type family applications. -- Precondition: kinds are the same tcUnifyTyWithTFs :: Bool -- ^ True <=> do two-way unification; -- False <=> do one-way matching. -- See end of sec 5.2 from the paper -> Type -> Type -> Maybe TCvSubst -- This algorithm is an implementation of the "Algorithm U" presented in -- the paper "Injective type families for Haskell", Figures 2 and 3. -- The code is incorporated with the standard unifier for convenience, but -- its operation should match the specification in the paper. tcUnifyTyWithTFs twoWay t1 t2 = case tc_unify_tys (const BindMe) twoWay True False rn_env emptyTvSubstEnv emptyCvSubstEnv [t1] [t2] of Unifiable (subst, _) -> Just $ maybe_fix subst MaybeApart (subst, _) -> Just $ maybe_fix subst -- we want to *succeed* in questionable cases. This is a -- pre-unification algorithm. SurelyApart -> Nothing where in_scope = mkInScopeSet $ tyCoVarsOfTypes [t1, t2] rn_env = mkRnEnv2 in_scope maybe_fix | twoWay = niFixTCvSubst | otherwise = mkTvSubst in_scope -- when matching, don't confuse -- domain with range ----------------- tcUnifyTys :: (TyCoVar -> BindFlag) -> [Type] -> [Type] -> Maybe TCvSubst -- ^ A regular one-shot (idempotent) substitution -- that unifies the erased types. See comments -- for 'tcUnifyTysFG' -- The two types may have common type variables, and indeed do so in the -- second call to tcUnifyTys in FunDeps.checkClsFD tcUnifyTys bind_fn tys1 tys2 = case tcUnifyTysFG bind_fn tys1 tys2 of Unifiable result -> Just result _ -> Nothing -- | Like 'tcUnifyTys' but also unifies the kinds tcUnifyTyKis :: (TyCoVar -> BindFlag) -> [Type] -> [Type] -> Maybe TCvSubst tcUnifyTyKis bind_fn tys1 tys2 = case tcUnifyTyKisFG bind_fn tys1 tys2 of Unifiable result -> Just result _ -> Nothing -- This type does double-duty. It is used in the UM (unifier monad) and to -- return the final result. See Note [Fine-grained unification] type UnifyResult = UnifyResultM TCvSubst data UnifyResultM a = Unifiable a -- the subst that unifies the types | MaybeApart a -- the subst has as much as we know -- it must be part of a most general unifier -- See Note [The substitution in MaybeApart] | SurelyApart deriving Functor instance Applicative UnifyResultM where pure = Unifiable (<*>) = ap instance Monad UnifyResultM where SurelyApart >>= _ = SurelyApart MaybeApart x >>= f = case f x of Unifiable y -> MaybeApart y other -> other Unifiable x >>= f = f x instance Alternative UnifyResultM where empty = SurelyApart a@(Unifiable {}) <|> _ = a _ <|> b@(Unifiable {}) = b a@(MaybeApart {}) <|> _ = a _ <|> b@(MaybeApart {}) = b SurelyApart <|> SurelyApart = SurelyApart instance MonadPlus UnifyResultM -- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose -- domain elements all respond 'BindMe' to @bind_tv@) such that -- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned -- Coercions. This version requires that the kinds of the types are the same, -- if you unify left-to-right. tcUnifyTysFG :: (TyVar -> BindFlag) -> [Type] -> [Type] -> UnifyResult tcUnifyTysFG bind_fn tys1 tys2 = tc_unify_tys_fg False bind_fn tys1 tys2 tcUnifyTyKisFG :: (TyVar -> BindFlag) -> [Type] -> [Type] -> UnifyResult tcUnifyTyKisFG bind_fn tys1 tys2 = tc_unify_tys_fg True bind_fn tys1 tys2 tc_unify_tys_fg :: Bool -> (TyVar -> BindFlag) -> [Type] -> [Type] -> UnifyResult tc_unify_tys_fg match_kis bind_fn tys1 tys2 = do { (env, _) <- tc_unify_tys bind_fn True False match_kis env emptyTvSubstEnv emptyCvSubstEnv tys1 tys2 ; return $ niFixTCvSubst env } where vars = tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 env = mkRnEnv2 $ mkInScopeSet vars -- | This function is actually the one to call the unifier -- a little -- too general for outside clients, though. tc_unify_tys :: (TyVar -> BindFlag) -> AmIUnifying -- ^ True <=> unify; False <=> match -> Bool -- ^ True <=> doing an injectivity check -> Bool -- ^ True <=> treat the kinds as well -> RnEnv2 -> TvSubstEnv -- ^ substitution to extend -> CvSubstEnv -> [Type] -> [Type] -> UnifyResultM (TvSubstEnv, CvSubstEnv) -- NB: It's tempting to ASSERT here that, if we're not matching kinds, then -- the kinds of the types should be the same. However, this doesn't work, -- as the types may be a dependent telescope, where later types have kinds -- that mention variables occurring earlier in the list of types. Here's an -- example (from typecheck/should_fail/T12709): -- template: [rep :: RuntimeRep, a :: TYPE rep] -- target: [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep] -- We can see that matching the first pair will make the kinds of the second -- pair equal. Yet, we still don't need a separate pass to unify the kinds -- of these types, so it's appropriate to use the Ty variant of unification. -- See also Note [tcMatchTy vs tcMatchTyKi]. tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2 = initUM tv_env cv_env $ do { when match_kis $ unify_tys env kis1 kis2 ; unify_tys env tys1 tys2 ; (,) <$> getTvSubstEnv <*> getCvSubstEnv } where env = UMEnv { um_bind_fun = bind_fn , um_skols = emptyVarSet , um_unif = unif , um_inj_tf = inj_check , um_rn_env = rn_env } kis1 = map typeKind tys1 kis2 = map typeKind tys2 instance Outputable a => Outputable (UnifyResultM a) where ppr SurelyApart = text "SurelyApart" ppr (Unifiable x) = text "Unifiable" <+> ppr x ppr (MaybeApart x) = text "MaybeApart" <+> ppr x {- ************************************************************************ * * Non-idempotent substitution * * ************************************************************************ Note [Non-idempotent substitution] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ During unification we use a TvSubstEnv/CvSubstEnv pair that is (a) non-idempotent (b) loop-free; ie repeatedly applying it yields a fixed point Note [Finding the substitution fixpoint] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Finding the fixpoint of a non-idempotent substitution arising from a unification is much trickier than it looks, because of kinds. Consider T k (H k (f:k)) ~ T * (g:*) If we unify, we get the substitution [ k -> * , g -> H k (f:k) ] To make it idempotent we don't want to get just [ k -> * , g -> H * (f:k) ] We also want to substitute inside f's kind, to get [ k -> * , g -> H k (f:*) ] If we don't do this, we may apply the substitution to something, and get an ill-formed type, i.e. one where typeKind will fail. This happened, for example, in #9106. It gets worse. In #14164 we wanted to take the fixpoint of this substitution [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6) (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6)) , a_aY6 :-> a_aXQ ] We have to apply the substitution for a_aY6 two levels deep inside the invocation of F! We don't have a function that recursively applies substitutions inside the kinds of variable occurrences (and probably rightly so). So, we work as follows: 1. Start with the current substitution (which we are trying to fixpoint [ xs :-> F a (z :: a) (rest :: G a (z :: a)) , a :-> b ] 2. Take all the free vars of the range of the substitution: {a, z, rest, b} NB: the free variable finder closes over the kinds of variable occurrences 3. If none are in the domain of the substitution, stop. We have found a fixpoint. 4. Remove the variables that are bound by the substitution, leaving {z, rest, b} 5. Do a topo-sort to put them in dependency order: [ b :: *, z :: a, rest :: G a z ] 6. Apply the substitution left-to-right to the kinds of these tyvars, extending it each time with a new binding, so we finish up with [ xs :-> ..as before.. , a :-> b , b :-> b :: * , z :-> z :: b , rest :-> rest :: G b (z :: b) ] Note that rest now has the right kind 7. Apply this extended substitution (once) to the range of the /original/ substitution. (Note that we do the extended substitution would go on forever if you tried to find its fixpoint, because it maps z to z.) 8. And go back to step 1 In Step 6 we use the free vars from Step 2 as the initial in-scope set, because all of those variables appear in the range of the substitution, so they must all be in the in-scope set. But NB that the type substitution engine does not look up variables in the in-scope set; it is used only to ensure no shadowing. -} niFixTCvSubst :: TvSubstEnv -> TCvSubst -- Find the idempotent fixed point of the non-idempotent substitution -- This is surprisingly tricky: -- see Note [Finding the substitution fixpoint] -- ToDo: use laziness instead of iteration? niFixTCvSubst tenv | not_fixpoint = niFixTCvSubst (mapVarEnv (substTy subst) tenv) | otherwise = subst where range_fvs :: FV range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv) -- It's OK to use nonDetEltsUFM here because the -- order of range_fvs, range_tvs is immaterial range_tvs :: [TyVar] range_tvs = fvVarList range_fvs not_fixpoint = any in_domain range_tvs in_domain tv = tv `elemVarEnv` tenv free_tvs = scopedSort (filterOut in_domain range_tvs) -- See Note [Finding the substitution fixpoint], Step 6 init_in_scope = mkInScopeSet (fvVarSet range_fvs) subst = foldl' add_free_tv (mkTvSubst init_in_scope tenv) free_tvs add_free_tv :: TCvSubst -> TyVar -> TCvSubst add_free_tv subst tv = extendTvSubst subst tv (mkTyVarTy tv') where tv' = updateTyVarKind (substTy subst) tv niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet -- Apply the non-idempotent substitution to a set of type variables, -- remembering that the substitution isn't necessarily idempotent -- This is used in the occurs check, before extending the substitution niSubstTvSet tsubst tvs = nonDetFoldUniqSet (unionVarSet . get) emptyVarSet tvs -- It's OK to nonDetFoldUFM here because we immediately forget the -- ordering by creating a set. where get tv | Just ty <- lookupVarEnv tsubst tv = niSubstTvSet tsubst (tyCoVarsOfType ty) | otherwise = unitVarSet tv {- ************************************************************************ * * unify_ty: the main workhorse * * ************************************************************************ Note [Specification of unification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The pure unifier, unify_ty, defined in this module, tries to work out a substitution to make two types say True to eqType. NB: eqType is itself not purely syntactic; it accounts for CastTys; see Note [Non-trivial definitional equality] in TyCoRep Unlike the "impure unifiers" in the typechecker (the eager unifier in TcUnify, and the constraint solver itself in TcCanonical), the pure unifier It does /not/ work up to ~. The algorithm implemented here is rather delicate, and we depend on it to uphold certain properties. This is a summary of these required properties. Any reference to "flattening" refers to the flattening algorithm in FamInstEnv (See Note [Flattening] in FamInstEnv), not the flattening algorithm in the solver. Notation: θ,φ substitutions ξ type-function-free types τ,σ other types τ♭ type τ, flattened ≡ eqType (U1) Soundness. If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂). θ is a most general unifier for τ₁ and τ₂. (U2) Completeness. If (unify ξ₁ ξ₂) = SurelyApart, then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂). These two properties are stated as Property 11 in the "Closed Type Families" paper (POPL'14). Below, this paper is called [CTF]. (U3) Apartness under substitution. If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart, for any θ. (Property 12 from [CTF]) (U4) Apart types do not unify. If (unify ξ τ♭) = SurelyApart, then there exists no θ such that θ(ξ) = θ(τ). (Property 13 from [CTF]) THEOREM. Completeness w.r.t ~ If (unify τ₁♭ τ₂♭) = SurelyApart, then there exists no proof that (τ₁ ~ τ₂). PROOF. See appendix of [CTF]. The unification algorithm is used for type family injectivity, as described in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run in this mode, it has the following properties. (I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even after arbitrary type family reductions. Note that σ and τ are not flattened here. (I2) If (unify σ τ) = MaybeApart θ, and if some φ exists such that φ(σ) ~ φ(τ), then φ extends θ. Furthermore, the RULES matching algorithm requires this property, but only when using this algorithm for matching: (M1) If (match σ τ) succeeds with θ, then all matchable tyvars in σ are bound in θ. Property M1 means that we must extend the substitution with, say (a ↦ a) when appropriate during matching. See also Note [Self-substitution when matching]. (M2) Completeness of matching. If θ(σ) = τ, then (match σ τ) = Unifiable φ, where θ is an extension of φ. Sadly, property M2 and I2 conflict. Consider type family F1 a b where F1 Int Bool = Char F1 Double String = Char Consider now two matching problems: P1. match (F1 a Bool) (F1 Int Bool) P2. match (F1 a Bool) (F1 Double String) In case P1, we must find (a ↦ Int) to satisfy M2. In case P2, we must /not/ find (a ↦ Double), in order to satisfy I2. (Note that the correct mapping for I2 is (a ↦ Int). There is no way to discover this, but we musn't map a to anything else!) We thus must parameterize the algorithm over whether it's being used for an injectivity check (refrain from looking at non-injective arguments to type families) or not (do indeed look at those arguments). This is implemented by the uf_inj_tf field of UmEnv. (It's all a question of whether or not to include equation (7) from Fig. 2 of [ITF].) This extra parameter is a bit fiddly, perhaps, but seemingly less so than having two separate, almost-identical algorithms. Note [Self-substitution when matching] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What should happen when we're *matching* (not unifying) a1 with a1? We should get a substitution [a1 |-> a1]. A successful match should map all the template variables (except ones that disappear when expanding synonyms). But when unifying, we don't want to do this, because we'll then fall into a loop. This arrangement affects the code in three places: - If we're matching a refined template variable, don't recur. Instead, just check for equality. That is, if we know [a |-> Maybe a] and are matching (a ~? Maybe Int), we want to just fail. - Skip the occurs check when matching. This comes up in two places, because matching against variables is handled separately from matching against full-on types. Note that this arrangement was provoked by a real failure, where the same unique ended up in the template as in the target. (It was a rule firing when compiling Data.List.NonEmpty.) Note [Matching coercion variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this: type family F a data G a where MkG :: F a ~ Bool => G a type family Foo (x :: G a) :: F a type instance Foo MkG = False We would like that to be accepted. For that to work, we need to introduce a coercion variable on the left and then use it on the right. Accordingly, at use sites of Foo, we need to be able to use matching to figure out the value for the coercion. (See the desugared version: axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c) ) We never want this action to happen during *unification* though, when all bets are off. Note [Kind coercions in Unify] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We wish to match/unify while ignoring casts. But, we can't just ignore them completely, or we'll end up with ill-kinded substitutions. For example, say we're matching `a` with `ty |> co`. If we just drop the cast, we'll return [a |-> ty], but `a` and `ty` might have different kinds. We can't just match/unify their kinds, either, because this might gratuitously fail. After all, `co` is the witness that the kinds are the same -- they may look nothing alike. So, we pass a kind coercion to the match/unify worker. This coercion witnesses the equality between the substed kind of the left-hand type and the substed kind of the right-hand type. Note that we do not unify kinds at the leaves (as we did previously). We thus have INVARIANT: In the call unify_ty ty1 ty2 kco it must be that subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)), where `subst` is the ambient substitution in the UM monad. To get this coercion, we first have to match/unify the kinds before looking at the types. Happily, we need look only one level up, as all kinds are guaranteed to have kind *. When we're working with type applications (either TyConApp or AppTy) we need to worry about establishing INVARIANT, as the kinds of the function & arguments aren't (necessarily) included in the kind of the result. When unifying two TyConApps, this is easy, because the two TyCons are the same. Their kinds are thus the same. As long as we unify left-to-right, we'll be sure to unify types' kinds before the types themselves. (For example, think about Proxy :: forall k. k -> *. Unifying the first args matches up the kinds of the second args.) For AppTy, we must unify the kinds of the functions, but once these are unified, we can continue unifying arguments without worrying further about kinds. The interface to this module includes both "...Ty" functions and "...TyKi" functions. The former assume that INVARIANT is already established, either because the kinds are the same or because the list of types being passed in are the well-typed arguments to some type constructor (see two paragraphs above). The latter take a separate pre-pass over the kinds to establish INVARIANT. Sometimes, it's important not to take the second pass, as it caused #12442. We thought, at one point, that this was all unnecessary: why should casts be in types in the first place? But they are sometimes. In dependent/should_compile/KindEqualities2, we see, for example the constraint Num (Int |> (blah ; sym blah)). We naturally want to find a dictionary for that constraint, which requires dealing with coercions in this manner. Note [Matching in the presence of casts (1)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When matching, it is crucial that no variables from the template end up in the range of the matching substitution (obviously!). When unifying, that's not a constraint; instead we take the fixpoint of the substitution at the end. So what should we do with this, when matching? unify_ty (tmpl |> co) tgt kco Previously, wrongly, we pushed 'co' in the (horrid) accumulating 'kco' argument like this: unify_ty (tmpl |> co) tgt kco = unify_ty tmpl tgt (kco ; co) But that is obviously wrong because 'co' (from the template) ends up in 'kco', which in turn ends up in the range of the substitution. This all came up in #13910. Because we match tycon arguments left-to-right, the ambient substitution will already have a matching substitution for any kinds; so there is an easy fix: just apply the substitution-so-far to the coercion from the LHS. Note that * When matching, the first arg of unify_ty is always the template; we never swap round. * The above argument is distressingly indirect. We seek a better way. * One better way is to ensure that type patterns (the template in the matching process) have no casts. See #14119. Note [Matching in the presence of casts (2)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There is another wrinkle (#17395). Suppose (T :: forall k. k -> Type) and we are matching tcMatchTy (T k (a::k)) (T j (b::j)) Then we'll match k :-> j, as expected. But then in unify_tys we invoke unify_tys env (a::k) (b::j) (Refl j) Although we have unified k and j, it's very important that we put (Refl j), /not/ (Refl k) as the fourth argument to unify_tys. If we put (Refl k) we'd end up with teh substitution a :-> b |> Refl k which is bogus because one of the template variables, k, appears in the range of the substitution. Eek. Similar care is needed in unify_ty_app. Note [Polykinded tycon applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose T :: forall k. Type -> K and we are unifying ty1: T @Type Int :: Type ty2: T @(Type->Type) Int Int :: Type These two TyConApps have the same TyCon at the front but they (legitimately) have different numbers of arguments. They are surelyApart, so we can report that without looking any further (see #15704). -} -------------- unify_ty: the main workhorse ----------- type AmIUnifying = Bool -- True <=> Unifying -- False <=> Matching unify_ty :: UMEnv -> Type -> Type -- Types to be unified and a co -> CoercionN -- A coercion between their kinds -- See Note [Kind coercions in Unify] -> UM () -- See Note [Specification of unification] -- Respects newtypes, PredTypes unify_ty env ty1 ty2 kco -- TODO: More commentary needed here | Just ty1' <- tcView ty1 = unify_ty env ty1' ty2 kco | Just ty2' <- tcView ty2 = unify_ty env ty1 ty2' kco | CastTy ty1' co <- ty1 = if um_unif env then unify_ty env ty1' ty2 (co `mkTransCo` kco) else -- See Note [Matching in the presence of casts (1)] do { subst <- getSubst env ; let co' = substCo subst co ; unify_ty env ty1' ty2 (co' `mkTransCo` kco) } | CastTy ty2' co <- ty2 = unify_ty env ty1 ty2' (kco `mkTransCo` mkSymCo co) unify_ty env (TyVarTy tv1) ty2 kco = uVar env tv1 ty2 kco unify_ty env ty1 (TyVarTy tv2) kco | um_unif env -- If unifying, can swap args = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco) unify_ty env ty1 ty2 _kco | Just (tc1, tys1) <- mb_tc_app1 , Just (tc2, tys2) <- mb_tc_app2 , tc1 == tc2 || (tcIsLiftedTypeKind ty1 && tcIsLiftedTypeKind ty2) = if isInjectiveTyCon tc1 Nominal then unify_tys env tys1 tys2 else do { let inj | isTypeFamilyTyCon tc1 = case tyConInjectivityInfo tc1 of NotInjective -> repeat False Injective bs -> bs | otherwise = repeat False (inj_tys1, noninj_tys1) = partitionByList inj tys1 (inj_tys2, noninj_tys2) = partitionByList inj tys2 ; unify_tys env inj_tys1 inj_tys2 ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification] don'tBeSoSure $ unify_tys env noninj_tys1 noninj_tys2 } | Just (tc1, _) <- mb_tc_app1 , not (isGenerativeTyCon tc1 Nominal) -- E.g. unify_ty (F ty1) b = MaybeApart -- because the (F ty1) behaves like a variable -- NB: if unifying, we have already dealt -- with the 'ty2 = variable' case = maybeApart | Just (tc2, _) <- mb_tc_app2 , not (isGenerativeTyCon tc2 Nominal) , um_unif env -- E.g. unify_ty [a] (F ty2) = MaybeApart, when unifying (only) -- because the (F ty2) behaves like a variable -- NB: we have already dealt with the 'ty1 = variable' case = maybeApart where mb_tc_app1 = tcSplitTyConApp_maybe ty1 mb_tc_app2 = tcSplitTyConApp_maybe ty2 -- Applications need a bit of care! -- They can match FunTy and TyConApp, so use splitAppTy_maybe -- NB: we've already dealt with type variables, -- so if one type is an App the other one jolly well better be too unify_ty env (AppTy ty1a ty1b) ty2 _kco | Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 = unify_ty_app env ty1a [ty1b] ty2a [ty2b] unify_ty env ty1 (AppTy ty2a ty2b) _kco | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 = unify_ty_app env ty1a [ty1b] ty2a [ty2b] unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return () unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind) ; let env' = umRnBndr2 env tv1 tv2 ; unify_ty env' ty1 ty2 kco } -- See Note [Matching coercion variables] unify_ty env (CoercionTy co1) (CoercionTy co2) kco = do { c_subst <- getCvSubstEnv ; case co1 of CoVarCo cv | not (um_unif env) , not (cv `elemVarEnv` c_subst) , BindMe <- tvBindFlag env cv -> do { checkRnEnv env (tyCoVarsOfCo co2) ; let (co_l, co_r) = decomposeFunCo Nominal kco -- cv :: t1 ~ t2 -- co2 :: s1 ~ s2 -- co_l :: t1 ~ s1 -- co_r :: t2 ~ s2 ; extendCvEnv cv (co_l `mkTransCo` co2 `mkTransCo` mkSymCo co_r) } _ -> return () } unify_ty _ _ _ _ = surelyApart unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM () unify_ty_app env ty1 ty1args ty2 ty2args | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 , Just (ty2', ty2a) <- repSplitAppTy_maybe ty2 = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args) | otherwise = do { let ki1 = typeKind ty1 ki2 = typeKind ty2 -- See Note [Kind coercions in Unify] ; unify_ty env ki1 ki2 (mkNomReflCo liftedTypeKind) ; unify_ty env ty1 ty2 (mkNomReflCo ki2) -- Very important: 'ki2' not 'ki1' -- See Note [Matching in the presence of casts (2)] ; unify_tys env ty1args ty2args } unify_tys :: UMEnv -> [Type] -> [Type] -> UM () unify_tys env orig_xs orig_ys = go orig_xs orig_ys where go [] [] = return () go (x:xs) (y:ys) -- See Note [Kind coercions in Unify] = do { unify_ty env x y (mkNomReflCo $ typeKind y) -- Very important: 'y' not 'x' -- See Note [Matching in the presence of casts (2)] ; go xs ys } go _ _ = surelyApart -- Possibly different saturations of a polykinded tycon -- See Note [Polykinded tycon applications] --------------------------------- uVar :: UMEnv -> InTyVar -- Variable to be unified -> Type -- with this Type -> Coercion -- :: kind tv ~N kind ty -> UM () uVar env tv1 ty kco = do { -- Apply the ambient renaming let tv1' = umRnOccL env tv1 -- Check to see whether tv1 is refined by the substitution ; subst <- getTvSubstEnv ; case (lookupVarEnv subst tv1') of Just ty' | um_unif env -- Unifying, so call -> unify_ty env ty' ty kco -- back into unify | otherwise -> -- Matching, we don't want to just recur here. -- this is because the range of the subst is the target -- type, not the template type. So, just check for -- normal type equality. guard ((ty' `mkCastTy` kco) `eqType` ty) Nothing -> uUnrefined env tv1' ty ty kco } -- No, continue uUnrefined :: UMEnv -> OutTyVar -- variable to be unified -> Type -- with this Type -> Type -- (version w/ expanded synonyms) -> Coercion -- :: kind tv ~N kind ty -> UM () -- We know that tv1 isn't refined uUnrefined env tv1' ty2 ty2' kco | Just ty2'' <- coreView ty2' = uUnrefined env tv1' ty2 ty2'' kco -- Unwrap synonyms -- This is essential, in case we have -- type Foo a = a -- and then unify a ~ Foo a | TyVarTy tv2 <- ty2' = do { let tv2' = umRnOccR env tv2 ; unless (tv1' == tv2' && um_unif env) $ do -- If we are unifying a ~ a, just return immediately -- Do not extend the substitution -- See Note [Self-substitution when matching] -- Check to see whether tv2 is refined { subst <- getTvSubstEnv ; case lookupVarEnv subst tv2 of { Just ty' | um_unif env -> uUnrefined env tv1' ty' ty' kco ; _ -> do { -- So both are unrefined -- Bind one or the other, depending on which is bindable ; let b1 = tvBindFlag env tv1' b2 = tvBindFlag env tv2' ty1 = mkTyVarTy tv1' ; case (b1, b2) of (BindMe, _) -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco) (_, BindMe) | um_unif env -> bindTv (umSwapRn env) tv2 (ty1 `mkCastTy` kco) _ | tv1' == tv2' -> return () -- How could this happen? If we're only matching and if -- we're comparing forall-bound variables. _ -> maybeApart -- See Note [Unification with skolems] }}}} uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable = case tvBindFlag env tv1' of Skolem -> maybeApart -- See Note [Unification with skolems] BindMe -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco) bindTv :: UMEnv -> OutTyVar -> Type -> UM () -- OK, so we want to extend the substitution with tv := ty -- But first, we must do a couple of checks bindTv env tv1 ty2 = do { let free_tvs2 = tyCoVarsOfType ty2 -- Make sure tys mentions no local variables -- E.g. (forall a. b) ~ (forall a. [a]) -- We should not unify b := [a]! ; checkRnEnv env free_tvs2 -- Occurs check, see Note [Fine-grained unification] -- Make sure you include 'kco' (which ty2 does) #14846 ; occurs <- occursCheck env tv1 free_tvs2 ; if occurs then maybeApart else extendTvEnv tv1 ty2 } occursCheck :: UMEnv -> TyVar -> VarSet -> UM Bool occursCheck env tv free_tvs | um_unif env = do { tsubst <- getTvSubstEnv ; return (tv `elemVarSet` niSubstTvSet tsubst free_tvs) } | otherwise -- Matching; no occurs check = return False -- See Note [Self-substitution when matching] {- %************************************************************************ %* * Binding decisions * * ************************************************************************ -} data BindFlag = BindMe -- A regular type variable | Skolem -- This type variable is a skolem constant -- Don't bind it; it only matches itself deriving Eq {- ************************************************************************ * * Unification monad * * ************************************************************************ -} data UMEnv = UMEnv { um_unif :: AmIUnifying , um_inj_tf :: Bool -- Checking for injectivity? -- See (end of) Note [Specification of unification] , um_rn_env :: RnEnv2 -- Renaming InTyVars to OutTyVars; this eliminates -- shadowing, and lines up matching foralls on the left -- and right , um_skols :: TyVarSet -- OutTyVars bound by a forall in this unification; -- Do not bind these in the substitution! -- See the function tvBindFlag , um_bind_fun :: TyVar -> BindFlag -- User-supplied BindFlag function, -- for variables not in um_skols } data UMState = UMState { um_tv_env :: TvSubstEnv , um_cv_env :: CvSubstEnv } newtype UM a = UM { unUM :: UMState -> UnifyResultM (UMState, a) } deriving (Functor) instance Applicative UM where pure a = UM (\s -> pure (s, a)) (<*>) = ap instance Monad UM where #if !MIN_VERSION_base(4,13,0) fail = MonadFail.fail #endif m >>= k = UM (\state -> do { (state', v) <- unUM m state ; unUM (k v) state' }) -- need this instance because of a use of 'guard' above instance Alternative UM where empty = UM (\_ -> Control.Applicative.empty) m1 <|> m2 = UM (\state -> unUM m1 state <|> unUM m2 state) instance MonadPlus UM instance MonadFail.MonadFail UM where fail _ = UM (\_ -> SurelyApart) -- failed pattern match initUM :: TvSubstEnv -- subst to extend -> CvSubstEnv -> UM a -> UnifyResultM a initUM subst_env cv_subst_env um = case unUM um state of Unifiable (_, subst) -> Unifiable subst MaybeApart (_, subst) -> MaybeApart subst SurelyApart -> SurelyApart where state = UMState { um_tv_env = subst_env , um_cv_env = cv_subst_env } tvBindFlag :: UMEnv -> OutTyVar -> BindFlag tvBindFlag env tv | tv `elemVarSet` um_skols env = Skolem | otherwise = um_bind_fun env tv getTvSubstEnv :: UM TvSubstEnv getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state) getCvSubstEnv :: UM CvSubstEnv getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state) getSubst :: UMEnv -> UM TCvSubst getSubst env = do { tv_env <- getTvSubstEnv ; cv_env <- getCvSubstEnv ; let in_scope = rnInScopeSet (um_rn_env env) ; return (mkTCvSubst in_scope (tv_env, cv_env)) } extendTvEnv :: TyVar -> Type -> UM () extendTvEnv tv ty = UM $ \state -> Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ()) extendCvEnv :: CoVar -> Coercion -> UM () extendCvEnv cv co = UM $ \state -> Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ()) umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv umRnBndr2 env v1 v2 = env { um_rn_env = rn_env', um_skols = um_skols env `extendVarSet` v' } where (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2 checkRnEnv :: UMEnv -> VarSet -> UM () checkRnEnv env varset | isEmptyVarSet skol_vars = return () | varset `disjointVarSet` skol_vars = return () | otherwise = maybeApart -- ToDo: why MaybeApart? -- I think SurelyApart would be right where skol_vars = um_skols env -- NB: That isEmptyVarSet guard is a critical optimization; -- it means we don't have to calculate the free vars of -- the type, often saving quite a bit of allocation. -- | Converts any SurelyApart to a MaybeApart don'tBeSoSure :: UM () -> UM () don'tBeSoSure um = UM $ \ state -> case unUM um state of SurelyApart -> MaybeApart (state, ()) other -> other umRnOccL :: UMEnv -> TyVar -> TyVar umRnOccL env v = rnOccL (um_rn_env env) v umRnOccR :: UMEnv -> TyVar -> TyVar umRnOccR env v = rnOccR (um_rn_env env) v umSwapRn :: UMEnv -> UMEnv umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) } maybeApart :: UM () maybeApart = UM (\state -> MaybeApart (state, ())) surelyApart :: UM a surelyApart = UM (\_ -> SurelyApart) {- %************************************************************************ %* * Matching a (lifted) type against a coercion %* * %************************************************************************ This section defines essentially an inverse to liftCoSubst. It is defined here to avoid a dependency from Coercion on this module. -} data MatchEnv = ME { me_tmpls :: TyVarSet , me_env :: RnEnv2 } -- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if -- @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@, -- where @==@ there means that the result of 'liftCoSubst' has the same -- type as the original co; but may be different under the hood. -- That is, it matches a type against a coercion of the same -- "shape", and returns a lifting substitution which could have been -- used to produce the given coercion from the given type. -- Note that this function is incomplete -- it might return Nothing -- when there does indeed exist a possible lifting context. -- -- This function is incomplete in that it doesn't respect the equality -- in `eqType`. That is, it's possible that this will succeed for t1 and -- fail for t2, even when t1 `eqType` t2. That's because it depends on -- there being a very similar structure between the type and the coercion. -- This incompleteness shouldn't be all that surprising, especially because -- it depends on the structure of the coercion, which is a silly thing to do. -- -- The lifting context produced doesn't have to be exacting in the roles -- of the mappings. This is because any use of the lifting context will -- also require a desired role. Thus, this algorithm prefers mapping to -- nominal coercions where it can do so. liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext liftCoMatch tmpls ty co = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co ; cenv2 <- ty_co_match menv cenv1 ty co (mkNomReflCo co_lkind) (mkNomReflCo co_rkind) ; return (LC (mkEmptyTCvSubst in_scope) cenv2) } where menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) -- Like tcMatchTy, assume all the interesting variables -- in ty are in tmpls ki = typeKind ty ki_co = promoteCoercion co ki_ki_co = mkNomReflCo liftedTypeKind Pair co_lkind co_rkind = coercionKind ki_co -- | 'ty_co_match' does all the actual work for 'liftCoMatch'. ty_co_match :: MatchEnv -- ^ ambient helpful info -> LiftCoEnv -- ^ incoming subst -> Type -- ^ ty, type to match -> Coercion -- ^ co, coercion to match against -> Coercion -- ^ :: kind of L type of substed ty ~N L kind of co -> Coercion -- ^ :: kind of R type of substed ty ~N R kind of co -> Maybe LiftCoEnv ty_co_match menv subst ty co lkco rkco | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco -- handle Refl case: | tyCoVarsOfType ty `isNotInDomainOf` subst , Just (ty', _) <- isReflCo_maybe co , ty `eqType` ty' = Just subst where isNotInDomainOf :: VarSet -> VarEnv a -> Bool isNotInDomainOf set env = noneSet (\v -> elemVarEnv v env) set noneSet :: (Var -> Bool) -> VarSet -> Bool noneSet f = allVarSet (not . f) ty_co_match menv subst ty co lkco rkco | CastTy ty' co' <- ty -- See Note [Matching in the presence of casts (1)] = let empty_subst = mkEmptyTCvSubst (rnInScopeSet (me_env menv)) substed_co_l = substCo (liftEnvSubstLeft empty_subst subst) co' substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co' in ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco) (substed_co_r `mkTransCo` rkco) | SymCo co' <- co = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco -- Match a type variable against a non-refl coercion ty_co_match menv subst (TyVarTy tv1) co lkco rkco | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1 = if eqCoercionX (nukeRnEnvL rn_env) co1' co then Just subst else Nothing -- no match since tv1 matches two different coercions | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co) then Nothing -- occurs check failed else Just $ extendVarEnv subst tv1' $ castCoercionKindI co (mkSymCo lkco) (mkSymCo rkco) | otherwise = Nothing where rn_env = me_env menv tv1' = rnOccL rn_env tv1 -- just look through SubCo's. We don't really care about roles here. ty_co_match menv subst ty (SubCo co) lkco rkco = ty_co_match menv subst ty co lkco rkco ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco | Just (co2, arg2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 -- yes, the one from Type, not TcType; this is for coercion optimization = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco = ty_co_match_tc menv subst tc1 tys tc2 cos ty_co_match menv subst (FunTy _ ty1 ty2) co _lkco _rkco -- Despite the fact that (->) is polymorphic in four type variables (two -- runtime rep and two types), we shouldn't need to explicitly unify the -- runtime reps here; unifying the types themselves should be sufficient. -- See Note [Representation of function types]. | Just (tc, [_,_,co1,co2]) <- splitTyConAppCo_maybe co , tc == funTyCon = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co1,co2] in ty_co_match_args menv subst [ty1, ty2] [co1, co2] lkcos rkcos ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1) (ForAllCo tv2 kind_co2 co2) lkco rkco | isTyVar tv1 && isTyVar tv2 = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2 ki_ki_co ki_ki_co ; let rn_env0 = me_env menv rn_env1 = rnBndr2 rn_env0 tv1 tv2 menv' = menv { me_env = rn_env1 } ; ty_co_match menv' subst1 ty1 co2 lkco rkco } where ki_ki_co = mkNomReflCo liftedTypeKind -- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1) -- (ForAllCo cv2 kind_co2 co2) -- lkco rkco -- | isCoVar cv1 && isCoVar cv2 -- We seems not to have enough information for this case -- 1. Given: -- cv1 :: (s1 :: k1) ~r (s2 :: k2) -- kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2) -- eta1 = mkNthCo role 2 (downgradeRole r Nominal kind_co2) -- :: s1' ~ t1 -- eta2 = mkNthCo role 3 (downgradeRole r Nominal kind_co2) -- :: s2' ~ t2 -- Wanted: -- subst1 <- ty_co_match menv subst s1 eta1 kco1 kco2 -- subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4 -- Question: How do we get kcoi? -- 2. Given: -- lkco :: <*> -- See Note [Weird typing rule for ForAllTy] in Type -- rkco :: <*> -- Wanted: -- ty_co_match menv' subst2 ty1 co2 lkco' rkco' -- Question: How do we get lkco' and rkco'? ty_co_match _ subst (CoercionTy {}) _ _ _ = Just subst -- don't inspect coercions ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco = ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co) ty_co_match menv subst ty co1 lkco rkco | Just (CastTy t co, r) <- isReflCo_maybe co1 -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us -- t |> co ~ t ; ; t ~ t |> co -- But transitive coercions are not helpful. Therefore we deal -- with it here: we do recursion on the smaller reflexive coercion, -- while propagating the correct kind coercions. = let kco' = mkSymCo co in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco') (rkco `mkTransCo` kco') ty_co_match menv subst ty co lkco rkco | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco | otherwise = Nothing ty_co_match_tc :: MatchEnv -> LiftCoEnv -> TyCon -> [Type] -> TyCon -> [Coercion] -> Maybe LiftCoEnv ty_co_match_tc menv subst tc1 tys1 tc2 cos2 = do { guard (tc1 == tc2) ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos } where Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) cos2 ty_co_match_app :: MatchEnv -> LiftCoEnv -> Type -> [Type] -> Coercion -> [Coercion] -> Maybe LiftCoEnv ty_co_match_app menv subst ty1 ty1args co2 co2args | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 , Just (co2', co2a) <- splitAppCo_maybe co2 = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args) | otherwise = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2 ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco ; let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) co2args ; ty_co_match_args menv subst2 ty1args co2args lkcos rkcos } where ki1 = typeKind ty1 ki2 = promoteCoercion co2 ki_ki_co = mkNomReflCo liftedTypeKind ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion] -> [Coercion] -> [Coercion] -> Maybe LiftCoEnv ty_co_match_args _ subst [] [] _ _ = Just subst ty_co_match_args menv subst (ty:tys) (arg:args) (lkco:lkcos) (rkco:rkcos) = do { subst' <- ty_co_match menv subst ty arg lkco rkco ; ty_co_match_args menv subst' tys args lkcos rkcos } ty_co_match_args _ _ _ _ _ _ = Nothing pushRefl :: Coercion -> Maybe Coercion pushRefl co = case (isReflCo_maybe co) of Just (AppTy ty1 ty2, Nominal) -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2)) Just (FunTy _ ty1 ty2, r) | Just rep1 <- getRuntimeRep_maybe ty1 , Just rep2 <- getRuntimeRep_maybe ty2 -> Just (TyConAppCo r funTyCon [ mkReflCo r rep1, mkReflCo r rep2 , mkReflCo r ty1, mkReflCo r ty2 ]) Just (TyConApp tc tys, r) -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) Just (ForAllTy (Bndr tv _) ty, r) -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty)) -- NB: NoRefl variant. Otherwise, we get a loop! _ -> Nothing ghc-lib-parser-8.10.2.20200808/compiler/utils/UniqDFM.hs0000644000000000000000000003703013713635745020263 0ustar0000000000000000{- (c) Bartosz Nitka, Facebook, 2015 UniqDFM: Specialised deterministic finite maps, for things with @Uniques@. Basically, the things need to be in class @Uniquable@, and we use the @getUnique@ method to grab their @Uniques@. This is very similar to @UniqFM@, the major difference being that the order of folding is not dependent on @Unique@ ordering, giving determinism. Currently the ordering is determined by insertion order. See Note [Unique Determinism] in Unique for explanation why @Unique@ ordering is not deterministic. -} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wall #-} module UniqDFM ( -- * Unique-keyed deterministic mappings UniqDFM, -- abstract type -- ** Manipulating those mappings emptyUDFM, unitUDFM, addToUDFM, addToUDFM_C, addListToUDFM, delFromUDFM, delListFromUDFM, adjustUDFM, alterUDFM, mapUDFM, plusUDFM, plusUDFM_C, lookupUDFM, lookupUDFM_Directly, elemUDFM, foldUDFM, eltsUDFM, filterUDFM, filterUDFM_Directly, isNullUDFM, sizeUDFM, intersectUDFM, udfmIntersectUFM, intersectsUDFM, disjointUDFM, disjointUdfmUfm, equalKeysUDFM, minusUDFM, listToUDFM, udfmMinusUFM, partitionUDFM, anyUDFM, allUDFM, pprUniqDFM, pprUDFM, udfmToList, udfmToUfm, nonDetFoldUDFM, alwaysUnsafeUfmToUdfm, ) where import GhcPrelude import Unique ( Uniquable(..), Unique, getKey ) import Outputable import qualified Data.IntMap as M import Data.Data import Data.Functor.Classes (Eq1 (..)) import Data.List (sortBy) import Data.Function (on) import qualified Data.Semigroup as Semi import UniqFM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap) -- Note [Deterministic UniqFM] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- A @UniqDFM@ is just like @UniqFM@ with the following additional -- property: the function `udfmToList` returns the elements in some -- deterministic order not depending on the Unique key for those elements. -- -- If the client of the map performs operations on the map in deterministic -- order then `udfmToList` returns them in deterministic order. -- -- There is an implementation cost: each element is given a serial number -- as it is added, and `udfmToList` sorts it's result by this serial -- number. So you should only use `UniqDFM` if you need the deterministic -- property. -- -- `foldUDFM` also preserves determinism. -- -- Normal @UniqFM@ when you turn it into a list will use -- Data.IntMap.toList function that returns the elements in the order of -- the keys. The keys in @UniqFM@ are always @Uniques@, so you end up with -- with a list ordered by @Uniques@. -- The order of @Uniques@ is known to be not stable across rebuilds. -- See Note [Unique Determinism] in Unique. -- -- -- There's more than one way to implement this. The implementation here tags -- every value with the insertion time that can later be used to sort the -- values when asked to convert to a list. -- -- An alternative would be to have -- -- data UniqDFM ele = UDFM (M.IntMap ele) [ele] -- -- where the list determines the order. This makes deletion tricky as we'd -- only accumulate elements in that list, but makes merging easier as you -- can just merge both structures independently. -- Deletion can probably be done in amortized fashion when the size of the -- list is twice the size of the set. -- | A type of values tagged with insertion time data TaggedVal val = TaggedVal val {-# UNPACK #-} !Int -- ^ insertion time deriving (Data, Functor) taggedFst :: TaggedVal val -> val taggedFst (TaggedVal v _) = v taggedSnd :: TaggedVal val -> Int taggedSnd (TaggedVal _ i) = i instance Eq val => Eq (TaggedVal val) where (TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2 -- | Type of unique deterministic finite maps data UniqDFM ele = UDFM !(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and -- values are tagged with insertion time. -- The invariant is that all the tags will -- be distinct within a single map {-# UNPACK #-} !Int -- Upper bound on the values' insertion -- time. See Note [Overflow on plusUDFM] deriving (Data, Functor) -- | Deterministic, in O(n log n). instance Foldable UniqDFM where foldr = foldUDFM -- | Deterministic, in O(n log n). instance Traversable UniqDFM where traverse f = fmap listToUDFM_Directly . traverse (\(u,a) -> (u,) <$> f a) . udfmToList emptyUDFM :: UniqDFM elt emptyUDFM = UDFM M.empty 0 unitUDFM :: Uniquable key => key -> elt -> UniqDFM elt unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1 -- The new binding always goes to the right of existing ones addToUDFM :: Uniquable key => UniqDFM elt -> key -> elt -> UniqDFM elt addToUDFM m k v = addToUDFM_Directly m (getUnique k) v -- The new binding always goes to the right of existing ones addToUDFM_Directly :: UniqDFM elt -> Unique -> elt -> UniqDFM elt addToUDFM_Directly (UDFM m i) u v = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) where tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i -- Keep the old tag, but insert the new value -- This means that udfmToList typically returns elements -- in the order of insertion, rather than the reverse addToUDFM_Directly_C :: (elt -> elt -> elt) -- old -> new -> result -> UniqDFM elt -> Unique -> elt -> UniqDFM elt addToUDFM_Directly_C f (UDFM m i) u v = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) where tf (TaggedVal new_v _) (TaggedVal old_v old_i) = TaggedVal (f old_v new_v) old_i -- Flip the arguments, because M.insertWith uses (new->old->result) -- but f needs (old->new->result) -- Like addToUDFM_Directly, keep the old tag addToUDFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result -> UniqDFM elt -- old -> key -> elt -- new -> UniqDFM elt -- result addToUDFM_C f m k v = addToUDFM_Directly_C f m (getUnique k) v addListToUDFM :: Uniquable key => UniqDFM elt -> [(key,elt)] -> UniqDFM elt addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) addListToUDFM_Directly :: UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v) addListToUDFM_Directly_C :: (elt -> elt -> elt) -> UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_Directly_C f m k v) delFromUDFM :: Uniquable key => UniqDFM elt -> key -> UniqDFM elt delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j) -- we will use the upper bound on the tag as a proxy for the set size, -- to insert the smaller one into the bigger one | i > j = insertUDFMIntoLeft_C f udfml udfmr | otherwise = insertUDFMIntoLeft_C f udfmr udfml -- Note [Overflow on plusUDFM] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- There are multiple ways of implementing plusUDFM. -- The main problem that needs to be solved is overlap on times of -- insertion between different keys in two maps. -- Consider: -- -- A = fromList [(a, (x, 1))] -- B = fromList [(b, (y, 1))] -- -- If you merge them naively you end up with: -- -- C = fromList [(a, (x, 1)), (b, (y, 1))] -- -- Which loses information about ordering and brings us back into -- non-deterministic world. -- -- The solution I considered before would increment the tags on one of the -- sets by the upper bound of the other set. The problem with this approach -- is that you'll run out of tags for some merge patterns. -- Say you start with A with upper bound 1, you merge A with A to get A' and -- the upper bound becomes 2. You merge A' with A' and the upper bound -- doubles again. After 64 merges you overflow. -- This solution would have the same time complexity as plusUFM, namely O(n+m). -- -- The solution I ended up with has time complexity of -- O(m log m + m * min (n+m, W)) where m is the smaller set. -- It simply inserts the elements of the smaller set into the larger -- set in the order that they were inserted into the smaller set. That's -- O(m log m) for extracting the elements from the smaller set in the -- insertion order and O(m * min(n+m, W)) to insert them into the bigger -- set. plusUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j) -- we will use the upper bound on the tag as a proxy for the set size, -- to insert the smaller one into the bigger one | i > j = insertUDFMIntoLeft udfml udfmr | otherwise = insertUDFMIntoLeft udfmr udfml insertUDFMIntoLeft :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr insertUDFMIntoLeft_C :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt insertUDFMIntoLeft_C f udfml udfmr = addListToUDFM_Directly_C f udfml $ udfmToList udfmr lookupUDFM :: Uniquable key => UniqDFM elt -> key -> Maybe elt lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m lookupUDFM_Directly :: UniqDFM elt -> Unique -> Maybe elt lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m elemUDFM :: Uniquable key => key -> UniqDFM elt -> Bool elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m -- | Performs a deterministic fold over the UniqDFM. -- It's O(n log n) while the corresponding function on `UniqFM` is O(n). foldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a foldUDFM k z m = foldr k z (eltsUDFM m) -- | Performs a nondeterministic fold over the UniqDFM. -- It's O(n), same as the corresponding function on `UniqFM`. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. nonDetFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a nonDetFoldUDFM k z (UDFM m _i) = foldr k z $ map taggedFst $ M.elems m eltsUDFM :: UniqDFM elt -> [elt] eltsUDFM (UDFM m _i) = map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m filterUDFM :: (elt -> Bool) -> UniqDFM elt -> UniqDFM elt filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM elt -> UniqDFM elt filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i where p' k (TaggedVal v _) = p (getUnique k) v -- | Converts `UniqDFM` to a list, with elements in deterministic order. -- It's O(n log n) while the corresponding function on `UniqFM` is O(n). udfmToList :: UniqDFM elt -> [(Unique, elt)] udfmToList (UDFM m _i) = [ (getUnique k, taggedFst v) | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ] -- Determines whether two 'UniqDFM's contain the same keys. equalKeysUDFM :: UniqDFM a -> UniqDFM b -> Bool equalKeysUDFM (UDFM m1 _) (UDFM m2 _) = liftEq (\_ _ -> True) m1 m2 isNullUDFM :: UniqDFM elt -> Bool isNullUDFM (UDFM m _) = M.null m sizeUDFM :: UniqDFM elt -> Int sizeUDFM (UDFM m _i) = M.size m intersectUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i -- M.intersection is left biased, that means the result will only have -- a subset of elements from the left set, so `i` is a good upper bound. udfmIntersectUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i -- M.intersection is left biased, that means the result will only have -- a subset of elements from the left set, so `i` is a good upper bound. intersectsUDFM :: UniqDFM elt -> UniqDFM elt -> Bool intersectsUDFM x y = isNullUDFM (x `intersectUDFM` y) disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool disjointUDFM (UDFM x _i) (UDFM y _j) = M.null (M.intersection x y) disjointUdfmUfm :: UniqDFM elt -> UniqFM elt2 -> Bool disjointUdfmUfm (UDFM x _i) y = M.null (M.intersection x (ufmToIntMap y)) minusUDFM :: UniqDFM elt1 -> UniqDFM elt2 -> UniqDFM elt1 minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i -- M.difference returns a subset of a left set, so `i` is a good upper -- bound. udfmMinusUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i -- M.difference returns a subset of a left set, so `i` is a good upper -- bound. -- | Partition UniqDFM into two UniqDFMs according to the predicate partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt) partitionUDFM p (UDFM m i) = case M.partition (p . taggedFst) m of (left, right) -> (UDFM left i, UDFM right i) -- | Delete a list of elements from a UniqDFM delListFromUDFM :: Uniquable key => UniqDFM elt -> [key] -> UniqDFM elt delListFromUDFM = foldl' delFromUDFM -- | This allows for lossy conversion from UniqDFM to UniqFM udfmToUfm :: UniqDFM elt -> UniqFM elt udfmToUfm (UDFM m _i) = listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m] listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM elt listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM -- | Apply a function to a particular element adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i -- | The expression (alterUDFM f k map) alters value x at k, or absence -- thereof. alterUDFM can be used to insert, delete, or update a value in -- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are -- more efficient. alterUDFM :: Uniquable key => (Maybe elt -> Maybe elt) -- How to adjust -> UniqDFM elt -- old -> key -- new -> UniqDFM elt -- result alterUDFM f (UDFM m i) k = UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1) where alterf Nothing = inject $ f Nothing alterf (Just (TaggedVal v _)) = inject $ f (Just v) inject Nothing = Nothing inject (Just v) = Just $ TaggedVal v i -- | Map a function over every value in a UniqDFM mapUDFM :: (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2 mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i anyUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m instance Semi.Semigroup (UniqDFM a) where (<>) = plusUDFM instance Monoid (UniqDFM a) where mempty = emptyUDFM mappend = (Semi.<>) -- This should not be used in commited code, provided for convenience to -- make ad-hoc conversions when developing alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList -- Output-ery instance Outputable a => Outputable (UniqDFM a) where ppr ufm = pprUniqDFM ppr ufm pprUniqDFM :: (a -> SDoc) -> UniqDFM a -> SDoc pprUniqDFM ppr_elt ufm = brackets $ fsep $ punctuate comma $ [ ppr uq <+> text ":->" <+> ppr_elt elt | (uq, elt) <- udfmToList ufm ] pprUDFM :: UniqDFM a -- ^ The things to be pretty printed -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements -> SDoc -- ^ 'SDoc' where the things have been pretty -- printed pprUDFM ufm pp = pp (eltsUDFM ufm) ghc-lib-parser-8.10.2.20200808/compiler/utils/UniqDSet.hs0000644000000000000000000001072313713635745020514 0ustar0000000000000000-- (c) Bartosz Nitka, Facebook, 2015 -- | -- Specialised deterministic sets, for things with @Uniques@ -- -- Based on 'UniqDFM's (as you would expect). -- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need it. -- -- Basically, the things need to be in class 'Uniquable'. {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} module UniqDSet ( -- * Unique set type UniqDSet, -- type synonym for UniqFM a getUniqDSet, pprUniqDSet, -- ** Manipulating these sets delOneFromUniqDSet, delListFromUniqDSet, emptyUniqDSet, unitUniqDSet, mkUniqDSet, addOneToUniqDSet, addListToUniqDSet, unionUniqDSets, unionManyUniqDSets, minusUniqDSet, uniqDSetMinusUniqSet, intersectUniqDSets, uniqDSetIntersectUniqSet, foldUniqDSet, elementOfUniqDSet, filterUniqDSet, sizeUniqDSet, isEmptyUniqDSet, lookupUniqDSet, uniqDSetToList, partitionUniqDSet, mapUniqDSet ) where import GhcPrelude import Outputable import UniqDFM import UniqSet import Unique import Data.Coerce import Data.Data import qualified Data.Semigroup as Semi -- See Note [UniqSet invariant] in UniqSet.hs for why we want a newtype here. -- Beyond preserving invariants, we may also want to 'override' typeclass -- instances. newtype UniqDSet a = UniqDSet {getUniqDSet' :: UniqDFM a} deriving (Data, Semi.Semigroup, Monoid) emptyUniqDSet :: UniqDSet a emptyUniqDSet = UniqDSet emptyUDFM unitUniqDSet :: Uniquable a => a -> UniqDSet a unitUniqDSet x = UniqDSet (unitUDFM x x) mkUniqDSet :: Uniquable a => [a] -> UniqDSet a mkUniqDSet = foldl' addOneToUniqDSet emptyUniqDSet -- The new element always goes to the right of existing ones. addOneToUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a addOneToUniqDSet (UniqDSet set) x = UniqDSet (addToUDFM set x x) addListToUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a addListToUniqDSet = foldl' addOneToUniqDSet delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a delOneFromUniqDSet (UniqDSet s) = UniqDSet . delFromUDFM s delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a delListFromUniqDSet (UniqDSet s) = UniqDSet . delListFromUDFM s unionUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a unionUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (plusUDFM s t) unionManyUniqDSets :: [UniqDSet a] -> UniqDSet a unionManyUniqDSets [] = emptyUniqDSet unionManyUniqDSets sets = foldr1 unionUniqDSets sets minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a minusUniqDSet (UniqDSet s) (UniqDSet t) = UniqDSet (minusUDFM s t) uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a uniqDSetMinusUniqSet xs ys = UniqDSet (udfmMinusUFM (getUniqDSet xs) (getUniqSet ys)) intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a intersectUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (intersectUDFM s t) uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a uniqDSetIntersectUniqSet xs ys = UniqDSet (udfmIntersectUFM (getUniqDSet xs) (getUniqSet ys)) foldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b foldUniqDSet c n (UniqDSet s) = foldUDFM c n s elementOfUniqDSet :: Uniquable a => a -> UniqDSet a -> Bool elementOfUniqDSet k = elemUDFM k . getUniqDSet filterUniqDSet :: (a -> Bool) -> UniqDSet a -> UniqDSet a filterUniqDSet p (UniqDSet s) = UniqDSet (filterUDFM p s) sizeUniqDSet :: UniqDSet a -> Int sizeUniqDSet = sizeUDFM . getUniqDSet isEmptyUniqDSet :: UniqDSet a -> Bool isEmptyUniqDSet = isNullUDFM . getUniqDSet lookupUniqDSet :: Uniquable a => UniqDSet a -> a -> Maybe a lookupUniqDSet = lookupUDFM . getUniqDSet uniqDSetToList :: UniqDSet a -> [a] uniqDSetToList = eltsUDFM . getUniqDSet partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet -- See Note [UniqSet invariant] in UniqSet.hs mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList -- Two 'UniqDSet's are considered equal if they contain the same -- uniques. instance Eq (UniqDSet a) where UniqDSet a == UniqDSet b = equalKeysUDFM a b getUniqDSet :: UniqDSet a -> UniqDFM a getUniqDSet = getUniqDSet' instance Outputable a => Outputable (UniqDSet a) where ppr = pprUniqDSet ppr pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList ghc-lib-parser-8.10.2.20200808/compiler/utils/UniqFM.hs0000644000000000000000000003420313713635745020156 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1994-1998 UniqFM: Specialised finite maps, for things with @Uniques@. Basically, the things need to be in class @Uniquable@, and we use the @getUnique@ method to grab their @Uniques@. (A similar thing to @UniqSet@, as opposed to @Set@.) The interface is based on @FiniteMap@s, but the implementation uses @Data.IntMap@, which is both maintained and faster than the past implementation (see commit log). The @UniqFM@ interface maps directly to Data.IntMap, only ``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order of arguments of combining function. -} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wall #-} module UniqFM ( -- * Unique-keyed mappings UniqFM, -- abstract type NonDetUniqFM(..), -- wrapper for opting into nondeterminism -- ** Manipulating those mappings emptyUFM, unitUFM, unitDirectlyUFM, listToUFM, listToUFM_Directly, listToUFM_C, addToUFM,addToUFM_C,addToUFM_Acc, addListToUFM,addListToUFM_C, addToUFM_Directly, addListToUFM_Directly, adjustUFM, alterUFM, adjustUFM_Directly, delFromUFM, delFromUFM_Directly, delListFromUFM, delListFromUFM_Directly, plusUFM, plusUFM_C, plusUFM_CD, plusMaybeUFM_C, plusUFMList, minusUFM, intersectUFM, intersectUFM_C, disjointUFM, equalKeysUFM, nonDetFoldUFM, foldUFM, nonDetFoldUFM_Directly, anyUFM, allUFM, seqEltsUFM, mapUFM, mapUFM_Directly, elemUFM, elemUFM_Directly, filterUFM, filterUFM_Directly, partitionUFM, sizeUFM, isNullUFM, lookupUFM, lookupUFM_Directly, lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, nonDetEltsUFM, eltsUFM, nonDetKeysUFM, ufmToSet_Directly, nonDetUFMToList, ufmToIntMap, pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM ) where import GhcPrelude import Unique ( Uniquable(..), Unique, getKey ) import Outputable import qualified Data.IntMap as M import qualified Data.IntSet as S import Data.Data import qualified Data.Semigroup as Semi import Data.Functor.Classes (Eq1 (..)) newtype UniqFM ele = UFM (M.IntMap ele) deriving (Data, Eq, Functor) -- Nondeterministic Foldable and Traversable instances are accessible through -- use of the 'NonDetUniqFM' wrapper. -- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. emptyUFM :: UniqFM elt emptyUFM = UFM M.empty isNullUFM :: UniqFM elt -> Bool isNullUFM (UFM m) = M.null m unitUFM :: Uniquable key => key -> elt -> UniqFM elt unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v) -- when you've got the Unique already unitDirectlyUFM :: Unique -> elt -> UniqFM elt unitDirectlyUFM u v = UFM (M.singleton (getKey u) v) listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM listToUFM_Directly :: [(Unique, elt)] -> UniqFM elt listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM listToUFM_C :: Uniquable key => (elt -> elt -> elt) -> [(key, elt)] -> UniqFM elt listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m) addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt addListToUFM = foldl' (\m (k, v) -> addToUFM m k v) addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt addListToUFM_Directly = foldl' (\m (k, v) -> addToUFM_Directly m k v) addToUFM_Directly :: UniqFM elt -> Unique -> elt -> UniqFM elt addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m) addToUFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result -> UniqFM elt -- old -> key -> elt -- new -> UniqFM elt -- result -- Arguments of combining function of M.insertWith and addToUFM_C are flipped. addToUFM_C f (UFM m) k v = UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) addToUFM_Acc :: Uniquable key => (elt -> elts -> elts) -- Add to existing -> (elt -> elts) -- New element -> UniqFM elts -- old -> key -> elt -- new -> UniqFM elts -- result addToUFM_Acc exi new (UFM m) k v = UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) alterUFM :: Uniquable key => (Maybe elt -> Maybe elt) -- How to adjust -> UniqFM elt -- old -> key -- new -> UniqFM elt -- result alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m) addListToUFM_C :: Uniquable key => (elt -> elt -> elt) -> UniqFM elt -> [(key,elt)] -> UniqFM elt addListToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m) adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m) delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt delListFromUFM = foldl' delFromUFM delListFromUFM_Directly :: UniqFM elt -> [Unique] -> UniqFM elt delListFromUFM_Directly = foldl' delFromUFM_Directly delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) -- Bindings in right argument shadow those in the left plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt -- M.union is left-biased, plusUFM should be right-biased. plusUFM (UFM x) (UFM y) = UFM (M.union y x) -- Note (M.union y x), with arguments flipped -- M.union is left-biased, plusUFM should be right-biased. plusUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) -- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the -- combinding function and `d1` resp. `d2` as the default value if -- there is no entry in `m1` reps. `m2`. The domain is the union of -- the domains of `m1` and `m2`. -- -- Representative example: -- -- @ -- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42 -- == {A: f 1 42, B: f 2 3, C: f 23 4 } -- @ plusUFM_CD :: (elt -> elt -> elt) -> UniqFM elt -- map X -> elt -- default for X -> UniqFM elt -- map Y -> elt -- default for Y -> UniqFM elt plusUFM_CD f (UFM xm) dx (UFM ym) dy = UFM $ M.mergeWithKey (\_ x y -> Just (x `f` y)) (M.map (\x -> x `f` dy)) (M.map (\y -> dx `f` y)) xm ym plusMaybeUFM_C :: (elt -> elt -> Maybe elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt plusMaybeUFM_C f (UFM xm) (UFM ym) = UFM $ M.mergeWithKey (\_ x y -> x `f` y) id id xm ym plusUFMList :: [UniqFM elt] -> UniqFM elt plusUFMList = foldl' plusUFM emptyUFM minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 minusUFM (UFM x) (UFM y) = UFM (M.difference x y) intersectUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) intersectUFM_C :: (elt1 -> elt2 -> elt3) -> UniqFM elt1 -> UniqFM elt2 -> UniqFM elt3 intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y) foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a foldUFM k z (UFM m) = M.foldr k z m mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 mapUFM f (UFM m) = UFM (M.map f m) mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt filterUFM p (UFM m) = UFM (M.filter p m) filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m) partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt) partitionUFM p (UFM m) = case M.partition p m of (left, right) -> (UFM left, UFM right) sizeUFM :: UniqFM elt -> Int sizeUFM (UFM m) = M.size m elemUFM :: Uniquable key => key -> UniqFM elt -> Bool elemUFM k (UFM m) = M.member (getKey $ getUnique k) m elemUFM_Directly :: Unique -> UniqFM elt -> Bool elemUFM_Directly u (UFM m) = M.member (getKey u) m lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m -- when you've got the Unique already lookupUFM_Directly :: UniqFM elt -> Unique -> Maybe elt lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m lookupWithDefaultUFM :: Uniquable key => UniqFM elt -> elt -> key -> elt lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m lookupWithDefaultUFM_Directly :: UniqFM elt -> elt -> Unique -> elt lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m eltsUFM :: UniqFM elt -> [elt] eltsUFM (UFM m) = M.elems m ufmToSet_Directly :: UniqFM elt -> S.IntSet ufmToSet_Directly (UFM m) = M.keysSet m anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool anyUFM p (UFM m) = M.foldr ((||) . p) False m allUFM :: (elt -> Bool) -> UniqFM elt -> Bool allUFM p (UFM m) = M.foldr ((&&) . p) True m seqEltsUFM :: ([elt] -> ()) -> UniqFM elt -> () seqEltsUFM seqList = seqList . nonDetEltsUFM -- It's OK to use nonDetEltsUFM here because the type guarantees that -- the only interesting thing this function can do is to force the -- elements. -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. nonDetEltsUFM :: UniqFM elt -> [elt] nonDetEltsUFM (UFM m) = M.elems m -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. nonDetKeysUFM :: UniqFM elt -> [Unique] nonDetKeysUFM (UFM m) = map getUnique $ M.keys m -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a nonDetFoldUFM k z (UFM m) = M.foldr k z m -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. nonDetFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a nonDetFoldUFM_Directly k z (UFM m) = M.foldrWithKey (k . getUnique) z m -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. nonDetUFMToList :: UniqFM elt -> [(Unique, elt)] nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m -- | A wrapper around 'UniqFM' with the sole purpose of informing call sites -- that the provided 'Foldable' and 'Traversable' instances are -- nondeterministic. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. -- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. newtype NonDetUniqFM ele = NonDetUniqFM { getNonDet :: UniqFM ele } deriving (Functor) -- | Inherently nondeterministic. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. -- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. instance Foldable NonDetUniqFM where foldr f z (NonDetUniqFM (UFM m)) = foldr f z m -- | Inherently nondeterministic. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. -- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. instance Traversable NonDetUniqFM where traverse f (NonDetUniqFM (UFM m)) = NonDetUniqFM . UFM <$> traverse f m ufmToIntMap :: UniqFM elt -> M.IntMap elt ufmToIntMap (UFM m) = m -- Determines whether two 'UniqFM's contain the same keys. equalKeysUFM :: UniqFM a -> UniqFM b -> Bool equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 -- Instances instance Semi.Semigroup (UniqFM a) where (<>) = plusUFM instance Monoid (UniqFM a) where mempty = emptyUFM mappend = (Semi.<>) -- Output-ery instance Outputable a => Outputable (UniqFM a) where ppr ufm = pprUniqFM ppr ufm pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc pprUniqFM ppr_elt ufm = brackets $ fsep $ punctuate comma $ [ ppr uq <+> text ":->" <+> ppr_elt elt | (uq, elt) <- nonDetUFMToList ufm ] -- It's OK to use nonDetUFMToList here because we only use it for -- pretty-printing. -- | Pretty-print a non-deterministic set. -- The order of variables is non-deterministic and for pretty-printing that -- shouldn't be a problem. -- Having this function helps contain the non-determinism created with -- nonDetEltsUFM. pprUFM :: UniqFM a -- ^ The things to be pretty printed -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements -> SDoc -- ^ 'SDoc' where the things have been pretty -- printed pprUFM ufm pp = pp (nonDetEltsUFM ufm) -- | Pretty-print a non-deterministic set. -- The order of variables is non-deterministic and for pretty-printing that -- shouldn't be a problem. -- Having this function helps contain the non-determinism created with -- nonDetUFMToList. pprUFMWithKeys :: UniqFM a -- ^ The things to be pretty printed -> ([(Unique, a)] -> SDoc) -- ^ The pretty printing function to use on the elements -> SDoc -- ^ 'SDoc' where the things have been pretty -- printed pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm) -- | Determines the pluralisation suffix appropriate for the length of a set -- in the same way that plural from Outputable does for lists. pluralUFM :: UniqFM a -> SDoc pluralUFM ufm | sizeUFM ufm == 1 = empty | otherwise = char 's' ghc-lib-parser-8.10.2.20200808/compiler/utils/UniqSet.hs0000644000000000000000000001504513713635745020412 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1994-1998 \section[UniqSet]{Specialised sets, for things with @Uniques@} Based on @UniqFMs@ (as you would expect). Basically, the things need to be in class @Uniquable@. -} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} module UniqSet ( -- * Unique set type UniqSet, -- type synonym for UniqFM a getUniqSet, pprUniqSet, -- ** Manipulating these sets emptyUniqSet, unitUniqSet, mkUniqSet, addOneToUniqSet, addListToUniqSet, delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet, delListFromUniqSet_Directly, unionUniqSets, unionManyUniqSets, minusUniqSet, uniqSetMinusUFM, intersectUniqSets, restrictUniqSetToUFM, uniqSetAny, uniqSetAll, elementOfUniqSet, elemUniqSet_Directly, filterUniqSet, filterUniqSet_Directly, sizeUniqSet, isEmptyUniqSet, lookupUniqSet, lookupUniqSet_Directly, partitionUniqSet, mapUniqSet, unsafeUFMToUniqSet, nonDetEltsUniqSet, nonDetKeysUniqSet, nonDetFoldUniqSet, nonDetFoldUniqSet_Directly ) where import GhcPrelude import UniqFM import Unique import Data.Coerce import Outputable import Data.Data import qualified Data.Semigroup as Semi -- Note [UniqSet invariant] -- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- UniqSet has the following invariant: -- The keys in the map are the uniques of the values -- It means that to implement mapUniqSet you have to update -- both the keys and the values. newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a} deriving (Data, Semi.Semigroup, Monoid) emptyUniqSet :: UniqSet a emptyUniqSet = UniqSet emptyUFM unitUniqSet :: Uniquable a => a -> UniqSet a unitUniqSet x = UniqSet $ unitUFM x x mkUniqSet :: Uniquable a => [a] -> UniqSet a mkUniqSet = foldl' addOneToUniqSet emptyUniqSet addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x) addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a addListToUniqSet = foldl' addOneToUniqSet delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a) delOneFromUniqSet_Directly :: UniqSet a -> Unique -> UniqSet a delOneFromUniqSet_Directly (UniqSet s) u = UniqSet (delFromUFM_Directly s u) delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l) delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a delListFromUniqSet_Directly (UniqSet s) l = UniqSet (delListFromUFM_Directly s l) unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t) unionManyUniqSets :: [UniqSet a] -> UniqSet a unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t) intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t) restrictUniqSetToUFM :: UniqSet a -> UniqFM b -> UniqSet a restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m) uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t) elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool elementOfUniqSet a (UniqSet s) = elemUFM a s elemUniqSet_Directly :: Unique -> UniqSet a -> Bool elemUniqSet_Directly a (UniqSet s) = elemUFM_Directly a s filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a filterUniqSet p (UniqSet s) = UniqSet (filterUFM p s) filterUniqSet_Directly :: (Unique -> elt -> Bool) -> UniqSet elt -> UniqSet elt filterUniqSet_Directly f (UniqSet s) = UniqSet (filterUFM_Directly f s) partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a) partitionUniqSet p (UniqSet s) = coerce (partitionUFM p s) uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool uniqSetAny p (UniqSet s) = anyUFM p s uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool uniqSetAll p (UniqSet s) = allUFM p s sizeUniqSet :: UniqSet a -> Int sizeUniqSet (UniqSet s) = sizeUFM s isEmptyUniqSet :: UniqSet a -> Bool isEmptyUniqSet (UniqSet s) = isNullUFM s lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b lookupUniqSet (UniqSet s) k = lookupUFM s k lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a lookupUniqSet_Directly (UniqSet s) k = lookupUFM_Directly s k -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. nonDetEltsUniqSet :: UniqSet elt -> [elt] nonDetEltsUniqSet = nonDetEltsUFM . getUniqSet' -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. nonDetKeysUniqSet :: UniqSet elt -> [Unique] nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet' -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. nonDetFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a nonDetFoldUniqSet c n (UniqSet s) = nonDetFoldUFM c n s -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism. nonDetFoldUniqSet_Directly:: (Unique -> elt -> a -> a) -> a -> UniqSet elt -> a nonDetFoldUniqSet_Directly f n (UniqSet s) = nonDetFoldUFM_Directly f n s -- See Note [UniqSet invariant] mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet -- Two 'UniqSet's are considered equal if they contain the same -- uniques. instance Eq (UniqSet a) where UniqSet a == UniqSet b = equalKeysUFM a b getUniqSet :: UniqSet a -> UniqFM a getUniqSet = getUniqSet' -- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@ -- assuming, without checking, that it maps each 'Unique' to a value -- that has that 'Unique'. See Note [UniqSet invariant]. unsafeUFMToUniqSet :: UniqFM a -> UniqSet a unsafeUFMToUniqSet = UniqSet instance Outputable a => Outputable (UniqSet a) where ppr = pprUniqSet ppr pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc -- It's OK to use nonDetUFMToList here because we only use it for -- pretty-printing. pprUniqSet f = braces . pprWithCommas f . nonDetEltsUniqSet ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/UniqSupply.hs0000644000000000000000000001660413713636246022120 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE BangPatterns #-} #if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-} #endif module UniqSupply ( -- * Main data type UniqSupply, -- Abstractly -- ** Operations on supplies uniqFromSupply, uniqsFromSupply, -- basic ops takeUniqFromSupply, uniqFromMask, mkSplitUniqSupply, splitUniqSupply, listSplitUniqSupply, -- * Unique supply monad and its abstraction UniqSM, MonadUnique(..), -- ** Operations on the monad initUs, initUs_, -- * Set supply strategy initUniqSupply ) where import GhcPrelude import Unique import PlainPanic (panic) import GHC.IO import MonadUtils import Control.Monad import Data.Bits import Data.Char import Control.Monad.Fail as Fail #include "Unique.h" {- ************************************************************************ * * \subsection{Splittable Unique supply: @UniqSupply@} * * ************************************************************************ -} -- | Unique Supply -- -- A value of type 'UniqSupply' is unique, and it can -- supply /one/ distinct 'Unique'. Also, from the supply, one can -- also manufacture an arbitrary number of further 'UniqueSupply' values, -- which will be distinct from the first and from all others. data UniqSupply = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this UniqSupply UniqSupply -- when split => these two supplies mkSplitUniqSupply :: Char -> IO UniqSupply -- ^ Create a unique supply out of thin air. The character given must -- be distinct from those of all calls to this function in the compiler -- for the values generated to be truly unique. splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) -- ^ Build two 'UniqSupply' from a single one, each of which -- can supply its own 'Unique'. listSplitUniqSupply :: UniqSupply -> [UniqSupply] -- ^ Create an infinite list of 'UniqSupply' from a single one uniqFromSupply :: UniqSupply -> Unique -- ^ Obtain the 'Unique' from this particular 'UniqSupply' uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite -- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply) -- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply uniqFromMask :: Char -> IO Unique uniqFromMask mask = do { uqNum <- genSym ; return $! mkUnique mask uqNum } mkSplitUniqSupply c = case ord c `shiftL` uNIQUE_BITS of !mask -> let -- here comes THE MAGIC: -- This is one of the most hammered bits in the whole compiler mk_supply -- NB: Use unsafeInterleaveIO for thread-safety. = unsafeInterleaveIO ( genSym >>= \ u -> mk_supply >>= \ s1 -> mk_supply >>= \ s2 -> return (MkSplitUniqSupply (mask .|. u) s1 s2) ) in mk_supply foreign import ccall unsafe "ghc_lib_parser_genSym" genSym :: IO Int foreign import ccall unsafe "ghc_lib_parser_initGenSym" initUniqSupply :: Int -> Int -> IO () splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2 takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1) {- ************************************************************************ * * \subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@} * * ************************************************************************ -} -- Avoids using unboxed tuples when loading into GHCi #if !defined(GHC_LOADED_INTO_GHCI) type UniqResult result = (# result, UniqSupply #) pattern UniqResult :: a -> b -> (# a, b #) pattern UniqResult x y = (# x, y #) {-# COMPLETE UniqResult #-} #else data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply deriving (Functor) #endif -- | A monad which just gives the ability to obtain 'Unique's newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result } deriving (Functor) instance Monad UniqSM where (>>=) = thenUs (>>) = (*>) instance Applicative UniqSM where pure = returnUs (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of UniqResult ff us1 -> case x us1 of UniqResult xx us2 -> UniqResult (ff xx) us2 (*>) = thenUs_ -- TODO: try to get rid of this instance instance Fail.MonadFail UniqSM where fail = panic -- | Run the 'UniqSM' action, returning the final 'UniqSupply' initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) } -- | Run the 'UniqSM' action, discarding the final 'UniqSupply' initUs_ :: UniqSupply -> UniqSM a -> a initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r } {-# INLINE thenUs #-} {-# INLINE returnUs #-} {-# INLINE splitUniqSupply #-} -- @thenUs@ is where we split the @UniqSupply@. liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply) liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1) instance MonadFix UniqSM where mfix m = USM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1) thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b thenUs (USM expr) cont = USM (\us0 -> case (expr us0) of UniqResult result us1 -> unUSM (cont result) us1) thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b thenUs_ (USM expr) (USM cont) = USM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 }) returnUs :: a -> UniqSM a returnUs result = USM (\us -> UniqResult result us) getUs :: UniqSM UniqSupply getUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2) -- | A monad for generating unique identifiers class Monad m => MonadUnique m where -- | Get a new UniqueSupply getUniqueSupplyM :: m UniqSupply -- | Get a new unique identifier getUniqueM :: m Unique -- | Get an infinite list of new unique identifiers getUniquesM :: m [Unique] -- This default definition of getUniqueM, while correct, is not as -- efficient as it could be since it needlessly generates and throws away -- an extra Unique. For your instances consider providing an explicit -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly. getUniqueM = liftM uniqFromSupply getUniqueSupplyM getUniquesM = liftM uniqsFromSupply getUniqueSupplyM instance MonadUnique UniqSM where getUniqueSupplyM = getUs getUniqueM = getUniqueUs getUniquesM = getUniquesUs getUniqueUs :: UniqSM Unique getUniqueUs = USM (\us0 -> case takeUniqFromSupply us0 of (u,us1) -> UniqResult u us1) getUniquesUs :: UniqSM [Unique] getUniquesUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult (uniqsFromSupply us1) us2) ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/Unique.hs0000644000000000000000000003657313713635744021246 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @Uniques@ are used to distinguish entities in the compiler (@Ids@, @Classes@, etc.) from each other. Thus, @Uniques@ are the basic comparison key in the compiler. If there is any single operation that needs to be fast, it is @Unique@ comparison. Unsurprisingly, there is quite a bit of huff-and-puff directed to that end. Some of the other hair in this code is to be able to use a ``splittable @UniqueSupply@'' if requested/possible (not standard Haskell). -} {-# LANGUAGE CPP, BangPatterns, MagicHash #-} module Unique ( -- * Main data types Unique, Uniquable(..), uNIQUE_BITS, -- ** Constructors, destructors and operations on 'Unique's hasKey, pprUniqueAlways, mkUniqueGrimily, -- Used in UniqSupply only! getKey, -- Used in Var, UniqFM, Name only! mkUnique, unpkUnique, -- Used in BinIface only eqUnique, ltUnique, deriveUnique, -- Ditto newTagUnique, -- Used in CgCase initTyVarUnique, initExitJoinUnique, nonDetCmpUnique, isValidKnownKeyUnique, -- Used in PrelInfo.knownKeyNamesOkay -- ** Making built-in uniques -- now all the built-in Uniques (and functions to make them) -- [the Oh-So-Wonderful Haskell module system wins again...] mkAlphaTyVarUnique, mkPrimOpIdUnique, mkPrimOpWrapperUnique, mkPreludeMiscIdUnique, mkPreludeDataConUnique, mkPreludeTyConUnique, mkPreludeClassUnique, mkCoVarUnique, mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, mkCostCentreUnique, mkBuiltinUnique, mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, -- ** Deriving uniques -- *** From TyCon name uniques tyConRepNameUnique, -- *** From DataCon name uniques dataConWorkerUnique, dataConTyRepNameUnique ) where #include "GhclibHsVersions.h" #include "Unique.h" import GhcPrelude import BasicTypes import FastString import Outputable import Util -- just for implementing a fast [0,61) -> Char function import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) import Data.Char ( chr, ord ) import Data.Bits {- ************************************************************************ * * \subsection[Unique-type]{@Unique@ type and operations} * * ************************************************************************ The @Chars@ are ``tag letters'' that identify the @UniqueSupply@. Fast comparison is everything on @Uniques@: -} -- | Unique identifier. -- -- The type of unique identifiers that are used in many places in GHC -- for fast ordering and equality tests. You should generate these with -- the functions from the 'UniqSupply' module -- -- These are sometimes also referred to as \"keys\" in comments in GHC. newtype Unique = MkUnique Int {-# INLINE uNIQUE_BITS #-} uNIQUE_BITS :: Int uNIQUE_BITS = finiteBitSize (0 :: Int) - UNIQUE_TAG_BITS {- Now come the functions which construct uniques from their pieces, and vice versa. The stuff about unique *supplies* is handled further down this module. -} unpkUnique :: Unique -> (Char, Int) -- The reverse mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply getKey :: Unique -> Int -- for Var incrUnique :: Unique -> Unique stepUnique :: Unique -> Int -> Unique deriveUnique :: Unique -> Int -> Unique newTagUnique :: Unique -> Char -> Unique mkUniqueGrimily = MkUnique {-# INLINE getKey #-} getKey (MkUnique x) = x incrUnique (MkUnique i) = MkUnique (i + 1) stepUnique (MkUnique i) n = MkUnique (i + n) -- deriveUnique uses an 'X' tag so that it won't clash with -- any of the uniques produced any other way -- SPJ says: this looks terribly smelly to me! deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta) -- newTagUnique changes the "domain" of a unique to a different char newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u -- | How many bits are devoted to the unique index (as opposed to the class -- character). uniqueMask :: Int uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1 -- pop the Char in the top 8 bits of the Unique(Supply) -- No 64-bit bugs here, as long as we have at least 32 bits. --JSM -- and as long as the Char fits in 8 bits, which we assume anyway! mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces -- NOT EXPORTED, so that we can see all the Chars that -- are used in this one module mkUnique c i = MkUnique (tag .|. bits) where tag = ord c `shiftL` uNIQUE_BITS bits = i .&. uniqueMask unpkUnique (MkUnique u) = let -- as long as the Char may have its eighth bit set, we -- really do need the logical right-shift here! tag = chr (u `shiftR` uNIQUE_BITS) i = u .&. uniqueMask in (tag, i) -- | The interface file symbol-table encoding assumes that known-key uniques fit -- in 30-bits; verify this. -- -- See Note [Symbol table representation of names] in BinIface for details. isValidKnownKeyUnique :: Unique -> Bool isValidKnownKeyUnique u = case unpkUnique u of (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22) {- ************************************************************************ * * \subsection[Uniquable-class]{The @Uniquable@ class} * * ************************************************************************ -} -- | Class of things that we can obtain a 'Unique' from class Uniquable a where getUnique :: a -> Unique hasKey :: Uniquable a => a -> Unique -> Bool x `hasKey` k = getUnique x == k instance Uniquable FastString where getUnique fs = mkUniqueGrimily (uniqueOfFS fs) instance Uniquable Int where getUnique i = mkUniqueGrimily i {- ************************************************************************ * * \subsection[Unique-instances]{Instance declarations for @Unique@} * * ************************************************************************ And the whole point (besides uniqueness) is fast equality. We don't use `deriving' because we want {\em precise} control of ordering (equality on @Uniques@ is v common). -} -- Note [Unique Determinism] -- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- The order of allocated @Uniques@ is not stable across rebuilds. -- The main reason for that is that typechecking interface files pulls -- @Uniques@ from @UniqSupply@ and the interface file for the module being -- currently compiled can, but doesn't have to exist. -- -- It gets more complicated if you take into account that the interface -- files are loaded lazily and that building multiple files at once has to -- work for any subset of interface files present. When you add parallelism -- this makes @Uniques@ hopelessly random. -- -- As such, to get deterministic builds, the order of the allocated -- @Uniques@ should not affect the final result. -- see also wiki/deterministic-builds -- -- Note [Unique Determinism and code generation] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- The goal of the deterministic builds (wiki/deterministic-builds, #4012) -- is to get ABI compatible binaries given the same inputs and environment. -- The motivation behind that is that if the ABI doesn't change the -- binaries can be safely reused. -- Note that this is weaker than bit-for-bit identical binaries and getting -- bit-for-bit identical binaries is not a goal for now. -- This means that we don't care about nondeterminism that happens after -- the interface files are created, in particular we don't care about -- register allocation and code generation. -- To track progress on bit-for-bit determinism see #12262. eqUnique :: Unique -> Unique -> Bool eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2 ltUnique :: Unique -> Unique -> Bool ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2 -- Provided here to make it explicit at the call-site that it can -- introduce non-determinism. -- See Note [Unique Determinism] -- See Note [No Ord for Unique] nonDetCmpUnique :: Unique -> Unique -> Ordering nonDetCmpUnique (MkUnique u1) (MkUnique u2) = if u1 == u2 then EQ else if u1 < u2 then LT else GT {- Note [No Ord for Unique] ~~~~~~~~~~~~~~~~~~~~~~~~~~ As explained in Note [Unique Determinism] the relative order of Uniques is nondeterministic. To prevent from accidental use the Ord Unique instance has been removed. This makes it easier to maintain deterministic builds, but comes with some drawbacks. The biggest drawback is that Maps keyed by Uniques can't directly be used. The alternatives are: 1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which 2) Create a newtype wrapper based on Unique ordering where nondeterminism is controlled. See Module.ModuleEnv 3) Change the algorithm to use nonDetCmpUnique and document why it's still deterministic 4) Use TrieMap as done in CmmCommonBlockElim.groupByLabel -} instance Eq Unique where a == b = eqUnique a b a /= b = not (eqUnique a b) instance Uniquable Unique where getUnique u = u -- We do sometimes make strings with @Uniques@ in them: showUnique :: Unique -> String showUnique uniq = case unpkUnique uniq of (tag, u) -> finish_show tag u (iToBase62 u) finish_show :: Char -> Int -> String -> String finish_show 't' u _pp_u | u < 26 = -- Special case to make v common tyvars, t1, t2, ... -- come out as a, b, ... (shorter, easier to read) [chr (ord 'a' + u)] finish_show tag _ pp_u = tag : pp_u pprUniqueAlways :: Unique -> SDoc -- The "always" means regardless of -dsuppress-uniques -- It replaces the old pprUnique to remind callers that -- they should consider whether they want to consult -- Opt_SuppressUniques pprUniqueAlways u = text (showUnique u) instance Outputable Unique where ppr = pprUniqueAlways instance Show Unique where show uniq = showUnique uniq {- ************************************************************************ * * \subsection[Utils-base62]{Base-62 numbers} * * ************************************************************************ A character-stingy way to read/write numbers (notably Uniques). The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. Code stolen from Lennart. -} iToBase62 :: Int -> String iToBase62 n_ = ASSERT(n_ >= 0) go n_ "" where go n cs | n < 62 = let !c = chooseChar62 n in c : cs | otherwise = go q (c : cs) where (!q, r) = quotRem n 62 !c = chooseChar62 r chooseChar62 :: Int -> Char {-# INLINE chooseChar62 #-} chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n) chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# {- ************************************************************************ * * \subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things} * * ************************************************************************ Allocation of unique supply characters: v,t,u : for renumbering value-, type- and usage- vars. B: builtin C-E: pseudo uniques (used in native-code generator) X: uniques derived by deriveUnique _: unifiable tyvars (above) 0-9: prelude things below (no numbers left any more..) :: (prelude) parallel array data constructors other a-z: lower case chars for unique supplies. Used so far: d desugarer f AbsC flattener g SimplStg k constraint tuple tycons m constraint tuple datacons n Native codegen r Hsc name cache s simplifier z anonymous sums -} mkAlphaTyVarUnique :: Int -> Unique mkPreludeClassUnique :: Int -> Unique mkPreludeTyConUnique :: Int -> Unique mkPreludeDataConUnique :: Arity -> Unique mkPrimOpIdUnique :: Int -> Unique -- See Note [Primop wrappers] in PrimOp.hs. mkPrimOpWrapperUnique :: Int -> Unique mkPreludeMiscIdUnique :: Int -> Unique mkCoVarUnique :: Int -> Unique mkAlphaTyVarUnique i = mkUnique '1' i mkCoVarUnique i = mkUnique 'g' i mkPreludeClassUnique i = mkUnique '2' i -------------------------------------------------- -- Wired-in type constructor keys occupy *two* slots: -- * u: the TyCon itself -- * u+1: the TyConRepName of the TyCon mkPreludeTyConUnique i = mkUnique '3' (2*i) tyConRepNameUnique :: Unique -> Unique tyConRepNameUnique u = incrUnique u -- Data constructor keys occupy *two* slots. The first is used for the -- data constructor itself and its wrapper function (the function that -- evaluates arguments as necessary and calls the worker). The second is -- used for the worker function (the function that builds the constructor -- representation). -------------------------------------------------- -- Wired-in data constructor keys occupy *three* slots: -- * u: the DataCon itself -- * u+1: its worker Id -- * u+2: the TyConRepName of the promoted TyCon -- Prelude data constructors are too simple to need wrappers. mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic -------------------------------------------------- dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique dataConWorkerUnique u = incrUnique u dataConTyRepNameUnique u = stepUnique u 2 -------------------------------------------------- mkPrimOpIdUnique op = mkUnique '9' (2*op) mkPrimOpWrapperUnique op = mkUnique '9' (2*op+1) mkPreludeMiscIdUnique i = mkUnique '0' i -- The "tyvar uniques" print specially nicely: a, b, c, etc. -- See pprUnique for details initTyVarUnique :: Unique initTyVarUnique = mkUnique 't' 0 mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, mkBuiltinUnique :: Int -> Unique mkBuiltinUnique i = mkUnique 'B' i mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique mkRegSingleUnique = mkUnique 'R' mkRegSubUnique = mkUnique 'S' mkRegPairUnique = mkUnique 'P' mkRegClassUnique = mkUnique 'L' mkCostCentreUnique :: Int -> Unique mkCostCentreUnique = mkUnique 'C' mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique -- See Note [The Unique of an OccName] in OccName mkVarOccUnique fs = mkUnique 'i' (uniqueOfFS fs) mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs) mkTvOccUnique fs = mkUnique 'v' (uniqueOfFS fs) mkTcOccUnique fs = mkUnique 'c' (uniqueOfFS fs) initExitJoinUnique :: Unique initExitJoinUnique = mkUnique 's' 0 ghc-lib-parser-8.10.2.20200808/compiler/utils/Util.hs0000644000000000000000000014133613713635745017742 0ustar0000000000000000-- (c) The University of Glasgow 2006 {-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TupleSections #-} -- | Highly random utility functions -- module Util ( -- * Flags dependent on the compiler build ghciSupported, debugIsOn, ghciTablesNextToCode, isWindowsHost, isDarwinHost, -- * Miscellaneous higher-order functions applyWhen, nTimes, -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, zipLazy, stretchZipWith, zipWithAndUnzip, zipAndUnzip, zipWithLazy, zipWith3Lazy, filterByList, filterByLists, partitionByList, unzipWith, mapFst, mapSnd, chkAppend, mapAndUnzip, mapAndUnzip3, mapAccumL2, filterOut, partitionWith, dropWhileEndLE, spanEnd, last2, lastMaybe, foldl1', foldl2, count, countWhile, all2, lengthExceeds, lengthIs, lengthIsNot, lengthAtLeast, lengthAtMost, lengthLessThan, listLengthCmp, atLength, equalLength, compareLength, leLength, ltLength, isSingleton, only, singleton, notNull, snocView, isIn, isn'tIn, chunkList, changeLast, whenNonEmpty, -- * Tuples fstOf3, sndOf3, thdOf3, firstM, first3M, secondM, fst3, snd3, third3, uncurry3, liftFst, liftSnd, -- * List operations controlled by another list takeList, dropList, splitAtList, split, dropTail, capitalise, -- * Sorting sortWith, minWith, nubSort, ordNub, -- * Comparisons isEqual, eqListBy, eqMaybeBy, thenCmp, cmpList, removeSpaces, (<&&>), (<||>), -- * Edit distance fuzzyMatch, fuzzyLookup, -- * Transitive closures transitiveClosure, -- * Strictness seqList, -- * Module names looksLikeModuleName, looksLikePackageName, -- * Argument processing getCmd, toCmdArgs, toArgs, -- * Integers exactLog2, -- * Floating point readRational, readHexRational, -- * IO-ish utilities doesDirNameExist, getModificationUTCTime, modificationTimeIfExists, withAtomicRename, global, consIORef, globalM, sharedGlobal, sharedGlobalM, -- * Filenames and paths Suffix, splitLongestPrefix, escapeSpaces, Direction(..), reslash, makeRelativeTo, -- * Utils for defining Data instances abstractConstr, abstractDataType, mkNoRepType, -- * Utils for printing C code charToC, -- * Hashing hashString, -- * Call stacks HasCallStack, HasDebugCallStack, -- * Utils for flags OverridingBool(..), overrideWith, ) where #include "GhclibHsVersions.h" import GhcPrelude import Exception import PlainPanic import Data.Data import Data.IORef ( IORef, newIORef, atomicModifyIORef' ) import System.IO.Unsafe ( unsafePerformIO ) import Data.List hiding (group) import Data.List.NonEmpty ( NonEmpty(..) ) import GHC.Exts import GHC.Stack (HasCallStack) import Control.Applicative ( liftA2 ) import Control.Monad ( liftM, guard ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import GHC.Conc.Sync ( sharedCAF ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) import System.FilePath import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper , isHexDigit, digitToInt ) import Data.Int import Data.Ratio ( (%) ) import Data.Ord ( comparing ) import Data.Bits import Data.Word import qualified Data.IntMap as IM import qualified Data.Set as Set import Data.Time #if defined(DEBUG) import {-# SOURCE #-} Outputable ( warnPprTrace, text ) #endif infixr 9 `thenCmp` {- ************************************************************************ * * \subsection{Is DEBUG on, are we on Windows, etc?} * * ************************************************************************ These booleans are global constants, set by CPP flags. They allow us to recompile a single module (this one) to change whether or not debug output appears. They sometimes let us avoid even running CPP elsewhere. It's important that the flags are literal constants (True/False). Then, with -0, tests of the flags in other modules will simplify to the correct branch of the conditional, thereby dropping debug code altogether when the flags are off. -} ghciSupported :: Bool #if defined(HAVE_INTERNAL_INTERPRETER) ghciSupported = True #else ghciSupported = False #endif debugIsOn :: Bool #if defined(DEBUG) debugIsOn = True #else debugIsOn = False #endif ghciTablesNextToCode :: Bool #if defined(GHCI_TABLES_NEXT_TO_CODE) ghciTablesNextToCode = True #else ghciTablesNextToCode = False #endif isWindowsHost :: Bool #if defined(mingw32_HOST_OS) isWindowsHost = True #else isWindowsHost = False #endif isDarwinHost :: Bool #if defined(darwin_HOST_OS) isDarwinHost = True #else isDarwinHost = False #endif {- ************************************************************************ * * \subsection{Miscellaneous higher-order functions} * * ************************************************************************ -} -- | Apply a function iff some condition is met. applyWhen :: Bool -> (a -> a) -> a -> a applyWhen True f x = f x applyWhen _ _ x = x -- | A for loop: Compose a function with itself n times. (nth rather than twice) nTimes :: Int -> (a -> a) -> (a -> a) nTimes 0 _ = id nTimes 1 f = f nTimes n f = f . nTimes (n-1) f fstOf3 :: (a,b,c) -> a sndOf3 :: (a,b,c) -> b thdOf3 :: (a,b,c) -> c fstOf3 (a,_,_) = a sndOf3 (_,b,_) = b thdOf3 (_,_,c) = c fst3 :: (a -> d) -> (a, b, c) -> (d, b, c) fst3 f (a, b, c) = (f a, b, c) snd3 :: (b -> d) -> (a, b, c) -> (a, d, c) snd3 f (a, b, c) = (a, f b, c) third3 :: (c -> d) -> (a, b, c) -> (a, b, d) third3 f (a, b, c) = (a, b, f c) uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c liftFst :: (a -> b) -> (a, c) -> (b, c) liftFst f (a,c) = (f a, c) liftSnd :: (a -> b) -> (c, a) -> (c, b) liftSnd f (c,a) = (c, f a) firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) firstM f (x, y) = liftM (\x' -> (x', y)) (f x) first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c) first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x) secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c) secondM f (x, y) = (x,) <$> f y {- ************************************************************************ * * \subsection[Utils-lists]{General list processing} * * ************************************************************************ -} filterOut :: (a->Bool) -> [a] -> [a] -- ^ Like filter, only it reverses the sense of the test filterOut _ [] = [] filterOut p (x:xs) | p x = filterOut p xs | otherwise = x : filterOut p xs partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) -- ^ Uses a function to determine which of two output lists an input element should join partitionWith _ [] = ([],[]) partitionWith f (x:xs) = case f x of Left b -> (b:bs, cs) Right c -> (bs, c:cs) where (bs,cs) = partitionWith f xs chkAppend :: [a] -> [a] -> [a] -- Checks for the second argument being empty -- Used in situations where that situation is common chkAppend xs ys | null ys = xs | otherwise = xs ++ ys {- A paranoid @zip@ (and some @zipWith@ friends) that checks the lists are of equal length. Alastair Reid thinks this should only happen if DEBUGging on; hey, why not? -} zipEqual :: String -> [a] -> [b] -> [(a,b)] zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] #if !defined(DEBUG) zipEqual _ = zip zipWithEqual _ = zipWith zipWith3Equal _ = zipWith3 zipWith4Equal _ = zipWith4 #else zipEqual _ [] [] = [] zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg) zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs zipWithEqual _ _ [] [] = [] zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg) zipWith3Equal msg z (a:as) (b:bs) (c:cs) = z a b c : zipWith3Equal msg z as bs cs zipWith3Equal _ _ [] [] [] = [] zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg) zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) = z a b c d : zipWith4Equal msg z as bs cs ds zipWith4Equal _ _ [] [] [] [] = [] zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) #endif -- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) zipLazy :: [a] -> [b] -> [(a,b)] zipLazy [] _ = [] zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys -- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list. -- The length of the output is always the same as the length of the first -- list. zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c] zipWithLazy _ [] _ = [] zipWithLazy f (a:as) ~(b:bs) = f a b : zipWithLazy f as bs -- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists. -- The length of the output is always the same as the length of the first -- list. zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] zipWith3Lazy _ [] _ _ = [] zipWith3Lazy f (a:as) ~(b:bs) ~(c:cs) = f a b c : zipWith3Lazy f as bs cs -- | 'filterByList' takes a list of Bools and a list of some elements and -- filters out these elements for which the corresponding value in the list of -- Bools is False. This function does not check whether the lists have equal -- length. filterByList :: [Bool] -> [a] -> [a] filterByList (True:bs) (x:xs) = x : filterByList bs xs filterByList (False:bs) (_:xs) = filterByList bs xs filterByList _ _ = [] -- | 'filterByLists' takes a list of Bools and two lists as input, and -- outputs a new list consisting of elements from the last two input lists. For -- each Bool in the list, if it is 'True', then it takes an element from the -- former list. If it is 'False', it takes an element from the latter list. -- The elements taken correspond to the index of the Bool in its list. -- For example: -- -- @ -- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" -- @ -- -- This function does not check whether the lists have equal length. filterByLists :: [Bool] -> [a] -> [a] -> [a] filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys filterByLists _ _ _ = [] -- | 'partitionByList' takes a list of Bools and a list of some elements and -- partitions the list according to the list of Bools. Elements corresponding -- to 'True' go to the left; elements corresponding to 'False' go to the right. -- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ -- This function does not check whether the lists have equal -- length; when one list runs out, the function stops. partitionByList :: [Bool] -> [a] -> ([a], [a]) partitionByList = go [] [] where go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs go trues falses _ _ = (reverse trues, reverse falses) stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] -- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in -- the places where @p@ returns @True@ stretchZipWith _ _ _ [] _ = [] stretchZipWith p z f (x:xs) ys | p x = f x z : stretchZipWith p z f xs ys | otherwise = case ys of [] -> [] (y:ys) -> f x y : stretchZipWith p z f xs ys mapFst :: (a->c) -> [(a,b)] -> [(c,b)] mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] mapFst f xys = [(f x, y) | (x,y) <- xys] mapSnd f xys = [(x, f y) | (x,y) <- xys] mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) mapAndUnzip _ [] = ([], []) mapAndUnzip f (x:xs) = let (r1, r2) = f x (rs1, rs2) = mapAndUnzip f xs in (r1:rs1, r2:rs2) mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) mapAndUnzip3 _ [] = ([], [], []) mapAndUnzip3 f (x:xs) = let (r1, r2, r3) = f x (rs1, rs2, rs3) = mapAndUnzip3 f xs in (r1:rs1, r2:rs2, r3:rs3) zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) zipWithAndUnzip f (a:as) (b:bs) = let (r1, r2) = f a b (rs1, rs2) = zipWithAndUnzip f as bs in (r1:rs1, r2:rs2) zipWithAndUnzip _ _ _ = ([],[]) -- | This has the effect of making the two lists have equal length by dropping -- the tail of the longer one. zipAndUnzip :: [a] -> [b] -> ([a],[b]) zipAndUnzip (a:as) (b:bs) = let (rs1, rs2) = zipAndUnzip as bs in (a:rs1, b:rs2) zipAndUnzip _ _ = ([],[]) mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b]) mapAccumL2 f s1 s2 xs = (s1', s2', ys) where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of (s1', s2', y) -> ((s1', s2'), y)) (s1, s2) xs -- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely: -- -- @ -- atLength atLenPred atEndPred ls n -- | n < 0 = atLenPred ls -- | length ls < n = atEndPred (n - length ls) -- | otherwise = atLenPred (drop n ls) -- @ atLength :: ([a] -> b) -- Called when length ls >= n, passed (drop n ls) -- NB: arg passed to this function may be [] -> b -- Called when length ls < n -> [a] -> Int -> b atLength atLenPred atEnd ls0 n0 | n0 < 0 = atLenPred ls0 | otherwise = go n0 ls0 where -- go's first arg n >= 0 go 0 ls = atLenPred ls go _ [] = atEnd -- n > 0 here go n (_:xs) = go (n-1) xs -- Some special cases of atLength: -- | @(lengthExceeds xs n) = (length xs > n)@ lengthExceeds :: [a] -> Int -> Bool lengthExceeds lst n | n < 0 = True | otherwise = atLength notNull False lst n -- | @(lengthAtLeast xs n) = (length xs >= n)@ lengthAtLeast :: [a] -> Int -> Bool lengthAtLeast = atLength (const True) False -- | @(lengthIs xs n) = (length xs == n)@ lengthIs :: [a] -> Int -> Bool lengthIs lst n | n < 0 = False | otherwise = atLength null False lst n -- | @(lengthIsNot xs n) = (length xs /= n)@ lengthIsNot :: [a] -> Int -> Bool lengthIsNot lst n | n < 0 = True | otherwise = atLength notNull True lst n -- | @(lengthAtMost xs n) = (length xs <= n)@ lengthAtMost :: [a] -> Int -> Bool lengthAtMost lst n | n < 0 = False | otherwise = atLength null True lst n -- | @(lengthLessThan xs n) == (length xs < n)@ lengthLessThan :: [a] -> Int -> Bool lengthLessThan = atLength (const False) True listLengthCmp :: [a] -> Int -> Ordering listLengthCmp = atLength atLen atEnd where atEnd = LT -- Not yet seen 'n' elts, so list length is < n. atLen [] = EQ atLen _ = GT equalLength :: [a] -> [b] -> Bool -- ^ True if length xs == length ys equalLength [] [] = True equalLength (_:xs) (_:ys) = equalLength xs ys equalLength _ _ = False compareLength :: [a] -> [b] -> Ordering compareLength [] [] = EQ compareLength (_:xs) (_:ys) = compareLength xs ys compareLength [] _ = LT compareLength _ [] = GT leLength :: [a] -> [b] -> Bool -- ^ True if length xs <= length ys leLength xs ys = case compareLength xs ys of LT -> True EQ -> True GT -> False ltLength :: [a] -> [b] -> Bool -- ^ True if length xs < length ys ltLength xs ys = case compareLength xs ys of LT -> True EQ -> False GT -> False ---------------------------- singleton :: a -> [a] singleton x = [x] isSingleton :: [a] -> Bool isSingleton [_] = True isSingleton _ = False notNull :: [a] -> Bool notNull [] = False notNull _ = True only :: [a] -> a #if defined(DEBUG) only [a] = a #else only (a:_) = a #endif only _ = panic "Util: only" -- Debugging/specialising versions of \tr{elem} and \tr{notElem} isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool # if !defined(DEBUG) isIn _msg x ys = x `elem` ys isn'tIn _msg x ys = x `notElem` ys # else /* DEBUG */ isIn msg x ys = elem100 0 x ys where elem100 :: Eq a => Int -> a -> [a] -> Bool elem100 _ _ [] = False elem100 i x (y:ys) | i > 100 = WARN(True, text ("Over-long elem in " ++ msg)) (x `elem` (y:ys)) | otherwise = x == y || elem100 (i + 1) x ys isn'tIn msg x ys = notElem100 0 x ys where notElem100 :: Eq a => Int -> a -> [a] -> Bool notElem100 _ _ [] = True notElem100 i x (y:ys) | i > 100 = WARN(True, text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys)) | otherwise = x /= y && notElem100 (i + 1) x ys # endif /* DEBUG */ -- | Split a list into chunks of /n/ elements chunkList :: Int -> [a] -> [[a]] chunkList _ [] = [] chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs -- | Replace the last element of a list with another element. changeLast :: [a] -> a -> [a] changeLast [] _ = panic "changeLast" changeLast [_] x = [x] changeLast (x:xs) x' = x : changeLast xs x' whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty [] _ = pure () whenNonEmpty (x:xs) f = f (x :| xs) {- ************************************************************************ * * \subsubsection{Sort utils} * * ************************************************************************ -} minWith :: Ord b => (a -> b) -> [a] -> a minWith get_key xs = ASSERT( not (null xs) ) head (sortWith get_key xs) nubSort :: Ord a => [a] -> [a] nubSort = Set.toAscList . Set.fromList -- | Remove duplicates but keep elements in order. -- O(n * log n) ordNub :: Ord a => [a] -> [a] ordNub xs = go Set.empty xs where go _ [] = [] go s (x:xs) | Set.member x s = go s xs | otherwise = x : go (Set.insert x s) xs {- ************************************************************************ * * \subsection[Utils-transitive-closure]{Transitive closure} * * ************************************************************************ This algorithm for transitive closure is straightforward, albeit quadratic. -} transitiveClosure :: (a -> [a]) -- Successor function -> (a -> a -> Bool) -- Equality predicate -> [a] -> [a] -- The transitive closure transitiveClosure succ eq xs = go [] xs where go done [] = done go done (x:xs) | x `is_in` done = go done xs | otherwise = go (x:done) (succ x ++ xs) _ `is_in` [] = False x `is_in` (y:ys) | eq x y = True | otherwise = x `is_in` ys {- ************************************************************************ * * \subsection[Utils-accum]{Accumulating} * * ************************************************************************ A combination of foldl with zip. It works with equal length lists. -} foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc foldl2 _ z [] [] = z foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs foldl2 _ _ _ _ = panic "Util: foldl2" all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool -- True if the lists are the same length, and -- all corresponding elements satisfy the predicate all2 _ [] [] = True all2 p (x:xs) (y:ys) = p x y && all2 p xs ys all2 _ _ _ = False -- Count the number of times a predicate is true count :: (a -> Bool) -> [a] -> Int count p = go 0 where go !n [] = n go !n (x:xs) | p x = go (n+1) xs | otherwise = go n xs countWhile :: (a -> Bool) -> [a] -> Int -- Length of an /initial prefix/ of the list satsifying p countWhile p = go 0 where go !n (x:xs) | p x = go (n+1) xs go !n _ = n {- @splitAt@, @take@, and @drop@ but with length of another list giving the break-off point: -} takeList :: [b] -> [a] -> [a] -- (takeList as bs) trims bs to the be same length -- as as, unless as is longer in which case it's a no-op takeList [] _ = [] takeList (_:xs) ls = case ls of [] -> [] (y:ys) -> y : takeList xs ys dropList :: [b] -> [a] -> [a] dropList [] xs = xs dropList _ xs@[] = xs dropList (_:xs) (_:ys) = dropList xs ys splitAtList :: [b] -> [a] -> ([a], [a]) splitAtList [] xs = ([], xs) splitAtList _ xs@[] = (xs, xs) splitAtList (_:xs) (y:ys) = (y:ys', ys'') where (ys', ys'') = splitAtList xs ys -- drop from the end of a list dropTail :: Int -> [a] -> [a] -- Specification: dropTail n = reverse . drop n . reverse -- Better implemention due to Joachim Breitner -- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html dropTail n xs = go (drop n xs) xs where go (_:ys) (x:xs) = x : go ys xs go _ _ = [] -- Stop when ys runs out -- It'll always run out before xs does -- dropWhile from the end of a list. This is similar to Data.List.dropWhileEnd, -- but is lazy in the elements and strict in the spine. For reasonably short lists, -- such as path names and typical lines of text, dropWhileEndLE is generally -- faster than dropWhileEnd. Its advantage is magnified when the predicate is -- expensive--using dropWhileEndLE isSpace to strip the space off a line of text -- is generally much faster than using dropWhileEnd isSpace for that purpose. -- Specification: dropWhileEndLE p = reverse . dropWhile p . reverse -- Pay attention to the short-circuit (&&)! The order of its arguments is the only -- difference between dropWhileEnd and dropWhileEndLE. dropWhileEndLE :: (a -> Bool) -> [a] -> [a] dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] -- | @spanEnd p l == reverse (span p (reverse l))@. The first list -- returns actually comes after the second list (when you look at the -- input list). spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) spanEnd p l = go l [] [] l where go yes _rev_yes rev_no [] = (yes, reverse rev_no) go yes rev_yes rev_no (x:xs) | p x = go yes (x : rev_yes) rev_no xs | otherwise = go xs [] (x : rev_yes ++ rev_no) xs -- | Get the last two elements in a list. Partial! {-# INLINE last2 #-} last2 :: [a] -> (a,a) last2 = foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError) where partialError = panic "last2 - list length less than two" lastMaybe :: [a] -> Maybe a lastMaybe [] = Nothing lastMaybe xs = Just $ last xs -- | Split a list into its last element and the initial part of the list. -- @snocView xs = Just (init xs, last xs)@ for non-empty lists. -- @snocView xs = Nothing@ otherwise. -- Unless both parts of the result are guaranteed to be used -- prefer separate calls to @last@ + @init@. -- If you are guaranteed to use both, this will -- be more efficient. snocView :: [a] -> Maybe ([a],a) snocView [] = Nothing snocView xs | (xs,x) <- go xs = Just (xs,x) where go :: [a] -> ([a],a) go [x] = ([],x) go (x:xs) | !(xs',x') <- go xs = (x:xs', x') go [] = error "impossible" split :: Char -> String -> [String] split c s = case rest of [] -> [chunk] _:rest -> chunk : split c rest where (chunk, rest) = break (==c) s -- | Convert a word to title case by capitalising the first letter capitalise :: String -> String capitalise [] = [] capitalise (c:cs) = toUpper c : cs {- ************************************************************************ * * \subsection[Utils-comparison]{Comparisons} * * ************************************************************************ -} isEqual :: Ordering -> Bool -- Often used in (isEqual (a `compare` b)) isEqual GT = False isEqual EQ = True isEqual LT = False thenCmp :: Ordering -> Ordering -> Ordering {-# INLINE thenCmp #-} thenCmp EQ ordering = ordering thenCmp ordering _ = ordering eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool eqListBy _ [] [] = True eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys eqListBy _ _ _ = False eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool eqMaybeBy _ Nothing Nothing = True eqMaybeBy eq (Just x) (Just y) = eq x y eqMaybeBy _ _ _ = False cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering -- `cmpList' uses a user-specified comparer cmpList _ [] [] = EQ cmpList _ [] _ = LT cmpList _ _ [] = GT cmpList cmp (a:as) (b:bs) = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } removeSpaces :: String -> String removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace -- Boolean operators lifted to Applicative (<&&>) :: Applicative f => f Bool -> f Bool -> f Bool (<&&>) = liftA2 (&&) infixr 3 <&&> -- same as (&&) (<||>) :: Applicative f => f Bool -> f Bool -> f Bool (<||>) = liftA2 (||) infixr 2 <||> -- same as (||) {- ************************************************************************ * * \subsection{Edit distance} * * ************************************************************************ -} -- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. -- See: . -- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing -- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). -- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and -- http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation restrictedDamerauLevenshteinDistance :: String -> String -> Int restrictedDamerauLevenshteinDistance str1 str2 = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 where m = length str1 n = length str2 restrictedDamerauLevenshteinDistanceWithLengths :: Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 | m <= n = if n <= 32 -- n must be larger so this check is sufficient then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2 | otherwise = if m <= 32 -- m must be larger so this check is sufficient then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 restrictedDamerauLevenshteinDistance' :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 | [] <- str1 = n | otherwise = extractAnswer $ foldl' (restrictedDamerauLevenshteinDistanceWorker (matchVectors str1) top_bit_mask vector_mask) (0, 0, m_ones, 0, m) str2 where m_ones@vector_mask = (2 ^ m) - 1 top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy extractAnswer (_, _, _, _, distance) = distance restrictedDamerauLevenshteinDistanceWorker :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask (pm, d0, vp, vn, distance) char2 = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $ seq pm' $ seq d0' $ seq vp' $ seq vn' $ seq distance'' $ seq char2 $ (pm', d0', vp', vn', distance'') where pm' = IM.findWithDefault 0 (ord char2) str1_mvs d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn -- No need to mask the shiftL because of the restricted range of pm hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) hn' = d0' .&. vp hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask hn'_shift = (hn' `shiftL` 1) .&. vector_mask vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift) vn' = d0' .&. hp'_shift distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance' sizedComplement :: Bits bv => bv -> bv -> bv sizedComplement vector_mask vect = vector_mask `xor` vect matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv matchVectors = snd . foldl' go (0 :: Int, IM.empty) where go (ix, im) char = let ix' = ix + 1 im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im in seq ix' $ seq im' $ (ix', im') {-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' :: Word32 -> Int -> Int -> String -> String -> Int #-} {-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' :: Integer -> Int -> Int -> String -> String -> Int #-} {-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32, Int) -> Char -> (Word32, Word32, Word32, Word32, Int) #-} {-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Integer -> Integer -> Integer -> (Integer, Integer, Integer, Integer, Int) -> Char -> (Integer, Integer, Integer, Integer, Int) #-} {-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-} {-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-} {-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-} {-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-} fuzzyMatch :: String -> [String] -> [String] fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals] -- | Search for possible matches to the users input in the given list, -- returning a small number of ranked results fuzzyLookup :: String -> [(String,a)] -> [a] fuzzyLookup user_entered possibilites = map fst $ take mAX_RESULTS $ sortBy (comparing snd) [ (poss_val, distance) | (poss_str, poss_val) <- possibilites , let distance = restrictedDamerauLevenshteinDistance poss_str user_entered , distance <= fuzzy_threshold ] where -- Work out an approriate match threshold: -- We report a candidate if its edit distance is <= the threshold, -- The threshold is set to about a quarter of the # of characters the user entered -- Length Threshold -- 1 0 -- Don't suggest *any* candidates -- 2 1 -- for single-char identifiers -- 3 1 -- 4 1 -- 5 1 -- 6 2 -- fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational) mAX_RESULTS = 3 {- ************************************************************************ * * \subsection[Utils-pairs]{Pairs} * * ************************************************************************ -} unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs seqList :: [a] -> b -> b seqList [] b = b seqList (x:xs) b = x `seq` seqList xs b {- ************************************************************************ * * Globals and the RTS * * ************************************************************************ When a plugin is loaded, it currently gets linked against a *newly loaded* copy of the GHC package. This would not be a problem, except that the new copy has its own mutable state that is not shared with that state that has already been initialized by the original GHC package. (Note that if the GHC executable was dynamically linked this wouldn't be a problem, because we could share the GHC library it links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.) The solution is to make use of @sharedCAF@ through @sharedGlobal@ for globals that are shared between multiple copies of ghc packages. -} -- Global variables: global :: a -> IORef a global a = unsafePerformIO (newIORef a) consIORef :: IORef [a] -> a -> IO () consIORef var x = do atomicModifyIORef' var (\xs -> (x:xs,())) globalM :: IO a -> IORef a globalM ma = unsafePerformIO (ma >>= newIORef) -- Shared global variables: sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a sharedGlobal a get_or_set = unsafePerformIO $ newIORef a >>= flip sharedCAF get_or_set sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a sharedGlobalM ma get_or_set = unsafePerformIO $ ma >>= newIORef >>= flip sharedCAF get_or_set -- Module names: looksLikeModuleName :: String -> Bool looksLikeModuleName [] = False looksLikeModuleName (c:cs) = isUpper c && go cs where go [] = True go ('.':cs) = looksLikeModuleName cs go (c:cs) = (isAlphaNum c || c == '_' || c == '\'') && go cs -- Similar to 'parse' for Distribution.Package.PackageName, -- but we don't want to depend on Cabal. looksLikePackageName :: String -> Bool looksLikePackageName = all (all isAlphaNum <&&> not . (all isDigit)) . split '-' {- Akin to @Prelude.words@, but acts like the Bourne shell, treating quoted strings as Haskell Strings, and also parses Haskell [String] syntax. -} getCmd :: String -> Either String -- Error (String, String) -- (Cmd, Rest) getCmd s = case break isSpace $ dropWhile isSpace s of ([], _) -> Left ("Couldn't find command in " ++ show s) res -> Right res toCmdArgs :: String -> Either String -- Error (String, [String]) -- (Cmd, Args) toCmdArgs s = case getCmd s of Left err -> Left err Right (cmd, s') -> case toArgs s' of Left err -> Left err Right args -> Right (cmd, args) toArgs :: String -> Either String -- Error [String] -- Args toArgs str = case dropWhile isSpace str of s@('[':_) -> case reads s of [(args, spaces)] | all isSpace spaces -> Right args _ -> Left ("Couldn't read " ++ show str ++ " as [String]") s -> toArgs' s where toArgs' :: String -> Either String [String] -- Remove outer quotes: -- > toArgs' "\"foo\" \"bar baz\"" -- Right ["foo", "bar baz"] -- -- Keep inner quotes: -- > toArgs' "-DFOO=\"bar baz\"" -- Right ["-DFOO=\"bar baz\""] toArgs' s = case dropWhile isSpace s of [] -> Right [] ('"' : _) -> do -- readAsString removes outer quotes (arg, rest) <- readAsString s (arg:) `fmap` toArgs' rest s' -> case break (isSpace <||> (== '"')) s' of (argPart1, s''@('"':_)) -> do (argPart2, rest) <- readAsString s'' -- show argPart2 to keep inner quotes ((argPart1 ++ show argPart2):) `fmap` toArgs' rest (arg, s'') -> (arg:) `fmap` toArgs' s'' readAsString :: String -> Either String (String, String) readAsString s = case reads s of [(arg, rest)] -- rest must either be [] or start with a space | all isSpace (take 1 rest) -> Right (arg, rest) _ -> Left ("Couldn't read " ++ show s ++ " as String") ----------------------------------------------------------------------------- -- Integers -- | Determine the $\log_2$ of exact powers of 2 exactLog2 :: Integer -> Maybe Integer exactLog2 x | x <= 0 = Nothing | x > fromIntegral (maxBound :: Int32) = Nothing | x' .&. (-x') /= x' = Nothing | otherwise = Just (fromIntegral c) where x' = fromIntegral x :: Int32 c = countTrailingZeros x' {- -- ----------------------------------------------------------------------------- -- Floats -} readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" readRational__ r = do (n,d,s) <- readFix r (k,t) <- readExp s return ((n%1)*10^^(k-d), t) where readFix r = do (ds,s) <- lexDecDigits r (ds',t) <- lexDotDigits s return (read (ds++ds'), length ds', t) readExp (e:s) | e `elem` "eE" = readExp' s readExp s = return (0,s) readExp' ('+':s) = readDec s readExp' ('-':s) = do (k,t) <- readDec s return (-k,t) readExp' s = readDec s readDec s = do (ds,r) <- nonnull isDigit s return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ], r) lexDecDigits = nonnull isDigit lexDotDigits ('.':s) = return (span' isDigit s) lexDotDigits s = return ("",s) nonnull p s = do (cs@(_:_),t) <- return (span' p s) return (cs,t) span' _ xs@[] = (xs, xs) span' p xs@(x:xs') | x == '_' = span' p xs' -- skip "_" (#14473) | p x = let (ys,zs) = span' p xs' in (x:ys,zs) | otherwise = ([],xs) readRational :: String -> Rational -- NB: *does* handle a leading "-" readRational top_s = case top_s of '-' : xs -> - (read_me xs) xs -> read_me xs where read_me s = case (do { (x,"") <- readRational__ s ; return x }) of [x] -> x [] -> error ("readRational: no parse:" ++ top_s) _ -> error ("readRational: ambiguous parse:" ++ top_s) readHexRational :: String -> Rational readHexRational str = case str of '-' : xs -> - (readMe xs) xs -> readMe xs where readMe as = case readHexRational__ as of Just n -> n _ -> error ("readHexRational: no parse:" ++ str) readHexRational__ :: String -> Maybe Rational readHexRational__ ('0' : x : rest) | x == 'X' || x == 'x' = do let (front,rest2) = span' isHexDigit rest guard (not (null front)) let frontNum = steps 16 0 front case rest2 of '.' : rest3 -> do let (back,rest4) = span' isHexDigit rest3 guard (not (null back)) let backNum = steps 16 frontNum back exp1 = -4 * length back case rest4 of p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps) _ -> return (mk backNum exp1) p : ps | isExp p -> fmap (mk frontNum) (getExp ps) _ -> Nothing where isExp p = p == 'p' || p == 'P' getExp ('+' : ds) = dec ds getExp ('-' : ds) = fmap negate (dec ds) getExp ds = dec ds mk :: Integer -> Int -> Rational mk n e = fromInteger n * 2^^e dec cs = case span' isDigit cs of (ds,"") | not (null ds) -> Just (steps 10 0 ds) _ -> Nothing steps base n ds = foldl' (step base) n ds step base n d = base * n + fromIntegral (digitToInt d) span' _ xs@[] = (xs, xs) span' p xs@(x:xs') | x == '_' = span' p xs' -- skip "_" (#14473) | p x = let (ys,zs) = span' p xs' in (x:ys,zs) | otherwise = ([],xs) readHexRational__ _ = Nothing ----------------------------------------------------------------------------- -- Verify that the 'dirname' portion of a FilePath exists. -- doesDirNameExist :: FilePath -> IO Bool doesDirNameExist fpath = doesDirectoryExist (takeDirectory fpath) ----------------------------------------------------------------------------- -- Backwards compatibility definition of getModificationTime getModificationUTCTime :: FilePath -> IO UTCTime getModificationUTCTime = getModificationTime -- -------------------------------------------------------------- -- check existence & modification time at the same time modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) modificationTimeIfExists f = do (do t <- getModificationUTCTime f; return (Just t)) `catchIO` \e -> if isDoesNotExistError e then return Nothing else ioError e -- -------------------------------------------------------------- -- atomic file writing by writing to a temporary file first (see #14533) -- -- This should be used in all cases where GHC writes files to disk -- and uses their modification time to skip work later, -- as otherwise a partially written file (e.g. due to crash or Ctrl+C) -- also results in a skip. withAtomicRename :: (MonadIO m) => FilePath -> (FilePath -> m a) -> m a withAtomicRename targetFile f | enableAtomicRename = do -- The temp file must be on the same file system (mount) as the target file -- to result in an atomic move on most platforms. -- The standard way to ensure that is to place it into the same directory. -- This can still be fooled when somebody mounts a different file system -- at just the right time, but that is not a case we aim to cover here. let temp = targetFile <.> "tmp" res <- f temp liftIO $ renameFile temp targetFile return res | otherwise = f targetFile where -- As described in #16450, enabling this causes spurious build failures due -- to apparently missing files. enableAtomicRename :: Bool #if defined(mingw32_BUILD_OS) enableAtomicRename = False #else enableAtomicRename = True #endif -- -------------------------------------------------------------- -- split a string at the last character where 'pred' is True, -- returning a pair of strings. The first component holds the string -- up (but not including) the last character for which 'pred' returned -- True, the second whatever comes after (but also not including the -- last character). -- -- If 'pred' returns False for all characters in the string, the original -- string is returned in the first component (and the second one is just -- empty). splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) splitLongestPrefix str pred | null r_pre = (str, []) | otherwise = (reverse (tail r_pre), reverse r_suf) -- 'tail' drops the char satisfying 'pred' where (r_suf, r_pre) = break pred (reverse str) escapeSpaces :: String -> String escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) "" type Suffix = String -------------------------------------------------------------- -- * Search path -------------------------------------------------------------- data Direction = Forwards | Backwards reslash :: Direction -> FilePath -> FilePath reslash d = f where f ('/' : xs) = slash : f xs f ('\\' : xs) = slash : f xs f (x : xs) = x : f xs f "" = "" slash = case d of Forwards -> '/' Backwards -> '\\' makeRelativeTo :: FilePath -> FilePath -> FilePath this `makeRelativeTo` that = directory thisFilename where (thisDirectory, thisFilename) = splitFileName this thatDirectory = dropFileName that directory = joinPath $ f (splitPath thisDirectory) (splitPath thatDirectory) f (x : xs) (y : ys) | x == y = f xs ys f xs ys = replicate (length ys) ".." ++ xs {- ************************************************************************ * * \subsection[Utils-Data]{Utils for defining Data instances} * * ************************************************************************ These functions helps us to define Data instances for abstract types. -} abstractConstr :: String -> Constr abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix abstractDataType :: String -> DataType abstractDataType n = mkDataType n [abstractConstr n] {- ************************************************************************ * * \subsection[Utils-C]{Utils for printing C code} * * ************************************************************************ -} charToC :: Word8 -> String charToC w = case chr (fromIntegral w) of '\"' -> "\\\"" '\'' -> "\\\'" '\\' -> "\\\\" c | c >= ' ' && c <= '~' -> [c] | otherwise -> ['\\', chr (ord '0' + ord c `div` 64), chr (ord '0' + ord c `div` 8 `mod` 8), chr (ord '0' + ord c `mod` 8)] {- ************************************************************************ * * \subsection[Utils-Hashing]{Utils for hashing} * * ************************************************************************ -} -- | A sample hash function for Strings. We keep multiplying by the -- golden ratio and adding. The implementation is: -- -- > hashString = foldl' f golden -- > where f m c = fromIntegral (ord c) * magic + hashInt32 m -- > magic = 0xdeadbeef -- -- Where hashInt32 works just as hashInt shown above. -- -- Knuth argues that repeated multiplication by the golden ratio -- will minimize gaps in the hash space, and thus it's a good choice -- for combining together multiple keys to form one. -- -- Here we know that individual characters c are often small, and this -- produces frequent collisions if we use ord c alone. A -- particular problem are the shorter low ASCII and ISO-8859-1 -- character strings. We pre-multiply by a magic twiddle factor to -- obtain a good distribution. In fact, given the following test: -- -- > testp :: Int32 -> Int -- > testp k = (n - ) . length . group . sort . map hs . take n $ ls -- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']] -- > hs = foldl' f golden -- > f m c = fromIntegral (ord c) * k + hashInt32 m -- > n = 100000 -- -- We discover that testp magic = 0. hashString :: String -> Int32 hashString = foldl' f golden where f m c = fromIntegral (ord c) * magic + hashInt32 m magic = fromIntegral (0xdeadbeef :: Word32) golden :: Int32 golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 -- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32 -- but that has bad mulHi properties (even adding 2^32 to get its inverse) -- Whereas the above works well and contains no hash duplications for -- [-32767..65536] -- | A sample (and useful) hash function for Int32, -- implemented by extracting the uppermost 32 bits of the 64-bit -- result of multiplying by a 33-bit constant. The constant is from -- Knuth, derived from the golden ratio: -- -- > golden = round ((sqrt 5 - 1) * 2^32) -- -- We get good key uniqueness on small inputs -- (a problem with previous versions): -- (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768 -- hashInt32 :: Int32 -> Int32 hashInt32 x = mulHi x golden + x -- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply mulHi :: Int32 -> Int32 -> Int32 mulHi a b = fromIntegral (r `shiftR` 32) where r :: Int64 r = fromIntegral a * fromIntegral b -- | A call stack constraint, but only when 'isDebugOn'. #if defined(DEBUG) type HasDebugCallStack = HasCallStack #else type HasDebugCallStack = (() :: Constraint) #endif data OverridingBool = Auto | Always | Never deriving Show overrideWith :: Bool -> OverridingBool -> Bool overrideWith b Auto = b overrideWith _ Always = True overrideWith _ Never = False ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/Var.hs0000644000000000000000000006470413713635744020525 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 \section{@Vars@: Variables} -} {-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-} -- | -- #name_types# -- GHC uses several kinds of name internally: -- -- * 'OccName.OccName': see "OccName#name_types" -- -- * 'RdrName.RdrName': see "RdrName#name_types" -- -- * 'Name.Name': see "Name#name_types" -- -- * 'Id.Id': see "Id#name_types" -- -- * 'Var.Var' is a synonym for the 'Id.Id' type but it may additionally -- potentially contain type variables, which have a 'TyCoRep.Kind' -- rather than a 'TyCoRep.Type' and only contain some extra -- details during typechecking. -- -- These 'Var.Var' names may either be global or local, see "Var#globalvslocal" -- -- #globalvslocal# -- Global 'Id's and 'Var's are those that are imported or correspond -- to a data constructor, primitive operation, or record selectors. -- Local 'Id's and 'Var's are those bound within an expression -- (e.g. by a lambda) or at the top level of the module being compiled. module Var ( -- * The main data type and synonyms Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId, TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar, -- * In and Out variants InVar, InCoVar, InId, InTyVar, OutVar, OutCoVar, OutId, OutTyVar, -- ** Taking 'Var's apart varName, varUnique, varType, -- ** Modifying 'Var's setVarName, setVarUnique, setVarType, updateVarType, updateVarTypeM, -- ** Constructing, taking apart, modifying 'Id's mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, idInfo, idDetails, lazySetIdInfo, setIdDetails, globaliseId, setIdExported, setIdNotExported, -- ** Predicates isId, isTyVar, isTcTyVar, isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar, isGlobalId, isExportedId, mustHaveLocalBinding, -- * ArgFlags ArgFlag(..), isVisibleArgFlag, isInvisibleArgFlag, sameVis, AnonArgFlag(..), ForallVisFlag(..), argToForallVisFlag, -- * TyVar's VarBndr(..), TyCoVarBinder, TyVarBinder, binderVar, binderVars, binderArgFlag, binderType, mkTyCoVarBinder, mkTyCoVarBinders, mkTyVarBinder, mkTyVarBinders, isTyVarBinder, -- ** Constructing TyVar's mkTyVar, mkTcTyVar, -- ** Taking 'TyVar's apart tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails, -- ** Modifying 'TyVar's setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind, updateTyVarKindM, nonDetCmpVar ) where #include "GhclibHsVersions.h" import GhcPrelude import {-# SOURCE #-} TyCoRep( Type, Kind ) import {-# SOURCE #-} TyCoPpr( pprKind ) import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv ) import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, isCoVarDetails, vanillaIdInfo, pprIdDetails ) import Name hiding (varName) import Unique ( Uniquable, Unique, getKey, getUnique , mkUniqueGrimily, nonDetCmpUnique ) import Util import Binary import DynFlags import Outputable import Data.Data {- ************************************************************************ * * Synonyms * * ************************************************************************ -- These synonyms are here and not in Id because otherwise we need a very -- large number of SOURCE imports of Id.hs :-( -} -- | Identifier type Id = Var -- A term-level identifier -- predicate: isId -- | Coercion Variable type CoVar = Id -- See Note [Evidence: EvIds and CoVars] -- predicate: isCoVar -- | type NcId = Id -- A term-level (value) variable that is -- /not/ an (unlifted) coercion -- predicate: isNonCoVarId -- | Type or kind Variable type TyVar = Var -- Type *or* kind variable (historical) -- | Type or Kind Variable type TKVar = Var -- Type *or* kind variable (historical) -- | Type variable that might be a metavariable type TcTyVar = Var -- | Type Variable type TypeVar = Var -- Definitely a type variable -- | Kind Variable type KindVar = Var -- Definitely a kind variable -- See Note [Kind and type variables] -- See Note [Evidence: EvIds and CoVars] -- | Evidence Identifier type EvId = Id -- Term-level evidence: DictId, IpId, or EqVar -- | Evidence Variable type EvVar = EvId -- ...historical name for EvId -- | Dictionary Function Identifier type DFunId = Id -- A dictionary function -- | Dictionary Identifier type DictId = EvId -- A dictionary variable -- | Implicit parameter Identifier type IpId = EvId -- A term-level implicit parameter -- | Equality Variable type EqVar = EvId -- Boxed equality evidence type JoinId = Id -- A join variable -- | Type or Coercion Variable type TyCoVar = Id -- Type, *or* coercion variable -- predicate: isTyCoVar {- Many passes apply a substitution, and it's very handy to have type synonyms to remind us whether or not the substitution has been applied -} type InVar = Var type InTyVar = TyVar type InCoVar = CoVar type InId = Id type OutVar = Var type OutTyVar = TyVar type OutCoVar = CoVar type OutId = Id {- Note [Evidence: EvIds and CoVars] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * An EvId (evidence Id) is a term-level evidence variable (dictionary, implicit parameter, or equality). Could be boxed or unboxed. * DictId, IpId, and EqVar are synonyms when we know what kind of evidence we are talking about. For example, an EqVar has type (t1 ~ t2). * A CoVar is always an un-lifted coercion, of type (t1 ~# t2) or (t1 ~R# t2) Note [Kind and type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before kind polymorphism, TyVar were used to mean type variables. Now they are used to mean kind *or* type variables. KindVar is used when we know for sure that it is a kind variable. In future, we might want to go over the whole compiler code to use: - TKVar to mean kind or type variables - TypeVar to mean type variables only - KindVar to mean kind variables ************************************************************************ * * \subsection{The main data type declarations} * * ************************************************************************ Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a @Type@, and an @IdInfo@ (non-essential info about it, e.g., strictness). The essential info about different kinds of @Vars@ is in its @VarDetails@. -} -- | Variable -- -- Essentially a typed 'Name', that may also contain some additional information -- about the 'Var' and its use sites. data Var = TyVar { -- Type and kind variables -- see Note [Kind and type variables] varName :: !Name, realUnique :: {-# UNPACK #-} !Int, -- ^ Key for fast comparison -- Identical to the Unique in the name, -- cached here for speed varType :: Kind -- ^ The type or kind of the 'Var' in question } | TcTyVar { -- Used only during type inference -- Used for kind variables during -- inference, as well varName :: !Name, realUnique :: {-# UNPACK #-} !Int, varType :: Kind, tc_tv_details :: TcTyVarDetails } | Id { varName :: !Name, realUnique :: {-# UNPACK #-} !Int, varType :: Type, idScope :: IdScope, id_details :: IdDetails, -- Stable, doesn't change id_info :: IdInfo } -- Unstable, updated by simplifier -- | Identifier Scope data IdScope -- See Note [GlobalId/LocalId] = GlobalId | LocalId ExportFlag data ExportFlag -- See Note [ExportFlag on binders] = NotExported -- ^ Not exported: may be discarded as dead code. | Exported -- ^ Exported: kept alive {- Note [ExportFlag on binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An ExportFlag of "Exported" on a top-level binder says "keep this binding alive; do not drop it as dead code". This transitively keeps alive all the other top-level bindings that this binding refers to. This property is persisted all the way down the pipeline, so that the binding will be compiled all the way to object code, and its symbols will appear in the linker symbol table. However, note that this use of "exported" is quite different to the export list on a Haskell module. Setting the ExportFlag on an Id does /not/ mean that if you import the module (in Haskell source code) you will see this Id. Of course, things that appear in the export list of the source Haskell module do indeed have their ExportFlag set. But many other things, such as dictionary functions, are kept alive by having their ExportFlag set, even though they are not exported in the source-code sense. We should probably use a different term for ExportFlag, like KeepAlive. Note [GlobalId/LocalId] ~~~~~~~~~~~~~~~~~~~~~~~ A GlobalId is * always a constant (top-level) * imported, or data constructor, or primop, or record selector * has a Unique that is globally unique across the whole GHC invocation (a single invocation may compile multiple modules) * never treated as a candidate by the free-variable finder; it's a constant! A LocalId is * bound within an expression (lambda, case, local let(rec)) * or defined at top level in the module being compiled * always treated as a candidate by the free-variable finder After CoreTidy, top-level LocalIds are turned into GlobalIds -} instance Outputable Var where ppr var = sdocWithDynFlags $ \dflags -> getPprStyle $ \ppr_style -> if | debugStyle ppr_style && (not (gopt Opt_SuppressVarKinds dflags)) -> parens (ppr (varName var) <+> ppr_debug var ppr_style <+> dcolon <+> pprKind (tyVarKind var)) | otherwise -> ppr (varName var) <> ppr_debug var ppr_style ppr_debug :: Var -> PprStyle -> SDoc ppr_debug (TyVar {}) sty | debugStyle sty = brackets (text "tv") ppr_debug (TcTyVar {tc_tv_details = d}) sty | dumpStyle sty || debugStyle sty = brackets (pprTcTyVarDetails d) ppr_debug (Id { idScope = s, id_details = d }) sty | debugStyle sty = brackets (ppr_id_scope s <> pprIdDetails d) ppr_debug _ _ = empty ppr_id_scope :: IdScope -> SDoc ppr_id_scope GlobalId = text "gid" ppr_id_scope (LocalId Exported) = text "lidx" ppr_id_scope (LocalId NotExported) = text "lid" instance NamedThing Var where getName = varName instance Uniquable Var where getUnique = varUnique instance Eq Var where a == b = realUnique a == realUnique b instance Ord Var where a <= b = realUnique a <= realUnique b a < b = realUnique a < realUnique b a >= b = realUnique a >= realUnique b a > b = realUnique a > realUnique b a `compare` b = a `nonDetCmpVar` b -- | Compare Vars by their Uniques. -- This is what Ord Var does, provided here to make it explicit at the -- call-site that it can introduce non-determinism. -- See Note [Unique Determinism] nonDetCmpVar :: Var -> Var -> Ordering nonDetCmpVar a b = varUnique a `nonDetCmpUnique` varUnique b instance Data Var where -- don't traverse? toConstr _ = abstractConstr "Var" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Var" instance HasOccName Var where occName = nameOccName . varName varUnique :: Var -> Unique varUnique var = mkUniqueGrimily (realUnique var) setVarUnique :: Var -> Unique -> Var setVarUnique var uniq = var { realUnique = getKey uniq, varName = setNameUnique (varName var) uniq } setVarName :: Var -> Name -> Var setVarName var new_name = var { realUnique = getKey (getUnique new_name), varName = new_name } setVarType :: Id -> Type -> Id setVarType id ty = id { varType = ty } updateVarType :: (Type -> Type) -> Id -> Id updateVarType f id = id { varType = f (varType id) } updateVarTypeM :: Monad m => (Type -> m Type) -> Id -> m Id updateVarTypeM f id = do { ty' <- f (varType id) ; return (id { varType = ty' }) } {- ********************************************************************* * * * ArgFlag * * ********************************************************************* -} -- | Argument Flag -- -- Is something required to appear in source Haskell ('Required'), -- permitted by request ('Specified') (visible type application), or -- prohibited entirely from appearing in source Haskell ('Inferred')? -- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep data ArgFlag = Inferred | Specified | Required deriving (Eq, Ord, Data) -- (<) on ArgFlag means "is less visible than" -- | Does this 'ArgFlag' classify an argument that is written in Haskell? isVisibleArgFlag :: ArgFlag -> Bool isVisibleArgFlag Required = True isVisibleArgFlag _ = False -- | Does this 'ArgFlag' classify an argument that is not written in Haskell? isInvisibleArgFlag :: ArgFlag -> Bool isInvisibleArgFlag = not . isVisibleArgFlag -- | Do these denote the same level of visibility? 'Required' -- arguments are visible, others are not. So this function -- equates 'Specified' and 'Inferred'. Used for printing. sameVis :: ArgFlag -> ArgFlag -> Bool sameVis Required Required = True sameVis Required _ = False sameVis _ Required = False sameVis _ _ = True instance Outputable ArgFlag where ppr Required = text "[req]" ppr Specified = text "[spec]" ppr Inferred = text "[infrd]" instance Binary ArgFlag where put_ bh Required = putByte bh 0 put_ bh Specified = putByte bh 1 put_ bh Inferred = putByte bh 2 get bh = do h <- getByte bh case h of 0 -> return Required 1 -> return Specified _ -> return Inferred -- | The non-dependent version of 'ArgFlag'. -- Appears here partly so that it's together with its friend ArgFlag, -- but also because it is used in IfaceType, rather early in the -- compilation chain -- See Note [AnonArgFlag vs. ForallVisFlag] data AnonArgFlag = VisArg -- ^ Used for @(->)@: an ordinary non-dependent arrow. -- The argument is visible in source code. | InvisArg -- ^ Used for @(=>)@: a non-dependent predicate arrow. -- The argument is invisible in source code. deriving (Eq, Ord, Data) instance Outputable AnonArgFlag where ppr VisArg = text "[vis]" ppr InvisArg = text "[invis]" instance Binary AnonArgFlag where put_ bh VisArg = putByte bh 0 put_ bh InvisArg = putByte bh 1 get bh = do h <- getByte bh case h of 0 -> return VisArg _ -> return InvisArg -- | Is a @forall@ invisible (e.g., @forall a b. {...}@, with a dot) or visible -- (e.g., @forall a b -> {...}@, with an arrow)? -- See Note [AnonArgFlag vs. ForallVisFlag] data ForallVisFlag = ForallVis -- ^ A visible @forall@ (with an arrow) | ForallInvis -- ^ An invisible @forall@ (with a dot) deriving (Eq, Ord, Data) instance Outputable ForallVisFlag where ppr f = text $ case f of ForallVis -> "ForallVis" ForallInvis -> "ForallInvis" -- | Convert an 'ArgFlag' to its corresponding 'ForallVisFlag'. argToForallVisFlag :: ArgFlag -> ForallVisFlag argToForallVisFlag Required = ForallVis argToForallVisFlag Specified = ForallInvis argToForallVisFlag Inferred = ForallInvis {- Note [AnonArgFlag vs. ForallVisFlag] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The AnonArgFlag and ForallVisFlag data types are quite similar at a first glance: data AnonArgFlag = VisArg | InvisArg data ForallVisFlag = ForallVis | ForallInvis Both data types keep track of visibility of some sort. AnonArgFlag tracks whether a FunTy has a visible argument (->) or an invisible predicate argument (=>). ForallVisFlag tracks whether a `forall` quantifier is visible (forall a -> {...}) or invisible (forall a. {...}). Given their similarities, it's tempting to want to combine these two data types into one, but they actually represent distinct concepts. AnonArgFlag reflects a property of *Core* types, whereas ForallVisFlag reflects a property of the GHC AST. In other words, AnonArgFlag is all about internals, whereas ForallVisFlag is all about surface syntax. Therefore, they are kept as separate data types. -} {- ********************************************************************* * * * VarBndr, TyCoVarBinder * * ********************************************************************* -} -- Variable Binder -- -- VarBndr is polymorphic in both var and visibility fields. -- Currently there are six different uses of 'VarBndr': -- * Var.TyVarBinder = VarBndr TyVar ArgFlag -- * Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag -- * TyCon.TyConBinder = VarBndr TyVar TyConBndrVis -- * TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis -- * IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ArgFlag -- * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis data VarBndr var argf = Bndr var argf deriving( Data ) -- | Variable Binder -- -- A 'TyCoVarBinder' is the binder of a ForAllTy -- It's convenient to define this synonym here rather its natural -- home in TyCoRep, because it's used in DataCon.hs-boot -- -- A 'TyVarBinder' is a binder with only TyVar type TyCoVarBinder = VarBndr TyCoVar ArgFlag type TyVarBinder = VarBndr TyVar ArgFlag binderVar :: VarBndr tv argf -> tv binderVar (Bndr v _) = v binderVars :: [VarBndr tv argf] -> [tv] binderVars tvbs = map binderVar tvbs binderArgFlag :: VarBndr tv argf -> argf binderArgFlag (Bndr _ argf) = argf binderType :: VarBndr TyCoVar argf -> Type binderType (Bndr tv _) = varType tv -- | Make a named binder mkTyCoVarBinder :: ArgFlag -> TyCoVar -> TyCoVarBinder mkTyCoVarBinder vis var = Bndr var vis -- | Make a named binder -- 'var' should be a type variable mkTyVarBinder :: ArgFlag -> TyVar -> TyVarBinder mkTyVarBinder vis var = ASSERT( isTyVar var ) Bndr var vis -- | Make many named binders mkTyCoVarBinders :: ArgFlag -> [TyCoVar] -> [TyCoVarBinder] mkTyCoVarBinders vis = map (mkTyCoVarBinder vis) -- | Make many named binders -- Input vars should be type variables mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder] mkTyVarBinders vis = map (mkTyVarBinder vis) isTyVarBinder :: TyCoVarBinder -> Bool isTyVarBinder (Bndr v _) = isTyVar v instance Outputable tv => Outputable (VarBndr tv ArgFlag) where ppr (Bndr v Required) = ppr v ppr (Bndr v Specified) = char '@' <> ppr v ppr (Bndr v Inferred) = braces (ppr v) instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis } get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) } instance NamedThing tv => NamedThing (VarBndr tv flag) where getName (Bndr tv _) = getName tv {- ************************************************************************ * * * Type and kind variables * * * ************************************************************************ -} tyVarName :: TyVar -> Name tyVarName = varName tyVarKind :: TyVar -> Kind tyVarKind = varType setTyVarUnique :: TyVar -> Unique -> TyVar setTyVarUnique = setVarUnique setTyVarName :: TyVar -> Name -> TyVar setTyVarName = setVarName setTyVarKind :: TyVar -> Kind -> TyVar setTyVarKind tv k = tv {varType = k} updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar updateTyVarKind update tv = tv {varType = update (tyVarKind tv)} updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar updateTyVarKindM update tv = do { k' <- update (tyVarKind tv) ; return $ tv {varType = k'} } mkTyVar :: Name -> Kind -> TyVar mkTyVar name kind = TyVar { varName = name , realUnique = getKey (nameUnique name) , varType = kind } mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar mkTcTyVar name kind details = -- NB: 'kind' may be a coercion kind; cf, 'TcMType.newMetaCoVar' TcTyVar { varName = name, realUnique = getKey (nameUnique name), varType = kind, tc_tv_details = details } tcTyVarDetails :: TyVar -> TcTyVarDetails -- See Note [TcTyVars in the typechecker] in TcType tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details tcTyVarDetails (TyVar {}) = vanillaSkolemTv tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (tyVarKind var)) setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar setTcTyVarDetails tv details = tv { tc_tv_details = details } {- %************************************************************************ %* * \subsection{Ids} * * ************************************************************************ -} idInfo :: HasDebugCallStack => Id -> IdInfo idInfo (Id { id_info = info }) = info idInfo other = pprPanic "idInfo" (ppr other) idDetails :: Id -> IdDetails idDetails (Id { id_details = details }) = details idDetails other = pprPanic "idDetails" (ppr other) -- The next three have a 'Var' suffix even though they always build -- Ids, because Id.hs uses 'mkGlobalId' etc with different types mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id mkGlobalVar details name ty info = mk_id name ty GlobalId details info mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id mkLocalVar details name ty info = mk_id name ty (LocalId NotExported) details info mkCoVar :: Name -> Type -> CoVar -- Coercion variables have no IdInfo mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo -- | Exported 'Var's will not be removed as dead code mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id mkExportedLocalVar details name ty info = mk_id name ty (LocalId Exported) details info mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id mk_id name ty scope details info = Id { varName = name, realUnique = getKey (nameUnique name), varType = ty, idScope = scope, id_details = details, id_info = info } ------------------- lazySetIdInfo :: Id -> IdInfo -> Var lazySetIdInfo id info = id { id_info = info } setIdDetails :: Id -> IdDetails -> Id setIdDetails id details = id { id_details = details } globaliseId :: Id -> Id -- ^ If it's a local, make it global globaliseId id = id { idScope = GlobalId } setIdExported :: Id -> Id -- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors -- and class operations, which are born as global 'Id's and automatically exported setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported } setIdExported id@(Id { idScope = GlobalId }) = id setIdExported tv = pprPanic "setIdExported" (ppr tv) setIdNotExported :: Id -> Id -- ^ We can only do this to LocalIds setIdNotExported id = ASSERT( isLocalId id ) id { idScope = LocalId NotExported } {- ************************************************************************ * * \subsection{Predicates over variables} * * ************************************************************************ -} -- | Is this a type-level (i.e., computationally irrelevant, thus erasable) -- variable? Satisfies @isTyVar = not . isId@. isTyVar :: Var -> Bool -- True of both TyVar and TcTyVar isTyVar (TyVar {}) = True isTyVar (TcTyVar {}) = True isTyVar _ = False isTcTyVar :: Var -> Bool -- True of TcTyVar only isTcTyVar (TcTyVar {}) = True isTcTyVar _ = False isTyCoVar :: Var -> Bool isTyCoVar v = isTyVar v || isCoVar v -- | Is this a value-level (i.e., computationally relevant) 'Id'entifier? -- Satisfies @isId = not . isTyVar@. isId :: Var -> Bool isId (Id {}) = True isId _ = False -- | Is this a coercion variable? -- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. isCoVar :: Var -> Bool isCoVar (Id { id_details = details }) = isCoVarDetails details isCoVar _ = False -- | Is this a term variable ('Id') that is /not/ a coercion variable? -- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@. isNonCoVarId :: Var -> Bool isNonCoVarId (Id { id_details = details }) = not (isCoVarDetails details) isNonCoVarId _ = False isLocalId :: Var -> Bool isLocalId (Id { idScope = LocalId _ }) = True isLocalId _ = False -- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's -- These are the variables that we need to pay attention to when finding free -- variables, or doing dependency analysis. isLocalVar :: Var -> Bool isLocalVar v = not (isGlobalId v) isGlobalId :: Var -> Bool isGlobalId (Id { idScope = GlobalId }) = True isGlobalId _ = False -- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's -- that must have a binding in this module. The converse -- is not quite right: there are some global 'Id's that must have -- bindings, such as record selectors. But that doesn't matter, -- because it's only used for assertions mustHaveLocalBinding :: Var -> Bool mustHaveLocalBinding var = isLocalVar var -- | 'isExportedIdVar' means \"don't throw this away\" isExportedId :: Var -> Bool isExportedId (Id { idScope = GlobalId }) = True isExportedId (Id { idScope = LocalId Exported}) = True isExportedId _ = False ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/VarEnv.hs0000644000000000000000000005310613713635744021170 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} module VarEnv ( -- * Var, Id and TyVar environments (maps) VarEnv, IdEnv, TyVarEnv, CoVarEnv, TyCoVarEnv, -- ** Manipulating these environments emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly, elemVarEnv, disjointVarEnv, extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly, extendVarEnvList, plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, plusVarEnvList, alterVarEnv, delVarEnvList, delVarEnv, delVarEnv_Directly, minusVarEnv, intersectsVarEnv, lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, mapVarEnv, zipVarEnv, modifyVarEnv, modifyVarEnv_Directly, isEmptyVarEnv, elemVarEnvByKey, lookupVarEnv_Directly, filterVarEnv, filterVarEnv_Directly, restrictVarEnv, partitionVarEnv, -- * Deterministic Var environments (maps) DVarEnv, DIdEnv, DTyVarEnv, -- ** Manipulating these environments emptyDVarEnv, mkDVarEnv, dVarEnvElts, extendDVarEnv, extendDVarEnv_C, extendDVarEnvList, lookupDVarEnv, elemDVarEnv, isEmptyDVarEnv, foldDVarEnv, mapDVarEnv, filterDVarEnv, modifyDVarEnv, alterDVarEnv, plusDVarEnv, plusDVarEnv_C, unitDVarEnv, delDVarEnv, delDVarEnvList, minusDVarEnv, partitionDVarEnv, anyDVarEnv, -- * The InScopeSet type InScopeSet, -- ** Operations on InScopeSets emptyInScopeSet, mkInScopeSet, delInScopeSet, extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, getInScopeVars, lookupInScope, lookupInScope_Directly, unionInScope, elemInScopeSet, uniqAway, varSetInScope, -- * The RnEnv2 type RnEnv2, -- ** Operations on RnEnv2s mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var, rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap, delBndrL, delBndrR, delBndrsL, delBndrsR, addRnInScopeSet, rnEtaL, rnEtaR, rnInScope, rnInScopeSet, lookupRnInScope, rnEnvL, rnEnvR, -- * TidyEnv and its operation TidyEnv, emptyTidyEnv, mkEmptyTidyEnv ) where import GhcPrelude import OccName import Var import VarSet import UniqSet import UniqFM import UniqDFM import Unique import Util import Maybes import Outputable {- ************************************************************************ * * In-scope sets * * ************************************************************************ -} -- | A set of variables that are in scope at some point -- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides -- the motivation for this abstraction. data InScopeSet = InScope VarSet {-# UNPACK #-} !Int -- Note [Lookups in in-scope set] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- We store a VarSet here, but we use this for lookups rather than just -- membership tests. Typically the InScopeSet contains the canonical -- version of the variable (e.g. with an informative unfolding), so this -- lookup is useful (see, for instance, Note [In-scope set as a -- substitution]). -- -- The Int is a kind of hash-value used by uniqAway -- For example, it might be the size of the set -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway instance Outputable InScopeSet where ppr (InScope s _) = text "InScope" <+> braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s))) -- It's OK to use nonDetEltsUniqSet here because it's -- only for pretty printing -- In-scope sets get big, and with -dppr-debug -- the output is overwhelming emptyInScopeSet :: InScopeSet emptyInScopeSet = InScope emptyVarSet 1 getInScopeVars :: InScopeSet -> VarSet getInScopeVars (InScope vs _) = vs mkInScopeSet :: VarSet -> InScopeSet mkInScopeSet in_scope = InScope in_scope 1 extendInScopeSet :: InScopeSet -> Var -> InScopeSet extendInScopeSet (InScope in_scope n) v = InScope (extendVarSet in_scope v) (n + 1) extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet extendInScopeSetList (InScope in_scope n) vs = InScope (foldl' (\s v -> extendVarSet s v) in_scope vs) (n + length vs) extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet extendInScopeSetSet (InScope in_scope n) vs = InScope (in_scope `unionVarSet` vs) (n + sizeUniqSet vs) delInScopeSet :: InScopeSet -> Var -> InScopeSet delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarSet` v) n elemInScopeSet :: Var -> InScopeSet -> Bool elemInScopeSet v (InScope in_scope _) = v `elemVarSet` in_scope -- | Look up a variable the 'InScopeSet'. This lets you map from -- the variable's identity (unique) to its full value. lookupInScope :: InScopeSet -> Var -> Maybe Var lookupInScope (InScope in_scope _) v = lookupVarSet in_scope v lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var lookupInScope_Directly (InScope in_scope _) uniq = lookupVarSet_Directly in_scope uniq unionInScope :: InScopeSet -> InScopeSet -> InScopeSet unionInScope (InScope s1 _) (InScope s2 n2) = InScope (s1 `unionVarSet` s2) n2 varSetInScope :: VarSet -> InScopeSet -> Bool varSetInScope vars (InScope s1 _) = vars `subVarSet` s1 -- | @uniqAway in_scope v@ finds a unique that is not used in the -- in-scope set, and gives that to v. uniqAway :: InScopeSet -> Var -> Var -- It starts with v's current unique, of course, in the hope that it won't -- have to change, and thereafter uses a combination of that and the hash-code -- found in the in-scope set uniqAway in_scope var | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one | otherwise = var -- Nothing to do uniqAway' :: InScopeSet -> Var -> Var -- This one *always* makes up a new variable uniqAway' (InScope set n) var = try 1 where orig_unique = getUnique var try k | debugIsOn && (k > 1000) = pprPanic "uniqAway loop:" msg | uniq `elemVarSetByKey` set = try (k + 1) | k > 3 = pprTraceDebug "uniqAway:" msg setVarUnique var uniq | otherwise = setVarUnique var uniq where msg = ppr k <+> text "tries" <+> ppr var <+> int n uniq = deriveUnique orig_unique (n * k) {- ************************************************************************ * * Dual renaming * * ************************************************************************ -} -- | Rename Environment 2 -- -- When we are comparing (or matching) types or terms, we are faced with -- \"going under\" corresponding binders. E.g. when comparing: -- -- > \x. e1 ~ \y. e2 -- -- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of -- things we must be careful of. In particular, @x@ might be free in @e2@, or -- y in @e1@. So the idea is that we come up with a fresh binder that is free -- in neither, and rename @x@ and @y@ respectively. That means we must maintain: -- -- 1. A renaming for the left-hand expression -- -- 2. A renaming for the right-hand expressions -- -- 3. An in-scope set -- -- Furthermore, when matching, we want to be able to have an 'occurs check', -- to prevent: -- -- > \x. f ~ \y. y -- -- matching with [@f@ -> @y@]. So for each expression we want to know that set of -- locally-bound variables. That is precisely the domain of the mappings 1. -- and 2., but we must ensure that we always extend the mappings as we go in. -- -- All of this information is bundled up in the 'RnEnv2' data RnEnv2 = RV2 { envL :: VarEnv Var -- Renaming for Left term , envR :: VarEnv Var -- Renaming for Right term , in_scope :: InScopeSet } -- In scope in left or right terms -- The renamings envL and envR are *guaranteed* to contain a binding -- for every variable bound as we go into the term, even if it is not -- renamed. That way we can ask what variables are locally bound -- (inRnEnvL, inRnEnvR) mkRnEnv2 :: InScopeSet -> RnEnv2 mkRnEnv2 vars = RV2 { envL = emptyVarEnv , envR = emptyVarEnv , in_scope = vars } addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2 addRnInScopeSet env vs | isEmptyVarSet vs = env | otherwise = env { in_scope = extendInScopeSetSet (in_scope env) vs } rnInScope :: Var -> RnEnv2 -> Bool rnInScope x env = x `elemInScopeSet` in_scope env rnInScopeSet :: RnEnv2 -> InScopeSet rnInScopeSet = in_scope -- | Retrieve the left mapping rnEnvL :: RnEnv2 -> VarEnv Var rnEnvL = envL -- | Retrieve the right mapping rnEnvR :: RnEnv2 -> VarEnv Var rnEnvR = envR rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 -- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 -- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term, -- and binder @bR@ in the Right term. -- It finds a new binder, @new_b@, -- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@ rnBndr2 env bL bR = fst $ rnBndr2_var env bL bR rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var) -- ^ Similar to 'rnBndr2' but returns the new variable as well as the -- new environment rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR = (RV2 { envL = extendVarEnv envL bL new_b -- See Note , envR = extendVarEnv envR bR new_b -- [Rebinding] , in_scope = extendInScopeSet in_scope new_b }, new_b) where -- Find a new binder not in scope in either term new_b | not (bL `elemInScopeSet` in_scope) = bL | not (bR `elemInScopeSet` in_scope) = bR | otherwise = uniqAway' in_scope bL -- Note [Rebinding] -- If the new var is the same as the old one, note that -- the extendVarEnv *deletes* any current renaming -- E.g. (\x. \x. ...) ~ (\y. \z. ...) -- -- Inside \x \y { [x->y], [y->y], {y} } -- \x \z { [x->x], [y->y, z->x], {y,x} } rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) -- ^ Similar to 'rnBndr2' but used when there's a binder on the left -- side only. rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL = (RV2 { envL = extendVarEnv envL bL new_b , envR = envR , in_scope = extendInScopeSet in_scope new_b }, new_b) where new_b = uniqAway in_scope bL rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) -- ^ Similar to 'rnBndr2' but used when there's a binder on the right -- side only. rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR = (RV2 { envR = extendVarEnv envR bR new_b , envL = envL , in_scope = extendInScopeSet in_scope new_b }, new_b) where new_b = uniqAway in_scope bR rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var) -- ^ Similar to 'rnBndrL' but used for eta expansion -- See Note [Eta expansion] rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL = (RV2 { envL = extendVarEnv envL bL new_b , envR = extendVarEnv envR new_b new_b -- Note [Eta expansion] , in_scope = extendInScopeSet in_scope new_b }, new_b) where new_b = uniqAway in_scope bL rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var) -- ^ Similar to 'rnBndr2' but used for eta expansion -- See Note [Eta expansion] rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [Eta expansion] , envR = extendVarEnv envR bR new_b , in_scope = extendInScopeSet in_scope new_b }, new_b) where new_b = uniqAway in_scope bR delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2 delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2 delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } rnOccL, rnOccR :: RnEnv2 -> Var -> Var -- ^ Look up the renaming of an occurrence in the left or right term rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var -- ^ Look up the renaming of an occurrence in the left or right term rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool -- ^ Tells whether a variable is locally bound inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env lookupRnInScope :: RnEnv2 -> Var -> Var lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 -- ^ Wipe the left or right side renaming nukeRnEnvL env = env { envL = emptyVarEnv } nukeRnEnvR env = env { envR = emptyVarEnv } rnSwap :: RnEnv2 -> RnEnv2 -- ^ swap the meaning of left and right rnSwap (RV2 { envL = envL, envR = envR, in_scope = in_scope }) = RV2 { envL = envR, envR = envL, in_scope = in_scope } {- Note [Eta expansion] ~~~~~~~~~~~~~~~~~~~~ When matching (\x.M) ~ N we rename x to x' with, where x' is not in scope in either term. Then we want to behave as if we'd seen (\x'.M) ~ (\x'.N x') Since x' isn't in scope in N, the form (\x'. N x') doesn't capture any variables in N. But we must nevertheless extend the envR with a binding [x' -> x'], to support the occurs check. For example, if we don't do this, we can get silly matches like forall a. (\y.a) ~ v succeeding with [a -> v y], which is bogus of course. ************************************************************************ * * Tidying * * ************************************************************************ -} -- | Tidy Environment -- -- When tidying up print names, we keep a mapping of in-scope occ-names -- (the 'TidyOccEnv') and a Var-to-Var of the current renamings type TidyEnv = (TidyOccEnv, VarEnv Var) emptyTidyEnv :: TidyEnv emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) mkEmptyTidyEnv :: TidyOccEnv -> TidyEnv mkEmptyTidyEnv occ_env = (occ_env, emptyVarEnv) {- ************************************************************************ * * \subsection{@VarEnv@s} * * ************************************************************************ -} -- | Variable Environment type VarEnv elt = UniqFM elt -- | Identifier Environment type IdEnv elt = VarEnv elt -- | Type Variable Environment type TyVarEnv elt = VarEnv elt -- | Type or Coercion Variable Environment type TyCoVarEnv elt = VarEnv elt -- | Coercion Variable Environment type CoVarEnv elt = VarEnv elt emptyVarEnv :: VarEnv a mkVarEnv :: [(Var, a)] -> VarEnv a mkVarEnv_Directly :: [(Unique, a)] -> VarEnv a zipVarEnv :: [Var] -> [a] -> VarEnv a unitVarEnv :: Var -> a -> VarEnv a alterVarEnv :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b extendVarEnv_Directly :: VarEnv a -> Unique -> a -> VarEnv a plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a plusVarEnvList :: [VarEnv a] -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a delVarEnv_Directly :: VarEnv a -> Unique -> VarEnv a partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a delVarEnvList :: VarEnv a -> [Var] -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a isEmptyVarEnv :: VarEnv a -> Bool lookupVarEnv :: VarEnv a -> Var -> Maybe a filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a lookupVarEnv_NF :: VarEnv a -> Var -> a lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a elemVarEnv :: Var -> VarEnv a -> Bool elemVarEnvByKey :: Unique -> VarEnv a -> Bool disjointVarEnv :: VarEnv a -> VarEnv a -> Bool elemVarEnv = elemUFM elemVarEnvByKey = elemUFM_Directly disjointVarEnv = disjointUFM alterVarEnv = alterUFM extendVarEnv = addToUFM extendVarEnv_C = addToUFM_C extendVarEnv_Acc = addToUFM_Acc extendVarEnv_Directly = addToUFM_Directly extendVarEnvList = addListToUFM plusVarEnv_C = plusUFM_C plusVarEnv_CD = plusUFM_CD plusMaybeVarEnv_C = plusMaybeUFM_C delVarEnvList = delListFromUFM delVarEnv = delFromUFM minusVarEnv = minusUFM intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2)) plusVarEnv = plusUFM plusVarEnvList = plusUFMList lookupVarEnv = lookupUFM filterVarEnv = filterUFM lookupWithDefaultVarEnv = lookupWithDefaultUFM mapVarEnv = mapUFM mkVarEnv = listToUFM mkVarEnv_Directly= listToUFM_Directly emptyVarEnv = emptyUFM unitVarEnv = unitUFM isEmptyVarEnv = isNullUFM lookupVarEnv_Directly = lookupUFM_Directly filterVarEnv_Directly = filterUFM_Directly delVarEnv_Directly = delFromUFM_Directly partitionVarEnv = partitionUFM restrictVarEnv env vs = filterVarEnv_Directly keep env where keep u _ = u `elemVarSetByKey` vs zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) lookupVarEnv_NF env id = case lookupVarEnv env id of Just xx -> xx Nothing -> panic "lookupVarEnv_NF: Nothing" {- @modifyVarEnv@: Look up a thing in the VarEnv, then mash it with the modify function, and put it back. -} modifyVarEnv mangle_fn env key = case (lookupVarEnv env key) of Nothing -> env Just xx -> extendVarEnv env key (mangle_fn xx) modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a modifyVarEnv_Directly mangle_fn env key = case (lookupUFM_Directly env key) of Nothing -> env Just xx -> addToUFM_Directly env key (mangle_fn xx) -- Deterministic VarEnv -- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need -- DVarEnv. -- | Deterministic Variable Environment type DVarEnv elt = UniqDFM elt -- | Deterministic Identifier Environment type DIdEnv elt = DVarEnv elt -- | Deterministic Type Variable Environment type DTyVarEnv elt = DVarEnv elt emptyDVarEnv :: DVarEnv a emptyDVarEnv = emptyUDFM dVarEnvElts :: DVarEnv a -> [a] dVarEnvElts = eltsUDFM mkDVarEnv :: [(Var, a)] -> DVarEnv a mkDVarEnv = listToUDFM extendDVarEnv :: DVarEnv a -> Var -> a -> DVarEnv a extendDVarEnv = addToUDFM minusDVarEnv :: DVarEnv a -> DVarEnv a' -> DVarEnv a minusDVarEnv = minusUDFM lookupDVarEnv :: DVarEnv a -> Var -> Maybe a lookupDVarEnv = lookupUDFM foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b foldDVarEnv = foldUDFM mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b mapDVarEnv = mapUDFM filterDVarEnv :: (a -> Bool) -> DVarEnv a -> DVarEnv a filterDVarEnv = filterUDFM alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a alterDVarEnv = alterUDFM plusDVarEnv :: DVarEnv a -> DVarEnv a -> DVarEnv a plusDVarEnv = plusUDFM plusDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a plusDVarEnv_C = plusUDFM_C unitDVarEnv :: Var -> a -> DVarEnv a unitDVarEnv = unitUDFM delDVarEnv :: DVarEnv a -> Var -> DVarEnv a delDVarEnv = delFromUDFM delDVarEnvList :: DVarEnv a -> [Var] -> DVarEnv a delDVarEnvList = delListFromUDFM isEmptyDVarEnv :: DVarEnv a -> Bool isEmptyDVarEnv = isNullUDFM elemDVarEnv :: Var -> DVarEnv a -> Bool elemDVarEnv = elemUDFM extendDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> Var -> a -> DVarEnv a extendDVarEnv_C = addToUDFM_C modifyDVarEnv :: (a -> a) -> DVarEnv a -> Var -> DVarEnv a modifyDVarEnv mangle_fn env key = case (lookupDVarEnv env key) of Nothing -> env Just xx -> extendDVarEnv env key (mangle_fn xx) partitionDVarEnv :: (a -> Bool) -> DVarEnv a -> (DVarEnv a, DVarEnv a) partitionDVarEnv = partitionUDFM extendDVarEnvList :: DVarEnv a -> [(Var, a)] -> DVarEnv a extendDVarEnvList = addListToUDFM anyDVarEnv :: (a -> Bool) -> DVarEnv a -> Bool anyDVarEnv = anyUDFM ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/VarSet.hs0000644000000000000000000002755313713635744021202 0ustar0000000000000000{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} {-# LANGUAGE CPP #-} module VarSet ( -- * Var, Id and TyVar set types VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet, -- ** Manipulating these sets emptyVarSet, unitVarSet, mkVarSet, extendVarSet, extendVarSetList, elemVarSet, subVarSet, unionVarSet, unionVarSets, mapUnionVarSet, intersectVarSet, intersectsVarSet, disjointVarSet, isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, minusVarSet, filterVarSet, mapVarSet, anyVarSet, allVarSet, transCloVarSet, fixVarSet, lookupVarSet_Directly, lookupVarSet, lookupVarSetByName, sizeVarSet, seqVarSet, elemVarSetByKey, partitionVarSet, pluralVarSet, pprVarSet, -- * Deterministic Var set types DVarSet, DIdSet, DTyVarSet, DTyCoVarSet, -- ** Manipulating these sets emptyDVarSet, unitDVarSet, mkDVarSet, extendDVarSet, extendDVarSetList, elemDVarSet, dVarSetElems, subDVarSet, unionDVarSet, unionDVarSets, mapUnionDVarSet, intersectDVarSet, dVarSetIntersectVarSet, intersectsDVarSet, disjointDVarSet, isEmptyDVarSet, delDVarSet, delDVarSetList, minusDVarSet, foldDVarSet, filterDVarSet, mapDVarSet, dVarSetMinusVarSet, anyDVarSet, allDVarSet, transCloDVarSet, sizeDVarSet, seqDVarSet, partitionDVarSet, dVarSetToVarSet, ) where #include "GhclibHsVersions.h" import GhcPrelude import Var ( Var, TyVar, CoVar, TyCoVar, Id ) import Unique import Name ( Name ) import UniqSet import UniqDSet import UniqFM( disjointUFM, pluralUFM, pprUFM ) import UniqDFM( disjointUDFM, udfmToUfm, anyUDFM, allUDFM ) import Outputable (SDoc) -- | A non-deterministic Variable Set -- -- A non-deterministic set of variables. -- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not -- deterministic and why it matters. Use DVarSet if the set eventually -- gets converted into a list or folded over in a way where the order -- changes the generated code, for example when abstracting variables. type VarSet = UniqSet Var -- | Identifier Set type IdSet = UniqSet Id -- | Type Variable Set type TyVarSet = UniqSet TyVar -- | Coercion Variable Set type CoVarSet = UniqSet CoVar -- | Type or Coercion Variable Set type TyCoVarSet = UniqSet TyCoVar emptyVarSet :: VarSet intersectVarSet :: VarSet -> VarSet -> VarSet unionVarSet :: VarSet -> VarSet -> VarSet unionVarSets :: [VarSet] -> VarSet mapUnionVarSet :: (a -> VarSet) -> [a] -> VarSet -- ^ map the function over the list, and union the results unitVarSet :: Var -> VarSet extendVarSet :: VarSet -> Var -> VarSet extendVarSetList:: VarSet -> [Var] -> VarSet elemVarSet :: Var -> VarSet -> Bool delVarSet :: VarSet -> Var -> VarSet delVarSetList :: VarSet -> [Var] -> VarSet minusVarSet :: VarSet -> VarSet -> VarSet isEmptyVarSet :: VarSet -> Bool mkVarSet :: [Var] -> VarSet lookupVarSet_Directly :: VarSet -> Unique -> Maybe Var lookupVarSet :: VarSet -> Var -> Maybe Var -- Returns the set element, which may be -- (==) to the argument, but not the same as lookupVarSetByName :: VarSet -> Name -> Maybe Var sizeVarSet :: VarSet -> Int filterVarSet :: (Var -> Bool) -> VarSet -> VarSet delVarSetByKey :: VarSet -> Unique -> VarSet elemVarSetByKey :: Unique -> VarSet -> Bool partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet) emptyVarSet = emptyUniqSet unitVarSet = unitUniqSet extendVarSet = addOneToUniqSet extendVarSetList= addListToUniqSet intersectVarSet = intersectUniqSets intersectsVarSet:: VarSet -> VarSet -> Bool -- True if non-empty intersection disjointVarSet :: VarSet -> VarSet -> Bool -- True if empty intersection subVarSet :: VarSet -> VarSet -> Bool -- True if first arg is subset of second -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty; -- ditto disjointVarSet, subVarSet unionVarSet = unionUniqSets unionVarSets = unionManyUniqSets elemVarSet = elementOfUniqSet minusVarSet = minusUniqSet delVarSet = delOneFromUniqSet delVarSetList = delListFromUniqSet isEmptyVarSet = isEmptyUniqSet mkVarSet = mkUniqSet lookupVarSet_Directly = lookupUniqSet_Directly lookupVarSet = lookupUniqSet lookupVarSetByName = lookupUniqSet sizeVarSet = sizeUniqSet filterVarSet = filterUniqSet delVarSetByKey = delOneFromUniqSet_Directly elemVarSetByKey = elemUniqSet_Directly partitionVarSet = partitionUniqSet mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs -- See comments with type signatures intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2) disjointVarSet s1 s2 = disjointUFM (getUniqSet s1) (getUniqSet s2) subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2) anyVarSet :: (Var -> Bool) -> VarSet -> Bool anyVarSet = uniqSetAny allVarSet :: (Var -> Bool) -> VarSet -> Bool allVarSet = uniqSetAll mapVarSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b mapVarSet = mapUniqSet fixVarSet :: (VarSet -> VarSet) -- Map the current set to a new set -> VarSet -> VarSet -- (fixVarSet f s) repeatedly applies f to the set s, -- until it reaches a fixed point. fixVarSet fn vars | new_vars `subVarSet` vars = vars | otherwise = fixVarSet fn new_vars where new_vars = fn vars transCloVarSet :: (VarSet -> VarSet) -- Map some variables in the set to -- extra variables that should be in it -> VarSet -> VarSet -- (transCloVarSet f s) repeatedly applies f to new candidates, adding any -- new variables to s that it finds thereby, until it reaches a fixed point. -- -- The function fn could be (Var -> VarSet), but we use (VarSet -> VarSet) -- for efficiency, so that the test can be batched up. -- It's essential that fn will work fine if given new candidates -- one at at time; ie fn {v1,v2} = fn v1 `union` fn v2 -- Use fixVarSet if the function needs to see the whole set all at once transCloVarSet fn seeds = go seeds seeds where go :: VarSet -- Accumulating result -> VarSet -- Work-list; un-processed subset of accumulating result -> VarSet -- Specification: go acc vs = acc `union` transClo fn vs go acc candidates | isEmptyVarSet new_vs = acc | otherwise = go (acc `unionVarSet` new_vs) new_vs where new_vs = fn candidates `minusVarSet` acc seqVarSet :: VarSet -> () seqVarSet s = sizeVarSet s `seq` () -- | Determines the pluralisation suffix appropriate for the length of a set -- in the same way that plural from Outputable does for lists. pluralVarSet :: VarSet -> SDoc pluralVarSet = pluralUFM . getUniqSet -- | Pretty-print a non-deterministic set. -- The order of variables is non-deterministic and for pretty-printing that -- shouldn't be a problem. -- Having this function helps contain the non-determinism created with -- nonDetEltsUFM. -- Passing a list to the pretty-printing function allows the caller -- to decide on the order of Vars (eg. toposort them) without them having -- to use nonDetEltsUFM at the call site. This prevents from let-binding -- non-deterministically ordered lists and reusing them where determinism -- matters. pprVarSet :: VarSet -- ^ The things to be pretty printed -> ([Var] -> SDoc) -- ^ The pretty printing function to use on the -- elements -> SDoc -- ^ 'SDoc' where the things have been pretty -- printed pprVarSet = pprUFM . getUniqSet -- Deterministic VarSet -- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need -- DVarSet. -- | Deterministic Variable Set type DVarSet = UniqDSet Var -- | Deterministic Identifier Set type DIdSet = UniqDSet Id -- | Deterministic Type Variable Set type DTyVarSet = UniqDSet TyVar -- | Deterministic Type or Coercion Variable Set type DTyCoVarSet = UniqDSet TyCoVar emptyDVarSet :: DVarSet emptyDVarSet = emptyUniqDSet unitDVarSet :: Var -> DVarSet unitDVarSet = unitUniqDSet mkDVarSet :: [Var] -> DVarSet mkDVarSet = mkUniqDSet -- The new element always goes to the right of existing ones. extendDVarSet :: DVarSet -> Var -> DVarSet extendDVarSet = addOneToUniqDSet elemDVarSet :: Var -> DVarSet -> Bool elemDVarSet = elementOfUniqDSet dVarSetElems :: DVarSet -> [Var] dVarSetElems = uniqDSetToList subDVarSet :: DVarSet -> DVarSet -> Bool subDVarSet s1 s2 = isEmptyDVarSet (s1 `minusDVarSet` s2) unionDVarSet :: DVarSet -> DVarSet -> DVarSet unionDVarSet = unionUniqDSets unionDVarSets :: [DVarSet] -> DVarSet unionDVarSets = unionManyUniqDSets -- | Map the function over the list, and union the results mapUnionDVarSet :: (a -> DVarSet) -> [a] -> DVarSet mapUnionDVarSet get_set xs = foldr (unionDVarSet . get_set) emptyDVarSet xs intersectDVarSet :: DVarSet -> DVarSet -> DVarSet intersectDVarSet = intersectUniqDSets dVarSetIntersectVarSet :: DVarSet -> VarSet -> DVarSet dVarSetIntersectVarSet = uniqDSetIntersectUniqSet -- | True if empty intersection disjointDVarSet :: DVarSet -> DVarSet -> Bool disjointDVarSet s1 s2 = disjointUDFM (getUniqDSet s1) (getUniqDSet s2) -- | True if non-empty intersection intersectsDVarSet :: DVarSet -> DVarSet -> Bool intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2) isEmptyDVarSet :: DVarSet -> Bool isEmptyDVarSet = isEmptyUniqDSet delDVarSet :: DVarSet -> Var -> DVarSet delDVarSet = delOneFromUniqDSet minusDVarSet :: DVarSet -> DVarSet -> DVarSet minusDVarSet = minusUniqDSet dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet dVarSetMinusVarSet = uniqDSetMinusUniqSet foldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a foldDVarSet = foldUniqDSet anyDVarSet :: (Var -> Bool) -> DVarSet -> Bool anyDVarSet p = anyUDFM p . getUniqDSet allDVarSet :: (Var -> Bool) -> DVarSet -> Bool allDVarSet p = allUDFM p . getUniqDSet mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b mapDVarSet = mapUniqDSet filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet filterDVarSet = filterUniqDSet sizeDVarSet :: DVarSet -> Int sizeDVarSet = sizeUniqDSet -- | Partition DVarSet according to the predicate given partitionDVarSet :: (Var -> Bool) -> DVarSet -> (DVarSet, DVarSet) partitionDVarSet = partitionUniqDSet -- | Delete a list of variables from DVarSet delDVarSetList :: DVarSet -> [Var] -> DVarSet delDVarSetList = delListFromUniqDSet seqDVarSet :: DVarSet -> () seqDVarSet s = sizeDVarSet s `seq` () -- | Add a list of variables to DVarSet extendDVarSetList :: DVarSet -> [Var] -> DVarSet extendDVarSetList = addListToUniqDSet -- | Convert a DVarSet to a VarSet by forgeting the order of insertion dVarSetToVarSet :: DVarSet -> VarSet dVarSetToVarSet = unsafeUFMToUniqSet . udfmToUfm . getUniqDSet -- | transCloVarSet for DVarSet transCloDVarSet :: (DVarSet -> DVarSet) -- Map some variables in the set to -- extra variables that should be in it -> DVarSet -> DVarSet -- (transCloDVarSet f s) repeatedly applies f to new candidates, adding any -- new variables to s that it finds thereby, until it reaches a fixed point. -- -- The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet) -- for efficiency, so that the test can be batched up. -- It's essential that fn will work fine if given new candidates -- one at at time; ie fn {v1,v2} = fn v1 `union` fn v2 transCloDVarSet fn seeds = go seeds seeds where go :: DVarSet -- Accumulating result -> DVarSet -- Work-list; un-processed subset of accumulating result -> DVarSet -- Specification: go acc vs = acc `union` transClo fn vs go acc candidates | isEmptyDVarSet new_vs = acc | otherwise = go (acc `unionDVarSet` new_vs) new_vs where new_vs = fn candidates `minusDVarSet` acc ghc-lib-parser-8.10.2.20200808/compiler/types/Coercion.hs-boot0000644000000000000000000000343113713635665021525 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module Coercion where import GhcPrelude import {-# SOURCE #-} TyCoRep import {-# SOURCE #-} TyCon import BasicTypes ( LeftOrRight ) import CoAxiom import Var import Pair import Util mkReflCo :: Role -> Type -> Coercion mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion mkAppCo :: Coercion -> Coercion -> Coercion mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion mkFunCo :: Role -> Coercion -> Coercion -> Coercion mkCoVarCo :: CoVar -> Coercion mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion mkPhantomCo :: Coercion -> Type -> Type -> Coercion mkUnsafeCo :: Role -> Type -> Type -> Coercion mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion mkSymCo :: Coercion -> Coercion mkTransCo :: Coercion -> Coercion -> Coercion mkNthCo :: HasDebugCallStack => Role -> Int -> Coercion -> Coercion mkLRCo :: LeftOrRight -> Coercion -> Coercion mkInstCo :: Coercion -> Coercion -> Coercion mkGReflCo :: Role -> Type -> MCoercionN -> Coercion mkNomReflCo :: Type -> Coercion mkKindCo :: Coercion -> Coercion mkSubCo :: Coercion -> Coercion mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion isGReflCo :: Coercion -> Bool isReflCo :: Coercion -> Bool isReflexiveCo :: Coercion -> Bool decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion) coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind, Kind, Type, Type, Role) coVarRole :: CoVar -> Role mkCoercionType :: Role -> Type -> Type -> Type data LiftingContext liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion seqCo :: Coercion -> () coercionKind :: Coercion -> Pair Type coercionType :: Coercion -> Type ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/ConLike.hs-boot0000644000000000000000000000033413713635665022251 0ustar0000000000000000module ConLike where import {-# SOURCE #-} DataCon (DataCon) import {-# SOURCE #-} PatSyn (PatSyn) import Name ( Name ) data ConLike = RealDataCon DataCon | PatSynCon PatSyn conLikeName :: ConLike -> Name ghc-lib-parser-8.10.2.20200808/compiler/simplCore/CoreMonad.hs-boot0000644000000000000000000000146213713635665022426 0ustar0000000000000000-- Created this hs-boot file to remove circular dependencies from the use of -- Plugins. Plugins needs CoreToDo and CoreM types to define core-to-core -- transformations. -- However CoreMonad does much more than defining these, and because Plugins are -- activated in various modules, the imports become circular. To solve this I -- extracted CoreToDo and CoreM into this file. -- I needed to write the whole definition of these types, otherwise it created -- a data-newtype conflict. module CoreMonad ( CoreToDo, CoreM ) where import GhcPrelude import IOEnv ( IOEnv ) type CoreIOEnv = IOEnv CoreReader data CoreReader newtype CoreWriter = CoreWriter { cw_simpl_count :: SimplCount } data SimplCount newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) } instance Monad CoreM data CoreToDo ghc-lib-parser-8.10.2.20200808/compiler/coreSyn/CoreUnfold.hs-boot0000644000000000000000000000036713713635665022307 0ustar0000000000000000module CoreUnfold ( mkUnfolding ) where import GhcPrelude import CoreSyn import DynFlags mkUnfolding :: DynFlags -> UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/DataCon.hs-boot0000644000000000000000000000202113713635665022231 0ustar0000000000000000module DataCon where import GhcPrelude import Var( TyVar, TyCoVar, TyVarBinder ) import Name( Name, NamedThing ) import {-# SOURCE #-} TyCon( TyCon ) import FieldLabel ( FieldLabel ) import Unique ( Uniquable ) import Outputable ( Outputable, OutputableBndr ) import BasicTypes (Arity) import {-# SOURCE #-} TyCoRep ( Type, ThetaType ) data DataCon data DataConRep data EqSpec dataConName :: DataCon -> Name dataConTyCon :: DataCon -> TyCon dataConExTyCoVars :: DataCon -> [TyCoVar] dataConUserTyVars :: DataCon -> [TyVar] dataConUserTyVarBinders :: DataCon -> [TyVarBinder] dataConSourceArity :: DataCon -> Arity dataConFieldLabels :: DataCon -> [FieldLabel] dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] dataConStupidTheta :: DataCon -> ThetaType dataConFullSig :: DataCon -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) isUnboxedSumCon :: DataCon -> Bool instance Eq DataCon instance Uniquable DataCon instance NamedThing DataCon instance Outputable DataCon instance OutputableBndr DataCon ghc-lib-parser-8.10.2.20200808/compiler/main/DynFlags.hs-boot0000644000000000000000000000112513713635665021251 0ustar0000000000000000module DynFlags where import GhcPrelude import GHC.Platform data DynFlags data DumpFlag data GeneralFlag targetPlatform :: DynFlags -> Platform pprUserLength :: DynFlags -> Int pprCols :: DynFlags -> Int unsafeGlobalDynFlags :: DynFlags useUnicode :: DynFlags -> Bool useUnicodeSyntax :: DynFlags -> Bool useStarIsType :: DynFlags -> Bool shouldUseColor :: DynFlags -> Bool shouldUseHexWordLiterals :: DynFlags -> Bool hasPprDebug :: DynFlags -> Bool hasNoDebugOutput :: DynFlags -> Bool ghc-lib-parser-8.10.2.20200808/compiler/main/ErrUtils.hs-boot0000644000000000000000000000113213713635665021311 0ustar0000000000000000module ErrUtils where import GhcPrelude import Outputable (SDoc, PrintUnqualified ) import SrcLoc (SrcSpan) import Json import {-# SOURCE #-} DynFlags ( DynFlags, DumpFlag ) data Severity = SevOutput | SevFatal | SevInteractive | SevDump | SevInfo | SevWarning | SevError type MsgDoc = SDoc mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO () instance ToJson Severity ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/Expr.hs-boot0000644000000000000000000000333613713635665020515 0ustar0000000000000000{-# LANGUAGE CPP, KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeFamilies #-} module GHC.Hs.Expr where import SrcLoc ( Located ) import Outputable ( SDoc, Outputable ) import {-# SOURCE #-} GHC.Hs.Pat ( LPat ) import BasicTypes ( SpliceExplicitFlag(..)) import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) type role HsExpr nominal type role HsCmd nominal type role MatchGroup nominal nominal type role GRHSs nominal nominal type role HsSplice nominal type role SyntaxExpr nominal data HsExpr (i :: *) data HsCmd (i :: *) data HsSplice (i :: *) data MatchGroup (a :: *) (body :: *) data GRHSs (a :: *) (body :: *) data SyntaxExpr (i :: *) instance OutputableBndrId p => Outputable (HsExpr (GhcPass p)) instance OutputableBndrId p => Outputable (HsCmd (GhcPass p)) type LHsExpr a = Located (HsExpr a) pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc pprSpliceDecl :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc pprPatBind :: forall bndr p body. (OutputableBndrId bndr, OutputableBndrId p, Outputable body) => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc pprFunBind :: (OutputableBndrId idR, Outputable body) => MatchGroup (GhcPass idR) body -> SDoc ghc-lib-parser-8.10.2.20200808/compiler/GHC/Hs/Pat.hs-boot0000644000000000000000000000107413713635665020320 0ustar0000000000000000{-# LANGUAGE CPP, KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TypeFamilies #-} module GHC.Hs.Pat where import Outputable import GHC.Hs.Extension ( OutputableBndrId, GhcPass, XRec ) type role Pat nominal data Pat (i :: *) type LPat i = XRec i Pat instance OutputableBndrId p => Outputable (Pat (GhcPass p)) ghc-lib-parser-8.10.2.20200808/compiler/GHC/HsToCore/PmCheck/Types.hs-boot0000644000000000000000000000013613713635665023324 0ustar0000000000000000module GHC.HsToCore.PmCheck.Types where import GhcPrelude () data Delta initDelta :: Delta ghc-lib-parser-8.10.2.20200808/compiler/main/Hooks.hs-boot0000644000000000000000000000011213713635665020620 0ustar0000000000000000module Hooks where import GhcPrelude () data Hooks emptyHooks :: Hooks ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/IdInfo.hs-boot0000644000000000000000000000031513713635665022074 0ustar0000000000000000module IdInfo where import GhcPrelude import Outputable data IdInfo data IdDetails vanillaIdInfo :: IdInfo coVarDetails :: IdDetails isCoVarDetails :: IdDetails -> Bool pprIdDetails :: IdDetails -> SDoc ghc-lib-parser-8.10.2.20200808/compiler/iface/IfaceType.hs-boot0000644000000000000000000000052213713635665021536 0ustar0000000000000000-- Used only by ToIface.hs-boot module IfaceType( IfaceType, IfaceTyCon, IfaceForAllBndr , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) where import Var (VarBndr, ArgFlag) data IfaceAppArgs data IfaceType data IfaceTyCon data IfaceTyLit data IfaceCoercion data IfaceBndr type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag ghc-lib-parser-8.10.2.20200808/compiler/prelude/KnownUniques.hs-boot0000644000000000000000000000064413713635665022731 0ustar0000000000000000module KnownUniques where import GhcPrelude import Unique import Name import BasicTypes -- Needed by TysWiredIn knownUniqueName :: Unique -> Maybe Name mkSumTyConUnique :: Arity -> Unique mkSumDataConUnique :: ConTagZ -> Arity -> Unique mkCTupleTyConUnique :: Arity -> Unique mkCTupleDataConUnique :: Arity -> Unique mkTupleTyConUnique :: Boxity -> Arity -> Unique mkTupleDataConUnique :: Boxity -> Arity -> Unique ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/MkId.hs-boot0000644000000000000000000000046713713635665021560 0ustar0000000000000000module MkId where import Name( Name ) import Var( Id ) import Class( Class ) import {-# SOURCE #-} DataCon( DataCon ) import {-# SOURCE #-} PrimOp( PrimOp ) data DataConBoxer mkDataConWorkId :: Name -> DataCon -> Id mkDictSelId :: Name -> Class -> Id mkPrimOpId :: PrimOp -> Id magicDictId :: Id ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/Module.hs-boot0000644000000000000000000000041213713635665022147 0ustar0000000000000000module Module where import GhcPrelude import FastString data Module data ModuleName data UnitId data InstalledUnitId newtype ComponentId = ComponentId FastString moduleName :: Module -> ModuleName moduleUnitId :: Module -> UnitId unitIdString :: UnitId -> String ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/Name.hs-boot0000644000000000000000000000006313713635665021604 0ustar0000000000000000module Name where import GhcPrelude () data Name ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/OccName.hs-boot0000644000000000000000000000007113713635665022230 0ustar0000000000000000module OccName where import GhcPrelude () data OccName ghc-lib-parser-8.10.2.20200808/compiler/utils/Outputable.hs-boot0000644000000000000000000000033213713635665022101 0ustar0000000000000000module Outputable where import GhcPrelude import GHC.Stack( HasCallStack ) data SDoc showSDocUnsafe :: SDoc -> String warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a text :: String -> SDoc ghc-lib-parser-8.10.2.20200808/compiler/main/PackageConfig.hs-boot0000644000000000000000000000045413713635665022227 0ustar0000000000000000module PackageConfig where import FastString import {-# SOURCE #-} Module import GHC.PackageDb newtype PackageName = PackageName FastString newtype SourcePackageId = SourcePackageId FastString type PackageConfig = InstalledPackageInfo ComponentId SourcePackageId PackageName UnitId ModuleName Module ghc-lib-parser-8.10.2.20200808/compiler/main/Packages.hs-boot0000644000000000000000000000071313713635665021262 0ustar0000000000000000module Packages where import GhcPrelude import {-# SOURCE #-} DynFlags(DynFlags) import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId) data PackageState data PackageConfigMap emptyPackageState :: PackageState componentIdString :: DynFlags -> ComponentId -> Maybe String displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String improveUnitId :: PackageConfigMap -> UnitId -> UnitId getPackageConfigMap :: DynFlags -> PackageConfigMap ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/PatSyn.hs-boot0000644000000000000000000000042713713635665022146 0ustar0000000000000000module PatSyn where import BasicTypes (Arity) import {-# SOURCE #-} TyCoRep (Type) import Var (TyVar) import Name (Name) data PatSyn patSynArity :: PatSyn -> Arity patSynInstArgTys :: PatSyn -> [Type] -> [Type] patSynExTyVars :: PatSyn -> [TyVar] patSynName :: PatSyn -> Name ghc-lib-parser-8.10.2.20200808/compiler/main/Plugins.hs-boot0000644000000000000000000000032613713635665021165 0ustar0000000000000000-- The plugins datatype is stored in DynFlags, so it needs to be -- exposed without importing all of its implementation. module Plugins where import GhcPrelude () data Plugin data LoadedPlugin data StaticPlugin ghc-lib-parser-8.10.2.20200808/compiler/prelude/PrelNames.hs-boot0000644000000000000000000000014513713635665022145 0ustar0000000000000000module PrelNames where import Module import Unique mAIN :: Module liftedTypeKindTyConKey :: Unique ghc-lib-parser-8.10.2.20200808/compiler/prelude/PrimOp.hs-boot0000644000000000000000000000006713713635665021470 0ustar0000000000000000module PrimOp where import GhcPrelude () data PrimOp ghc-lib-parser-8.10.2.20200808/compiler/typecheck/TcHoleFitTypes.hs-boot0000644000000000000000000000036113713635665023444 0ustar0000000000000000-- This boot file is in place to break the loop where: -- + TcRnTypes needs 'HoleFitPlugin', -- + which needs 'TcHoleFitTypes' -- + which needs 'TcRnTypes' module TcHoleFitTypes where -- Build ordering import GHC.Base() data HoleFitPlugin ghc-lib-parser-8.10.2.20200808/compiler/typecheck/TcRnTypes.hs-boot0000644000000000000000000000037513713635665022476 0ustar0000000000000000module TcRnTypes where import TcType import SrcLoc data TcLclEnv setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv getLclEnvTcLevel :: TcLclEnv -> TcLevel setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv getLclEnvLoc :: TcLclEnv -> RealSrcSpan ghc-lib-parser-8.10.2.20200808/compiler/typecheck/TcType.hs-boot0000644000000000000000000000024313713635665022005 0ustar0000000000000000module TcType where import Outputable( SDoc ) data MetaDetails data TcTyVarDetails pprTcTyVarDetails :: TcTyVarDetails -> SDoc vanillaSkolemTv :: TcTyVarDetails ghc-lib-parser-8.10.2.20200808/compiler/iface/ToIface.hs-boot0000644000000000000000000000125213713635665021200 0ustar0000000000000000module ToIface where import {-# SOURCE #-} TyCoRep ( Type, TyLit, Coercion ) import {-# SOURCE #-} IfaceType( IfaceType, IfaceTyCon, IfaceForAllBndr , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) import Var ( TyCoVarBinder ) import VarEnv ( TidyEnv ) import TyCon ( TyCon ) import VarSet( VarSet ) -- For TyCoRep toIfaceTypeX :: VarSet -> Type -> IfaceType toIfaceTyLit :: TyLit -> IfaceTyLit toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs ghc-lib-parser-8.10.2.20200808/compiler/types/TyCoPpr.hs-boot0000644000000000000000000000031213713635665021317 0ustar0000000000000000module TyCoPpr where import {-# SOURCE #-} TyCoRep (Type, Kind, Coercion, TyLit) import Outputable pprType :: Type -> SDoc pprKind :: Kind -> SDoc pprCo :: Coercion -> SDoc pprTyLit :: TyLit -> SDoc ghc-lib-parser-8.10.2.20200808/compiler/types/TyCoRep.hs-boot0000644000000000000000000000074313713635665021314 0ustar0000000000000000module TyCoRep where import Data.Data ( Data ) import {-# SOURCE #-} Var( Var, ArgFlag, AnonArgFlag ) data Type data TyThing data Coercion data UnivCoProvenance data TyLit data TyCoBinder data MCoercion type PredType = Type type Kind = Type type ThetaType = [PredType] type CoercionN = Coercion type MCoercionN = MCoercion mkFunTy :: AnonArgFlag -> Type -> Type -> Type mkForAllTy :: Var -> ArgFlag -> Type -> Type instance Data Type -- To support Data instances in CoAxiom ghc-lib-parser-8.10.2.20200808/compiler/types/TyCon.hs-boot0000644000000000000000000000024213713635665021015 0ustar0000000000000000module TyCon where import GhcPrelude data TyCon isTupleTyCon :: TyCon -> Bool isUnboxedTupleTyCon :: TyCon -> Bool isFunTyCon :: TyCon -> Bool ghc-lib-parser-8.10.2.20200808/compiler/types/Type.hs-boot0000644000000000000000000000121413713635665020702 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module Type where import GhcPrelude import TyCon import {-# SOURCE #-} TyCoRep( Type, Coercion ) import Util isPredTy :: HasDebugCallStack => Type -> Bool isCoercionTy :: Type -> Bool mkAppTy :: Type -> Type -> Type mkCastTy :: Type -> Coercion -> Type piResultTy :: HasDebugCallStack => Type -> Type -> Type eqType :: Type -> Type -> Bool coreView :: Type -> Maybe Type tcView :: Type -> Maybe Type isRuntimeRepTy :: Type -> Bool isLiftedTypeKind :: Type -> Bool splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) ghc-lib-parser-8.10.2.20200808/compiler/prelude/TysWiredIn.hs-boot0000644000000000000000000000245113713635665022322 0ustar0000000000000000module TysWiredIn where import {-# SOURCE #-} TyCon ( TyCon ) import {-# SOURCE #-} TyCoRep (Type, Kind) import BasicTypes (Arity, TupleSort) import Name (Name) listTyCon :: TyCon typeNatKind, typeSymbolKind :: Type mkBoxedTupleTy :: [Type] -> Type coercibleTyCon, heqTyCon :: TyCon unitTy :: Type liftedTypeKind :: Kind constraintKind :: Kind runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon runtimeRepTy :: Type liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, wordRepDataConTy, word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, vec64DataConTy :: Type int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, doubleElemRepDataConTy :: Type anyTypeOfKind :: Kind -> Type unboxedTupleKind :: [Type] -> Type mkPromotedListTy :: Type -> [Type] -> Type tupleTyConName :: TupleSort -> Arity -> Name ghc-lib-parser-8.10.2.20200808/compiler/basicTypes/Var.hs-boot0000644000000000000000000000102213713635665021450 0ustar0000000000000000-- Var.hs-boot is Imported (only) by TyCoRep.hs-boot module Var where import GhcPrelude () -- We compile this module with -XNoImplicitPrelude (for some -- reason), so if there are no imports it does not seem to -- depend on anything. But it does! We must, for example, -- compile GHC.Types in the ghc-prim library first. -- So this otherwise-unnecessary import tells the build system -- that this module depends on GhcPrelude, which ensures -- that GHC.Type is built first. data ArgFlag data AnonArgFlag data Var ghc-lib-parser-8.10.2.20200808/libraries/ghc-heap/cbits/HeapPrim.cmm0000644000000000000000000000032613713635745022447 0ustar0000000000000000#include "Cmm.h" Ghclib_aToWordzh (P_ clos) { return (clos); } Ghclib_reallyUnsafePtrEqualityUpToTag (W_ clos1, W_ clos2) { clos1 = UNTAG(clos1); clos2 = UNTAG(clos2); return (clos1 == clos2); } ghc-lib-parser-8.10.2.20200808/compiler/cbits/genSym.c0000644000000000000000000000206113713636246020027 0ustar0000000000000000#include #include #include "Unique.h" static HsInt GenSymCounter = 0; static HsInt GenSymInc = 1; #define UNIQUE_BITS (sizeof (HsInt) * 8 - UNIQUE_TAG_BITS) #define UNIQUE_MASK ((1ULL << UNIQUE_BITS) - 1) STATIC_INLINE void checkUniqueRange(HsInt u STG_UNUSED) { #if DEBUG // Uh oh! We will overflow next time a unique is requested. assert(u != UNIQUE_MASK); #endif } HsInt ghc_lib_parser_genSym(void) { #if defined(THREADED_RTS) if (n_capabilities == 1) { GenSymCounter = (GenSymCounter + GenSymInc) & UNIQUE_MASK; checkUniqueRange(GenSymCounter); return GenSymCounter; } else { HsInt n = atomic_inc((StgWord *)&GenSymCounter, GenSymInc) & UNIQUE_MASK; checkUniqueRange(n); return n; } #else GenSymCounter = (GenSymCounter + GenSymInc) & UNIQUE_MASK; checkUniqueRange(GenSymCounter); return GenSymCounter; #endif } void ghc_lib_parser_initGenSym(HsInt NewGenSymCounter, HsInt NewGenSymInc) { GenSymCounter = NewGenSymCounter; GenSymInc = NewGenSymInc; } ghc-lib-parser-8.10.2.20200808/compiler/parser/cutils.c0000644000000000000000000000106513713636246020263 0ustar0000000000000000/* These utility routines are used various places in the GHC library. */ #include #include void ghc_lib_parser_enableTimingStats( void ) /* called from the driver */ { RtsFlags.GcFlags.giveStats = ONELINE_GC_STATS; } void ghc_lib_parser_setHeapSize( HsInt size ) { RtsFlags.GcFlags.heapSizeSuggestion = size / BLOCK_SIZE; if (RtsFlags.GcFlags.maxHeapSize != 0 && RtsFlags.GcFlags.heapSizeSuggestion > RtsFlags.GcFlags.maxHeapSize) { RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion; } } ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/lib/settings0000644000000000000000000000312313713636006020516 0ustar0000000000000000[("GCC extra via C opts", "") ,("C compiler command", "cc") ,("C compiler flags", "") ,("C++ compiler flags", "") ,("C compiler link flags", "") ,("C compiler supports -no-pie", "NO") ,("Haskell CPP command", "cc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs") ,("ld command", "ld") ,("ld flags", "") ,("ld supports compact unwind", "YES") ,("ld supports build-id", "NO") ,("ld supports filelist", "YES") ,("ld is GNU ld", "NO") ,("Merge objects command", "ld") ,("Merge objects flags", "-r") ,("ar command", "ar") ,("ar flags", "qcls") ,("ar supports at file", "NO") ,("ranlib command", "ranlib") ,("touch command", "touch") ,("dllwrap command", "/bin/false") ,("windres command", "/bin/false") ,("libtool command", "libtool") ,("unlit command", "$topdir/bin/unlit") ,("cross compiling", "NO") ,("target platform string", "x86_64-apple-darwin") ,("target os", "OSDarwin") ,("target arch", "ArchX86_64") ,("target word size", "8") ,("target has GNU nonexec stack", "NO") ,("target has .ident directive", "YES") ,("target has subsections via symbols", "YES") ,("target has RTS linker", "YES") ,("Unregisterised", "NO") ,("LLVM target", "x86_64-apple-darwin") ,("LLVM llc command", "llc") ,("LLVM opt command", "opt") ,("LLVM clang command", "clang") ,("integer library", "integer-simple") ,("Use interpreter", "YES") ,("Use native code generator", "YES") ,("Support SMP", "YES") ,("RTS ways", "v thr") ,("Tables next to code", "YES") ,("Leading underscore", "YES") ,("Use LibFFI", "NO") ,("Use Threads", "YES") ,("Use Debugging", "NO") ,("RTS expects libdw", "NO") ] ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/lib/llvm-targets0000644000000000000000000001225713713636006021307 0ustar0000000000000000[("i386-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", "")) ,("i686-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", "")) ,("x86_64-unknown-windows", ("e-m:w-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align")) ,("arm-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align")) ,("armv6-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align")) ,("armv6-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align")) ,("armv6l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align")) ,("armv6l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align")) ,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) ,("armv7-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) ,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) ,("armv7a-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) ,("armv7a-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) ,("armv7a-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) ,("armv7l-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) ,("armv7l-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) ,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) ,("armv7l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) ,("aarch64-unknown-linux-gnu", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("aarch64-unknown-linux-musl", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("aarch64-unknown-linux", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("i386-unknown-linux-gnu", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", "")) ,("i386-unknown-linux-musl", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", "")) ,("i386-unknown-linux", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", "")) ,("x86_64-unknown-linux-gnu", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-linux-musl", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-linux", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-linux-android", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+sse4.2 +popcnt +cx16")) ,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+fpregs +vfp2 +vfp2d16 +vfp2d16sp +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -crypto -fp16fml")) ,("aarch64-unknown-linux-android", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("armv7a-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+fpregs +vfp2 +vfp2d16 +vfp2d16sp +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -crypto -fp16fml")) ,("powerpc64le-unknown-linux-gnu", ("e-m:e-i64:64-n32:64", "ppc64le", "")) ,("powerpc64le-unknown-linux-musl", ("e-m:e-i64:64-n32:64", "ppc64le", "+secure-plt")) ,("powerpc64le-unknown-linux", ("e-m:e-i64:64-n32:64", "ppc64le", "")) ,("s390x-ibm-linux", ("E-m:e-i1:8:16-i8:8:16-i64:64-f128:64-a:8:16-n32:64", "z10", "")) ,("i386-apple-darwin", ("e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128", "yonah", "")) ,("x86_64-apple-darwin", ("e-m:o-i64:64-f80:128-n8:16:32:64-S128", "core2", "")) ,("armv7-apple-ios", ("e-m:o-p:32:32-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32", "generic", "")) ,("aarch64-apple-ios", ("e-m:o-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("i386-apple-ios", ("e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128", "yonah", "")) ,("x86_64-apple-ios", ("e-m:o-i64:64-f80:128-n8:16:32:64-S128", "core2", "")) ,("amd64-portbld-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("aarch64-unknown-freebsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align")) ,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align")) ,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align")) ] ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/lib/llvm-passes0000644000000000000000000000010213713636006021116 0ustar0000000000000000[ (0, "-mem2reg -globalopt"), (1, "-O1 -globalopt"), (2, "-O2") ] ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/lib/platformConstants0000644000000000000000000001152013713636027022402 0ustar0000000000000000PlatformConstants { pc_CONTROL_GROUP_CONST_291 = 291, pc_STD_HDR_SIZE = 1, pc_PROF_HDR_SIZE = 2, pc_BLOCK_SIZE = 4096, pc_BLOCKS_PER_MBLOCK = 252, pc_TICKY_BIN_COUNT = 9, pc_OFFSET_StgRegTable_rR1 = 0, pc_OFFSET_StgRegTable_rR2 = 8, pc_OFFSET_StgRegTable_rR3 = 16, pc_OFFSET_StgRegTable_rR4 = 24, pc_OFFSET_StgRegTable_rR5 = 32, pc_OFFSET_StgRegTable_rR6 = 40, pc_OFFSET_StgRegTable_rR7 = 48, pc_OFFSET_StgRegTable_rR8 = 56, pc_OFFSET_StgRegTable_rR9 = 64, pc_OFFSET_StgRegTable_rR10 = 72, pc_OFFSET_StgRegTable_rF1 = 80, pc_OFFSET_StgRegTable_rF2 = 84, pc_OFFSET_StgRegTable_rF3 = 88, pc_OFFSET_StgRegTable_rF4 = 92, pc_OFFSET_StgRegTable_rF5 = 96, pc_OFFSET_StgRegTable_rF6 = 100, pc_OFFSET_StgRegTable_rD1 = 104, pc_OFFSET_StgRegTable_rD2 = 112, pc_OFFSET_StgRegTable_rD3 = 120, pc_OFFSET_StgRegTable_rD4 = 128, pc_OFFSET_StgRegTable_rD5 = 136, pc_OFFSET_StgRegTable_rD6 = 144, pc_OFFSET_StgRegTable_rXMM1 = 152, pc_OFFSET_StgRegTable_rXMM2 = 168, pc_OFFSET_StgRegTable_rXMM3 = 184, pc_OFFSET_StgRegTable_rXMM4 = 200, pc_OFFSET_StgRegTable_rXMM5 = 216, pc_OFFSET_StgRegTable_rXMM6 = 232, pc_OFFSET_StgRegTable_rYMM1 = 248, pc_OFFSET_StgRegTable_rYMM2 = 280, pc_OFFSET_StgRegTable_rYMM3 = 312, pc_OFFSET_StgRegTable_rYMM4 = 344, pc_OFFSET_StgRegTable_rYMM5 = 376, pc_OFFSET_StgRegTable_rYMM6 = 408, pc_OFFSET_StgRegTable_rZMM1 = 440, pc_OFFSET_StgRegTable_rZMM2 = 504, pc_OFFSET_StgRegTable_rZMM3 = 568, pc_OFFSET_StgRegTable_rZMM4 = 632, pc_OFFSET_StgRegTable_rZMM5 = 696, pc_OFFSET_StgRegTable_rZMM6 = 760, pc_OFFSET_StgRegTable_rL1 = 824, pc_OFFSET_StgRegTable_rSp = 832, pc_OFFSET_StgRegTable_rSpLim = 840, pc_OFFSET_StgRegTable_rHp = 848, pc_OFFSET_StgRegTable_rHpLim = 856, pc_OFFSET_StgRegTable_rCCCS = 864, pc_OFFSET_StgRegTable_rCurrentTSO = 872, pc_OFFSET_StgRegTable_rCurrentNursery = 888, pc_OFFSET_StgRegTable_rHpAlloc = 904, pc_OFFSET_stgEagerBlackholeInfo = -24, pc_OFFSET_stgGCEnter1 = -16, pc_OFFSET_stgGCFun = -8, pc_OFFSET_Capability_r = 24, pc_OFFSET_bdescr_start = 0, pc_OFFSET_bdescr_free = 8, pc_OFFSET_bdescr_blocks = 48, pc_OFFSET_bdescr_flags = 46, pc_SIZEOF_CostCentreStack = 96, pc_OFFSET_CostCentreStack_mem_alloc = 72, pc_REP_CostCentreStack_mem_alloc = 8, pc_OFFSET_CostCentreStack_scc_count = 48, pc_REP_CostCentreStack_scc_count = 8, pc_OFFSET_StgHeader_ccs = 8, pc_OFFSET_StgHeader_ldvw = 16, pc_SIZEOF_StgSMPThunkHeader = 8, pc_OFFSET_StgEntCounter_allocs = 48, pc_REP_StgEntCounter_allocs = 8, pc_OFFSET_StgEntCounter_allocd = 16, pc_REP_StgEntCounter_allocd = 8, pc_OFFSET_StgEntCounter_registeredp = 0, pc_OFFSET_StgEntCounter_link = 56, pc_OFFSET_StgEntCounter_entry_count = 40, pc_SIZEOF_StgUpdateFrame_NoHdr = 8, pc_SIZEOF_StgMutArrPtrs_NoHdr = 16, pc_OFFSET_StgMutArrPtrs_ptrs = 0, pc_OFFSET_StgMutArrPtrs_size = 8, pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 8, pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0, pc_SIZEOF_StgArrBytes_NoHdr = 8, pc_OFFSET_StgArrBytes_bytes = 0, pc_OFFSET_StgTSO_alloc_limit = 96, pc_OFFSET_StgTSO_cccs = 112, pc_OFFSET_StgTSO_stackobj = 16, pc_OFFSET_StgStack_sp = 8, pc_OFFSET_StgStack_stack = 16, pc_OFFSET_StgUpdateFrame_updatee = 0, pc_OFFSET_StgFunInfoExtraFwd_arity = 4, pc_REP_StgFunInfoExtraFwd_arity = 4, pc_SIZEOF_StgFunInfoExtraRev = 24, pc_OFFSET_StgFunInfoExtraRev_arity = 20, pc_REP_StgFunInfoExtraRev_arity = 4, pc_MAX_SPEC_SELECTEE_SIZE = 15, pc_MAX_SPEC_AP_SIZE = 7, pc_MIN_PAYLOAD_SIZE = 1, pc_MIN_INTLIKE = -16, pc_MAX_INTLIKE = 255, pc_MIN_CHARLIKE = 0, pc_MAX_CHARLIKE = 255, pc_MUT_ARR_PTRS_CARD_BITS = 7, pc_MAX_Vanilla_REG = 10, pc_MAX_Float_REG = 6, pc_MAX_Double_REG = 6, pc_MAX_Long_REG = 1, pc_MAX_XMM_REG = 6, pc_MAX_Real_Vanilla_REG = 6, pc_MAX_Real_Float_REG = 6, pc_MAX_Real_Double_REG = 6, pc_MAX_Real_XMM_REG = 6, pc_MAX_Real_Long_REG = 0, pc_RESERVED_C_STACK_BYTES = 16384, pc_RESERVED_STACK_WORDS = 21, pc_AP_STACK_SPLIM = 1024, pc_WORD_SIZE = 8, pc_DOUBLE_SIZE = 8, pc_CINT_SIZE = 4, pc_CLONG_SIZE = 8, pc_CLONG_LONG_SIZE = 8, pc_BITMAP_BITS_SHIFT = 6, pc_TAG_BITS = 3, pc_WORDS_BIGENDIAN = False, pc_DYNAMIC_BY_DEFAULT = False, pc_LDV_SHIFT = 30, pc_ILDV_CREATE_MASK = 1152921503533105152, pc_ILDV_STATE_CREATE = 0, pc_ILDV_STATE_USE = 1152921504606846976 } ghc-lib-parser-8.10.2.20200808/LICENSE0000644000000000000000000000311313713635662014510 0ustar0000000000000000The Glasgow Haskell Compiler License Copyright 2002, The University Court of the University of Glasgow. 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 name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE 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 UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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-8.10.2.20200808/ghc-lib-parser.cabal0000644000000000000000000002100513713636251017261 0ustar0000000000000000cabal-version: >=1.22 build-type: Simple name: ghc-lib-parser version: 8.10.2.20200808 license: BSD3 license-file: LICENSE category: Development author: The GHC Team and Digital Asset maintainer: Digital Asset synopsis: The GHC API, decoupled from GHC versions description: A package equivalent to the @ghc@ package, but which can be loaded on many compiler versions. homepage: https://github.com/digital-asset/ghc-lib bug-reports: https://github.com/digital-asset/ghc-lib/issues data-dir: ghc-lib/stage0/lib data-files: settings llvm-targets llvm-passes platformConstants extra-source-files: ghc-lib/stage0/lib/ghcautoconf.h ghc-lib/stage0/lib/ghcplatform.h ghc-lib/stage0/lib/ghcversion.h ghc-lib/stage0/lib/DerivedConstants.h ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs ghc-lib/stage0/lib/GHCConstantsHaskellType.hs ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl ghc-lib/stage0/compiler/build/primop-code-size.hs-incl ghc-lib/stage0/compiler/build/primop-commutable.hs-incl ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl ghc-lib/stage0/compiler/build/primop-fixity.hs-incl ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl ghc-lib/stage0/compiler/build/primop-list.hs-incl ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl ghc-lib/stage0/compiler/build/primop-strictness.hs-incl ghc-lib/stage0/compiler/build/primop-tag.hs-incl ghc-lib/stage0/compiler/build/primop-vector-tycons.hs-incl ghc-lib/stage0/compiler/build/primop-vector-tys-exports.hs-incl ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl ghc-lib/stage0/compiler/build/Config.hs ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs ghc-lib/stage0/compiler/build/Parser.hs ghc-lib/stage0/compiler/build/Lexer.hs includes/ghcconfig.h includes/MachDeps.h includes/stg/MachRegs.h includes/CodeGen.Platform.hs compiler/GhclibHsVersions.h compiler/Unique.h source-repository head type: git location: git@github.com:digital-asset/ghc-lib.git library default-language: Haskell2010 default-extensions: NoImplicitPrelude exposed: False include-dirs: includes ghc-lib/stage0/lib ghc-lib/stage0/compiler/build compiler ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS cc-options: -DTHREADED_RTS cpp-options: -DTHREADED_RTS -DGHC_IN_GHCI if !os(windows) build-depends: unix else build-depends: Win32 build-depends: ghc-prim > 0.2 && < 0.7, base >= 4.12 && < 4.15, containers >= 0.5 && < 0.7, bytestring >= 0.9 && < 0.11, binary == 0.8.*, filepath >= 1 && < 1.5, directory >= 1 && < 1.4, array >= 0.1 && < 0.6, deepseq >= 1.4 && < 1.5, pretty == 1.1.*, time >= 1.4 && < 1.10, transformers == 0.5.*, process >= 1 && < 1.7, hpc == 0.6.* build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns CPP DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DisambiguateRecordFields ExistentialQuantification ExplicitForAll FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs MagicHash MultiParamTypeClasses NamedFieldPuns NondecreasingIndentation RankNTypes RecordWildCards RoleAnnotations ScopedTypeVariables StandaloneDeriving Trustworthy TupleSections TypeFamilies TypeSynonymInstances UnboxedTuples UndecidableInstances c-sources: libraries/ghc-heap/cbits/HeapPrim.cmm compiler/cbits/genSym.c compiler/parser/cutils.c hs-source-dirs: ghc-lib/stage0/libraries/ghc-boot/build ghc-lib/stage0/compiler/build libraries/template-haskell libraries/ghc-boot-th compiler/basicTypes compiler/specialise compiler/profiling compiler/simplCore compiler/typecheck libraries/ghc-boot libraries/ghc-heap compiler/backpack compiler/simplStg compiler/coreSyn compiler/prelude compiler/parser compiler/iface compiler/types compiler/utils libraries/ghci compiler/ghci compiler/main compiler/cmm compiler/. compiler autogen-modules: Lexer Parser exposed-modules: Annotations ApiAnnotation Avail Bag BasicTypes BinFingerprint Binary BkpSyn BooleanFormula BufWrite ByteCodeTypes Class CliOption CmdLineParser CmmType CoAxiom Coercion ConLike Config Constants Constraint CoreArity CoreFVs CoreMap CoreMonad CoreOpt CoreSeq CoreStats CoreSubst CoreSyn CoreTidy CoreUnfold CoreUtils CostCentre CostCentreState Ctype DataCon Demand Digraph DriverPhases DynFlags Encoding EnumSet ErrUtils Exception FV FamInstEnv FastFunctions FastMutInt FastString FastStringEnv FieldLabel FileCleanup FileSettings Fingerprint FiniteMap ForeignCall GHC.BaseDir GHC.Exts.Heap GHC.Exts.Heap.ClosureTypes GHC.Exts.Heap.Closures GHC.Exts.Heap.Constants GHC.Exts.Heap.InfoTable GHC.Exts.Heap.InfoTable.Types GHC.Exts.Heap.InfoTableProf GHC.Exts.Heap.Utils GHC.ForeignSrcLang GHC.ForeignSrcLang.Type GHC.Hs GHC.Hs.Binds GHC.Hs.Decls GHC.Hs.Doc GHC.Hs.Dump GHC.Hs.Expr GHC.Hs.Extension GHC.Hs.ImpExp GHC.Hs.Instances GHC.Hs.Lit GHC.Hs.Pat GHC.Hs.PlaceHolder GHC.Hs.Types GHC.Hs.Utils GHC.HsToCore.PmCheck.Types GHC.LanguageExtensions GHC.LanguageExtensions.Type GHC.Lexeme GHC.PackageDb GHC.Platform GHC.Serialized GHC.UniqueSubdir GHC.Version GHCi.BreakArray GHCi.FFI GHCi.Message GHCi.RemoteTypes GHCi.TH.Binary GhcMonad GhcNameVersion GhcPrelude HaddockUtils HeaderInfo Hooks HscTypes IOEnv Id IdInfo IfaceSyn IfaceType InstEnv InteractiveEvalTypes Json KnownUniques Language.Haskell.TH Language.Haskell.TH.LanguageExtensions Language.Haskell.TH.Lib Language.Haskell.TH.Lib.Internal Language.Haskell.TH.Lib.Map Language.Haskell.TH.Ppr Language.Haskell.TH.PprLib Language.Haskell.TH.Syntax Lexeme Lexer LinkerTypes ListSetOps Literal Maybes MkCore MkId Module MonadUtils Name NameCache NameEnv NameSet OccName OccurAnal OptCoercion OrdList Outputable PackageConfig Packages Pair Panic Parser PatSyn PipelineMonad PlainPanic PlatformConstants Plugins PprColour PprCore Predicate PrelNames PrelRules Pretty PrimOp RdrHsSyn RdrName RepType Rules Settings SizedSeq SrcLoc StringBuffer SysTools.BaseDir SysTools.Terminal TcEvidence TcHoleFitTypes TcOrigin TcRnTypes TcType ToIface ToolSettings TrieMap TyCoFVs TyCoPpr TyCoRep TyCoSubst TyCoTidy TyCon Type TysPrim TysWiredIn Unify UniqDFM UniqDSet UniqFM UniqSet UniqSupply Unique Util Var VarEnv VarSet ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/lib/ghcautoconf.h0000644000000000000000000003516713713636006021421 0ustar0000000000000000#if !defined(__GHCAUTOCONF_H__) #define __GHCAUTOCONF_H__ /* mk/config.h. Generated from config.h.in by configure. */ /* mk/config.h.in. Generated from configure.ac by autoheader. */ /* Define if building universal (internal helper macro) */ /* #undef AC_APPLE_UNIVERSAL_BUILD */ /* The alignment of a `char'. */ #define ALIGNMENT_CHAR 1 /* The alignment of a `double'. */ #define ALIGNMENT_DOUBLE 8 /* The alignment of a `float'. */ #define ALIGNMENT_FLOAT 4 /* The alignment of a `int'. */ #define ALIGNMENT_INT 4 /* The alignment of a `int16_t'. */ #define ALIGNMENT_INT16_T 2 /* The alignment of a `int32_t'. */ #define ALIGNMENT_INT32_T 4 /* The alignment of a `int64_t'. */ #define ALIGNMENT_INT64_T 8 /* The alignment of a `int8_t'. */ #define ALIGNMENT_INT8_T 1 /* The alignment of a `long'. */ #define ALIGNMENT_LONG 8 /* The alignment of a `long long'. */ #define ALIGNMENT_LONG_LONG 8 /* The alignment of a `short'. */ #define ALIGNMENT_SHORT 2 /* The alignment of a `uint16_t'. */ #define ALIGNMENT_UINT16_T 2 /* The alignment of a `uint32_t'. */ #define ALIGNMENT_UINT32_T 4 /* The alignment of a `uint64_t'. */ #define ALIGNMENT_UINT64_T 8 /* The alignment of a `uint8_t'. */ #define ALIGNMENT_UINT8_T 1 /* The alignment of a `unsigned char'. */ #define ALIGNMENT_UNSIGNED_CHAR 1 /* The alignment of a `unsigned int'. */ #define ALIGNMENT_UNSIGNED_INT 4 /* The alignment of a `unsigned long'. */ #define ALIGNMENT_UNSIGNED_LONG 8 /* The alignment of a `unsigned long long'. */ #define ALIGNMENT_UNSIGNED_LONG_LONG 8 /* The alignment of a `unsigned short'. */ #define ALIGNMENT_UNSIGNED_SHORT 2 /* The alignment of a `void *'. */ #define ALIGNMENT_VOID_P 8 /* Define (to 1) if C compiler has an LLVM back end */ #define CC_LLVM_BACKEND 1 /* Define to 1 if __thread is supported */ #define CC_SUPPORTS_TLS 1 /* Define to one of `_getb67', `GETB67', `getb67' for Cray-2 and Cray-YMP systems. This function is required for `alloca.c' support on those systems. */ /* #undef CRAY_STACKSEG_END */ /* Define to 1 if using `alloca.c'. */ /* #undef C_ALLOCA */ /* Define to 1 if your processor stores words of floats with the most significant byte first */ /* #undef FLOAT_WORDS_BIGENDIAN */ /* Has visibility hidden */ #define HAS_VISIBILITY_HIDDEN 1 /* Define to 1 if you have `alloca', as a function or macro. */ #define HAVE_ALLOCA 1 /* Define to 1 if you have and it should be used (not on Ultrix). */ #define HAVE_ALLOCA_H 1 /* Define to 1 if you have the header file. */ /* #undef HAVE_BFD_H */ /* Does GCC support __atomic primitives? */ #define HAVE_C11_ATOMICS 1 /* Define to 1 if you have the `clock_gettime' function. */ #define HAVE_CLOCK_GETTIME 1 /* Define to 1 if you have the `ctime_r' function. */ #define HAVE_CTIME_R 1 /* Define to 1 if you have the header file. */ #define HAVE_CTYPE_H 1 /* Define to 1 if you have the declaration of `ctime_r', and to 0 if you don't. */ #define HAVE_DECL_CTIME_R 1 /* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you don't. */ /* #undef HAVE_DECL_MADV_DONTNEED */ /* Define to 1 if you have the declaration of `MADV_FREE', and to 0 if you don't. */ /* #undef HAVE_DECL_MADV_FREE */ /* Define to 1 if you have the declaration of `MAP_NORESERVE', and to 0 if you don't. */ /* #undef HAVE_DECL_MAP_NORESERVE */ /* Define to 1 if you have the header file. */ #define HAVE_DIRENT_H 1 /* Define to 1 if you have the header file. */ #define HAVE_DLFCN_H 1 /* Define to 1 if you have the header file. */ /* #undef HAVE_ELFUTILS_LIBDW_H */ /* Define to 1 if you have the header file. */ #define HAVE_ERRNO_H 1 /* Define to 1 if you have the `eventfd' function. */ /* #undef HAVE_EVENTFD */ /* Define to 1 if you have the header file. */ #define HAVE_FCNTL_H 1 /* Define to 1 if you have the header file. */ /* #undef HAVE_FFI_H */ /* Define to 1 if you have the `fork' function. */ #define HAVE_FORK 1 /* Define to 1 if you have the `getclock' function. */ /* #undef HAVE_GETCLOCK */ /* Define to 1 if you have the `GetModuleFileName' function. */ /* #undef HAVE_GETMODULEFILENAME */ /* Define to 1 if you have the `getrusage' function. */ #define HAVE_GETRUSAGE 1 /* Define to 1 if you have the `gettimeofday' function. */ #define HAVE_GETTIMEOFDAY 1 /* Define to 1 if you have the header file. */ #define HAVE_GRP_H 1 /* Define to 1 if you have the header file. */ #define HAVE_INTTYPES_H 1 /* Define to 1 if you have the `bfd' library (-lbfd). */ /* #undef HAVE_LIBBFD */ /* Define to 1 if you have the `dl' library (-ldl). */ #define HAVE_LIBDL 1 /* Define to 1 if you have libffi. */ /* #undef HAVE_LIBFFI */ /* Define to 1 if you have the `iberty' library (-liberty). */ /* #undef HAVE_LIBIBERTY */ /* Define to 1 if you need to link with libm */ #define HAVE_LIBM 1 /* Define to 1 if you have libnuma */ #define HAVE_LIBNUMA 0 /* Define to 1 if you have the `pthread' library (-lpthread). */ #define HAVE_LIBPTHREAD 1 /* Define to 1 if you have the `rt' library (-lrt). */ /* #undef HAVE_LIBRT */ /* Define to 1 if you have the header file. */ #define HAVE_LIMITS_H 1 /* Define to 1 if you have the header file. */ #define HAVE_LOCALE_H 1 /* Define to 1 if the system has the type `long long'. */ #define HAVE_LONG_LONG 1 /* Define to 1 if you have the header file. */ #define HAVE_MEMORY_H 1 /* Define to 1 if you have the mingwex library. */ /* #undef HAVE_MINGWEX */ /* Define to 1 if you have the header file. */ #define HAVE_NLIST_H 1 /* Define to 1 if you have the header file. */ /* #undef HAVE_NUMAIF_H */ /* Define to 1 if you have the header file. */ /* #undef HAVE_NUMA_H */ /* Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC). */ #define HAVE_PRINTF_LDBLSTUB 0 /* Define to 1 if you have the header file. */ #define HAVE_PTHREAD_H 1 /* Define to 1 if you have the glibc version of pthread_setname_np */ /* #undef HAVE_PTHREAD_SETNAME_NP */ /* Define to 1 if you have the header file. */ #define HAVE_PWD_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SCHED_H 1 /* Define to 1 if you have the `sched_setaffinity' function. */ /* #undef HAVE_SCHED_SETAFFINITY */ /* Define to 1 if you have the `setitimer' function. */ #define HAVE_SETITIMER 1 /* Define to 1 if you have the `setlocale' function. */ #define HAVE_SETLOCALE 1 /* Define to 1 if you have the `siginterrupt' function. */ #define HAVE_SIGINTERRUPT 1 /* Define to 1 if you have the header file. */ #define HAVE_SIGNAL_H 1 /* Define to 1 if you have the header file. */ #define HAVE_STDINT_H 1 /* Define to 1 if you have the header file. */ #define HAVE_STDLIB_H 1 /* Define to 1 if you have the header file. */ #define HAVE_STRINGS_H 1 /* Define to 1 if you have the header file. */ #define HAVE_STRING_H 1 /* Define to 1 if Apple-style dead-stripping is supported. */ #define HAVE_SUBSECTIONS_VIA_SYMBOLS 1 /* Define to 1 if you have the `sysconf' function. */ #define HAVE_SYSCONF 1 /* Define to 1 if you have the header file. */ /* #undef HAVE_SYS_CPUSET_H */ /* Define to 1 if you have the header file. */ /* #undef HAVE_SYS_EVENTFD_H */ /* Define to 1 if you have the header file. */ #define HAVE_SYS_MMAN_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_PARAM_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_RESOURCE_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_SELECT_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_STAT_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_TIMEB_H 1 /* Define to 1 if you have the header file. */ /* #undef HAVE_SYS_TIMERFD_H */ /* Define to 1 if you have the header file. */ /* #undef HAVE_SYS_TIMERS_H */ /* Define to 1 if you have the header file. */ #define HAVE_SYS_TIMES_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_TIME_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_TYPES_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_UTSNAME_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_WAIT_H 1 /* Define to 1 if you have the header file. */ #define HAVE_TERMIOS_H 1 /* Define to 1 if you have the `timer_settime' function. */ /* #undef HAVE_TIMER_SETTIME */ /* Define to 1 if you have the `times' function. */ #define HAVE_TIMES 1 /* Define to 1 if you have the header file. */ #define HAVE_TIME_H 1 /* Define to 1 if you have the header file. */ #define HAVE_UNISTD_H 1 /* Define to 1 if you have the header file. */ #define HAVE_UTIME_H 1 /* Define to 1 if you have the `vfork' function. */ #define HAVE_VFORK 1 /* Define to 1 if you have the header file. */ /* #undef HAVE_VFORK_H */ /* Define to 1 if you have the header file. */ /* #undef HAVE_WINDOWS_H */ /* Define to 1 if you have the `WinExec' function. */ /* #undef HAVE_WINEXEC */ /* Define to 1 if you have the header file. */ /* #undef HAVE_WINSOCK_H */ /* Define to 1 if `fork' works. */ #define HAVE_WORKING_FORK 1 /* Define to 1 if `vfork' works. */ #define HAVE_WORKING_VFORK 1 /* Define to 1 if C symbols have a leading underscore added by the compiler. */ #define LEADING_UNDERSCORE 1 /* Define 1 if we need to link code using pthreads with -lpthread */ #define NEED_PTHREAD_LIB 0 /* Define to the address where bug reports for this package should be sent. */ /* #undef PACKAGE_BUGREPORT */ /* Define to the full name of this package. */ /* #undef PACKAGE_NAME */ /* Define to the full name and version of this package. */ /* #undef PACKAGE_STRING */ /* Define to the one symbol short name of this package. */ /* #undef PACKAGE_TARNAME */ /* Define to the home page for this package. */ /* #undef PACKAGE_URL */ /* Define to the version of this package. */ /* #undef PACKAGE_VERSION */ /* Use mmap in the runtime linker */ #define RTS_LINKER_USE_MMAP 1 /* The size of `char', as computed by sizeof. */ #define SIZEOF_CHAR 1 /* The size of `double', as computed by sizeof. */ #define SIZEOF_DOUBLE 8 /* The size of `float', as computed by sizeof. */ #define SIZEOF_FLOAT 4 /* The size of `int', as computed by sizeof. */ #define SIZEOF_INT 4 /* The size of `int16_t', as computed by sizeof. */ #define SIZEOF_INT16_T 2 /* The size of `int32_t', as computed by sizeof. */ #define SIZEOF_INT32_T 4 /* The size of `int64_t', as computed by sizeof. */ #define SIZEOF_INT64_T 8 /* The size of `int8_t', as computed by sizeof. */ #define SIZEOF_INT8_T 1 /* The size of `long', as computed by sizeof. */ #define SIZEOF_LONG 8 /* The size of `long long', as computed by sizeof. */ #define SIZEOF_LONG_LONG 8 /* The size of `short', as computed by sizeof. */ #define SIZEOF_SHORT 2 /* The size of `uint16_t', as computed by sizeof. */ #define SIZEOF_UINT16_T 2 /* The size of `uint32_t', as computed by sizeof. */ #define SIZEOF_UINT32_T 4 /* The size of `uint64_t', as computed by sizeof. */ #define SIZEOF_UINT64_T 8 /* The size of `uint8_t', as computed by sizeof. */ #define SIZEOF_UINT8_T 1 /* The size of `unsigned char', as computed by sizeof. */ #define SIZEOF_UNSIGNED_CHAR 1 /* The size of `unsigned int', as computed by sizeof. */ #define SIZEOF_UNSIGNED_INT 4 /* The size of `unsigned long', as computed by sizeof. */ #define SIZEOF_UNSIGNED_LONG 8 /* The size of `unsigned long long', as computed by sizeof. */ #define SIZEOF_UNSIGNED_LONG_LONG 8 /* The size of `unsigned short', as computed by sizeof. */ #define SIZEOF_UNSIGNED_SHORT 2 /* The size of `void *', as computed by sizeof. */ #define SIZEOF_VOID_P 8 /* If using the C implementation of alloca, define if you know the direction of stack growth for your system; otherwise it will be automatically deduced at runtime. STACK_DIRECTION > 0 => grows toward higher addresses STACK_DIRECTION < 0 => grows toward lower addresses STACK_DIRECTION = 0 => direction of growth unknown */ /* #undef STACK_DIRECTION */ /* Define to 1 if you have the ANSI C header files. */ #define STDC_HEADERS 1 /* Define to 1 if info tables are layed out next to code */ #define TABLES_NEXT_TO_CODE 1 /* Define to 1 if you can safely include both and . */ #define TIME_WITH_SYS_TIME 1 /* Enable single heap address space support */ #define USE_LARGE_ADDRESS_SPACE 1 /* Set to 1 to use libdw */ #define USE_LIBDW 0 /* Enable extensions on AIX 3, Interix. */ #ifndef _ALL_SOURCE # define _ALL_SOURCE 1 #endif /* Enable GNU extensions on systems that have them. */ #ifndef _GNU_SOURCE # define _GNU_SOURCE 1 #endif /* Enable threading extensions on Solaris. */ #ifndef _POSIX_PTHREAD_SEMANTICS # define _POSIX_PTHREAD_SEMANTICS 1 #endif /* Enable extensions on HP NonStop. */ #ifndef _TANDEM_SOURCE # define _TANDEM_SOURCE 1 #endif /* Enable general extensions on Solaris. */ #ifndef __EXTENSIONS__ # define __EXTENSIONS__ 1 #endif /* Define to 1 if we can use timer_create(CLOCK_REALTIME,...) */ /* #undef USE_TIMER_CREATE */ /* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most significant byte first (like Motorola and SPARC, unlike Intel). */ #if defined AC_APPLE_UNIVERSAL_BUILD # if defined __BIG_ENDIAN__ # define WORDS_BIGENDIAN 1 # endif #else # ifndef WORDS_BIGENDIAN /* # undef WORDS_BIGENDIAN */ # endif #endif /* Enable large inode numbers on Mac OS X 10.5. */ #ifndef _DARWIN_USE_64_BIT_INODE # define _DARWIN_USE_64_BIT_INODE 1 #endif /* Number of bits in a file offset, on hosts where this is settable. */ /* #undef _FILE_OFFSET_BITS */ /* Define for large files, on AIX-style hosts. */ /* #undef _LARGE_FILES */ /* Define to 1 if on MINIX. */ /* #undef _MINIX */ /* Define to 2 if the system does not provide POSIX.1 features except with this defined. */ /* #undef _POSIX_1_SOURCE */ /* Define to 1 if you need to in order for `stat' and other things to work. */ /* #undef _POSIX_SOURCE */ /* ARM pre v6 */ /* #undef arm_HOST_ARCH_PRE_ARMv6 */ /* ARM pre v7 */ /* #undef arm_HOST_ARCH_PRE_ARMv7 */ /* Define to empty if `const' does not conform to ANSI C. */ /* #undef const */ /* Define to `int' if does not define. */ /* #undef pid_t */ /* The supported LLVM version number */ #define sUPPORTED_LLVM_VERSION (9) /* Define to `unsigned int' if does not define. */ /* #undef size_t */ /* Define as `fork' if `vfork' does not work. */ /* #undef vfork */ #endif /* __GHCAUTOCONF_H__ */ ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/lib/ghcplatform.h0000644000000000000000000000114213713636006021411 0ustar0000000000000000#if !defined(__GHCPLATFORM_H__) #define __GHCPLATFORM_H__ #define GHC_STAGE 1 #define BuildPlatform_TYPE x86_64_apple_darwin #define HostPlatform_TYPE x86_64_apple_darwin #define x86_64_apple_darwin_BUILD 1 #define x86_64_apple_darwin_HOST 1 #define x86_64_BUILD_ARCH 1 #define x86_64_HOST_ARCH 1 #define BUILD_ARCH "x86_64" #define HOST_ARCH "x86_64" #define darwin_BUILD_OS 1 #define darwin_HOST_OS 1 #define BUILD_OS "darwin" #define HOST_OS "darwin" #define apple_BUILD_VENDOR 1 #define apple_HOST_VENDOR 1 #define BUILD_VENDOR "apple" #define HOST_VENDOR "apple" #endif /* __GHCPLATFORM_H__ */ ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/lib/ghcversion.h0000644000000000000000000000107413713636006021256 0ustar0000000000000000#if !defined(__GHCVERSION_H__) #define __GHCVERSION_H__ #if !defined(__GLASGOW_HASKELL__) # define __GLASGOW_HASKELL__ 810 #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 2 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \ ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \ && (pl1) < __GLASGOW_HASKELL_PATCHLEVEL1__ || \ ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \ && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__ \ && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ ) #endif /* __GHCVERSION_H__ */ ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/lib/DerivedConstants.h0000644000000000000000000007516513713636030022377 0ustar0000000000000000/* This file is created automatically. Do not edit by hand.*/ #define CONTROL_GROUP_CONST_291 291 #define STD_HDR_SIZE 1 #define PROF_HDR_SIZE 2 #define STACK_DIRTY 1 #define BLOCK_SIZE 4096 #define MBLOCK_SIZE 1048576 #define BLOCKS_PER_MBLOCK 252 #define TICKY_BIN_COUNT 9 #define OFFSET_StgRegTable_rR1 0 #define OFFSET_StgRegTable_rR2 8 #define OFFSET_StgRegTable_rR3 16 #define OFFSET_StgRegTable_rR4 24 #define OFFSET_StgRegTable_rR5 32 #define OFFSET_StgRegTable_rR6 40 #define OFFSET_StgRegTable_rR7 48 #define OFFSET_StgRegTable_rR8 56 #define OFFSET_StgRegTable_rR9 64 #define OFFSET_StgRegTable_rR10 72 #define OFFSET_StgRegTable_rF1 80 #define OFFSET_StgRegTable_rF2 84 #define OFFSET_StgRegTable_rF3 88 #define OFFSET_StgRegTable_rF4 92 #define OFFSET_StgRegTable_rF5 96 #define OFFSET_StgRegTable_rF6 100 #define OFFSET_StgRegTable_rD1 104 #define OFFSET_StgRegTable_rD2 112 #define OFFSET_StgRegTable_rD3 120 #define OFFSET_StgRegTable_rD4 128 #define OFFSET_StgRegTable_rD5 136 #define OFFSET_StgRegTable_rD6 144 #define OFFSET_StgRegTable_rXMM1 152 #define OFFSET_StgRegTable_rXMM2 168 #define OFFSET_StgRegTable_rXMM3 184 #define OFFSET_StgRegTable_rXMM4 200 #define OFFSET_StgRegTable_rXMM5 216 #define OFFSET_StgRegTable_rXMM6 232 #define OFFSET_StgRegTable_rYMM1 248 #define OFFSET_StgRegTable_rYMM2 280 #define OFFSET_StgRegTable_rYMM3 312 #define OFFSET_StgRegTable_rYMM4 344 #define OFFSET_StgRegTable_rYMM5 376 #define OFFSET_StgRegTable_rYMM6 408 #define OFFSET_StgRegTable_rZMM1 440 #define OFFSET_StgRegTable_rZMM2 504 #define OFFSET_StgRegTable_rZMM3 568 #define OFFSET_StgRegTable_rZMM4 632 #define OFFSET_StgRegTable_rZMM5 696 #define OFFSET_StgRegTable_rZMM6 760 #define OFFSET_StgRegTable_rL1 824 #define OFFSET_StgRegTable_rSp 832 #define OFFSET_StgRegTable_rSpLim 840 #define OFFSET_StgRegTable_rHp 848 #define OFFSET_StgRegTable_rHpLim 856 #define OFFSET_StgRegTable_rCCCS 864 #define OFFSET_StgRegTable_rCurrentTSO 872 #define OFFSET_StgRegTable_rCurrentNursery 888 #define OFFSET_StgRegTable_rHpAlloc 904 #define OFFSET_StgRegTable_rRet 912 #define REP_StgRegTable_rRet b64 #define StgRegTable_rRet(__ptr__) REP_StgRegTable_rRet[__ptr__+OFFSET_StgRegTable_rRet] #define OFFSET_StgRegTable_rNursery 880 #define REP_StgRegTable_rNursery b64 #define StgRegTable_rNursery(__ptr__) REP_StgRegTable_rNursery[__ptr__+OFFSET_StgRegTable_rNursery] #define OFFSET_stgEagerBlackholeInfo -24 #define OFFSET_stgGCEnter1 -16 #define OFFSET_stgGCFun -8 #define OFFSET_Capability_r 24 #define OFFSET_Capability_lock 1208 #define OFFSET_Capability_no 944 #define REP_Capability_no b32 #define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no] #define OFFSET_Capability_mut_lists 1016 #define REP_Capability_mut_lists b64 #define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists] #define OFFSET_Capability_context_switch 1176 #define REP_Capability_context_switch b32 #define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch] #define OFFSET_Capability_interrupt 1180 #define REP_Capability_interrupt b32 #define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt] #define OFFSET_Capability_sparks 1312 #define REP_Capability_sparks b64 #define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks] #define OFFSET_Capability_total_allocated 1184 #define REP_Capability_total_allocated b64 #define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated] #define OFFSET_Capability_weak_ptr_list_hd 1160 #define REP_Capability_weak_ptr_list_hd b64 #define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd] #define OFFSET_Capability_weak_ptr_list_tl 1168 #define REP_Capability_weak_ptr_list_tl b64 #define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl] #define OFFSET_bdescr_start 0 #define REP_bdescr_start b64 #define bdescr_start(__ptr__) REP_bdescr_start[__ptr__+OFFSET_bdescr_start] #define OFFSET_bdescr_free 8 #define REP_bdescr_free b64 #define bdescr_free(__ptr__) REP_bdescr_free[__ptr__+OFFSET_bdescr_free] #define OFFSET_bdescr_blocks 48 #define REP_bdescr_blocks b32 #define bdescr_blocks(__ptr__) REP_bdescr_blocks[__ptr__+OFFSET_bdescr_blocks] #define OFFSET_bdescr_gen_no 40 #define REP_bdescr_gen_no b16 #define bdescr_gen_no(__ptr__) REP_bdescr_gen_no[__ptr__+OFFSET_bdescr_gen_no] #define OFFSET_bdescr_link 16 #define REP_bdescr_link b64 #define bdescr_link(__ptr__) REP_bdescr_link[__ptr__+OFFSET_bdescr_link] #define OFFSET_bdescr_flags 46 #define REP_bdescr_flags b16 #define bdescr_flags(__ptr__) REP_bdescr_flags[__ptr__+OFFSET_bdescr_flags] #define SIZEOF_generation 384 #define OFFSET_generation_n_new_large_words 56 #define REP_generation_n_new_large_words b64 #define generation_n_new_large_words(__ptr__) REP_generation_n_new_large_words[__ptr__+OFFSET_generation_n_new_large_words] #define OFFSET_generation_weak_ptr_list 112 #define REP_generation_weak_ptr_list b64 #define generation_weak_ptr_list(__ptr__) REP_generation_weak_ptr_list[__ptr__+OFFSET_generation_weak_ptr_list] #define SIZEOF_CostCentreStack 96 #define OFFSET_CostCentreStack_ccsID 0 #define REP_CostCentreStack_ccsID b64 #define CostCentreStack_ccsID(__ptr__) REP_CostCentreStack_ccsID[__ptr__+OFFSET_CostCentreStack_ccsID] #define OFFSET_CostCentreStack_mem_alloc 72 #define REP_CostCentreStack_mem_alloc b64 #define CostCentreStack_mem_alloc(__ptr__) REP_CostCentreStack_mem_alloc[__ptr__+OFFSET_CostCentreStack_mem_alloc] #define OFFSET_CostCentreStack_scc_count 48 #define REP_CostCentreStack_scc_count b64 #define CostCentreStack_scc_count(__ptr__) REP_CostCentreStack_scc_count[__ptr__+OFFSET_CostCentreStack_scc_count] #define OFFSET_CostCentreStack_prevStack 16 #define REP_CostCentreStack_prevStack b64 #define CostCentreStack_prevStack(__ptr__) REP_CostCentreStack_prevStack[__ptr__+OFFSET_CostCentreStack_prevStack] #define OFFSET_CostCentre_ccID 0 #define REP_CostCentre_ccID b64 #define CostCentre_ccID(__ptr__) REP_CostCentre_ccID[__ptr__+OFFSET_CostCentre_ccID] #define OFFSET_CostCentre_link 56 #define REP_CostCentre_link b64 #define CostCentre_link(__ptr__) REP_CostCentre_link[__ptr__+OFFSET_CostCentre_link] #define OFFSET_StgHeader_info 0 #define REP_StgHeader_info b64 #define StgHeader_info(__ptr__) REP_StgHeader_info[__ptr__+OFFSET_StgHeader_info] #define OFFSET_StgHeader_ccs 8 #define REP_StgHeader_ccs b64 #define StgHeader_ccs(__ptr__) REP_StgHeader_ccs[__ptr__+OFFSET_StgHeader_ccs] #define OFFSET_StgHeader_ldvw 16 #define REP_StgHeader_ldvw b64 #define StgHeader_ldvw(__ptr__) REP_StgHeader_ldvw[__ptr__+OFFSET_StgHeader_ldvw] #define SIZEOF_StgSMPThunkHeader 8 #define OFFSET_StgClosure_payload 0 #define StgClosure_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgClosure_payload + WDS(__ix__)] #define OFFSET_StgEntCounter_allocs 48 #define REP_StgEntCounter_allocs b64 #define StgEntCounter_allocs(__ptr__) REP_StgEntCounter_allocs[__ptr__+OFFSET_StgEntCounter_allocs] #define OFFSET_StgEntCounter_allocd 16 #define REP_StgEntCounter_allocd b64 #define StgEntCounter_allocd(__ptr__) REP_StgEntCounter_allocd[__ptr__+OFFSET_StgEntCounter_allocd] #define OFFSET_StgEntCounter_registeredp 0 #define REP_StgEntCounter_registeredp b64 #define StgEntCounter_registeredp(__ptr__) REP_StgEntCounter_registeredp[__ptr__+OFFSET_StgEntCounter_registeredp] #define OFFSET_StgEntCounter_link 56 #define REP_StgEntCounter_link b64 #define StgEntCounter_link(__ptr__) REP_StgEntCounter_link[__ptr__+OFFSET_StgEntCounter_link] #define OFFSET_StgEntCounter_entry_count 40 #define REP_StgEntCounter_entry_count b64 #define StgEntCounter_entry_count(__ptr__) REP_StgEntCounter_entry_count[__ptr__+OFFSET_StgEntCounter_entry_count] #define SIZEOF_StgUpdateFrame_NoHdr 8 #define SIZEOF_StgUpdateFrame (SIZEOF_StgHeader+8) #define SIZEOF_StgCatchFrame_NoHdr 16 #define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16) #define SIZEOF_StgStopFrame_NoHdr 0 #define SIZEOF_StgStopFrame (SIZEOF_StgHeader+0) #define SIZEOF_StgMutArrPtrs_NoHdr 16 #define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16) #define OFFSET_StgMutArrPtrs_ptrs 0 #define REP_StgMutArrPtrs_ptrs b64 #define StgMutArrPtrs_ptrs(__ptr__) REP_StgMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_ptrs] #define OFFSET_StgMutArrPtrs_size 8 #define REP_StgMutArrPtrs_size b64 #define StgMutArrPtrs_size(__ptr__) REP_StgMutArrPtrs_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_size] #define SIZEOF_StgSmallMutArrPtrs_NoHdr 8 #define SIZEOF_StgSmallMutArrPtrs (SIZEOF_StgHeader+8) #define OFFSET_StgSmallMutArrPtrs_ptrs 0 #define REP_StgSmallMutArrPtrs_ptrs b64 #define StgSmallMutArrPtrs_ptrs(__ptr__) REP_StgSmallMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgSmallMutArrPtrs_ptrs] #define SIZEOF_StgArrBytes_NoHdr 8 #define SIZEOF_StgArrBytes (SIZEOF_StgHeader+8) #define OFFSET_StgArrBytes_bytes 0 #define REP_StgArrBytes_bytes b64 #define StgArrBytes_bytes(__ptr__) REP_StgArrBytes_bytes[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_bytes] #define OFFSET_StgArrBytes_payload 8 #define StgArrBytes_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_payload + WDS(__ix__)] #define OFFSET_StgTSO__link 0 #define REP_StgTSO__link b64 #define StgTSO__link(__ptr__) REP_StgTSO__link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO__link] #define OFFSET_StgTSO_global_link 8 #define REP_StgTSO_global_link b64 #define StgTSO_global_link(__ptr__) REP_StgTSO_global_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_global_link] #define OFFSET_StgTSO_what_next 24 #define REP_StgTSO_what_next b16 #define StgTSO_what_next(__ptr__) REP_StgTSO_what_next[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_what_next] #define OFFSET_StgTSO_why_blocked 26 #define REP_StgTSO_why_blocked b16 #define StgTSO_why_blocked(__ptr__) REP_StgTSO_why_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_why_blocked] #define OFFSET_StgTSO_block_info 32 #define REP_StgTSO_block_info b64 #define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info] #define OFFSET_StgTSO_blocked_exceptions 80 #define REP_StgTSO_blocked_exceptions b64 #define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions] #define OFFSET_StgTSO_id 40 #define REP_StgTSO_id b32 #define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id] #define OFFSET_StgTSO_cap 64 #define REP_StgTSO_cap b64 #define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap] #define OFFSET_StgTSO_saved_errno 44 #define REP_StgTSO_saved_errno b32 #define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno] #define OFFSET_StgTSO_trec 72 #define REP_StgTSO_trec b64 #define StgTSO_trec(__ptr__) REP_StgTSO_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_trec] #define OFFSET_StgTSO_flags 28 #define REP_StgTSO_flags b32 #define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags] #define OFFSET_StgTSO_dirty 48 #define REP_StgTSO_dirty b32 #define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty] #define OFFSET_StgTSO_bq 88 #define REP_StgTSO_bq b64 #define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq] #define OFFSET_StgTSO_alloc_limit 96 #define REP_StgTSO_alloc_limit b64 #define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit] #define OFFSET_StgTSO_cccs 112 #define REP_StgTSO_cccs b64 #define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs] #define OFFSET_StgTSO_stackobj 16 #define REP_StgTSO_stackobj b64 #define StgTSO_stackobj(__ptr__) REP_StgTSO_stackobj[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_stackobj] #define OFFSET_StgStack_sp 8 #define REP_StgStack_sp b64 #define StgStack_sp(__ptr__) REP_StgStack_sp[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_sp] #define OFFSET_StgStack_stack 16 #define OFFSET_StgStack_stack_size 0 #define REP_StgStack_stack_size b32 #define StgStack_stack_size(__ptr__) REP_StgStack_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_stack_size] #define OFFSET_StgStack_dirty 4 #define REP_StgStack_dirty b8 #define StgStack_dirty(__ptr__) REP_StgStack_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_dirty] #define SIZEOF_StgTSOProfInfo 8 #define OFFSET_StgUpdateFrame_updatee 0 #define REP_StgUpdateFrame_updatee b64 #define StgUpdateFrame_updatee(__ptr__) REP_StgUpdateFrame_updatee[__ptr__+SIZEOF_StgHeader+OFFSET_StgUpdateFrame_updatee] #define OFFSET_StgCatchFrame_handler 8 #define REP_StgCatchFrame_handler b64 #define StgCatchFrame_handler(__ptr__) REP_StgCatchFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_handler] #define OFFSET_StgCatchFrame_exceptions_blocked 0 #define REP_StgCatchFrame_exceptions_blocked b64 #define StgCatchFrame_exceptions_blocked(__ptr__) REP_StgCatchFrame_exceptions_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_exceptions_blocked] #define SIZEOF_StgPAP_NoHdr 16 #define SIZEOF_StgPAP (SIZEOF_StgHeader+16) #define OFFSET_StgPAP_n_args 4 #define REP_StgPAP_n_args b32 #define StgPAP_n_args(__ptr__) REP_StgPAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_n_args] #define OFFSET_StgPAP_fun 8 #define REP_StgPAP_fun gcptr #define StgPAP_fun(__ptr__) REP_StgPAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_fun] #define OFFSET_StgPAP_arity 0 #define REP_StgPAP_arity b32 #define StgPAP_arity(__ptr__) REP_StgPAP_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_arity] #define OFFSET_StgPAP_payload 16 #define StgPAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_payload + WDS(__ix__)] #define SIZEOF_StgAP_NoThunkHdr 16 #define SIZEOF_StgAP_NoHdr 24 #define SIZEOF_StgAP (SIZEOF_StgHeader+24) #define OFFSET_StgAP_n_args 12 #define REP_StgAP_n_args b32 #define StgAP_n_args(__ptr__) REP_StgAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_n_args] #define OFFSET_StgAP_fun 16 #define REP_StgAP_fun gcptr #define StgAP_fun(__ptr__) REP_StgAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_fun] #define OFFSET_StgAP_payload 24 #define StgAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_payload + WDS(__ix__)] #define SIZEOF_StgAP_STACK_NoThunkHdr 16 #define SIZEOF_StgAP_STACK_NoHdr 24 #define SIZEOF_StgAP_STACK (SIZEOF_StgHeader+24) #define OFFSET_StgAP_STACK_size 8 #define REP_StgAP_STACK_size b64 #define StgAP_STACK_size(__ptr__) REP_StgAP_STACK_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_size] #define OFFSET_StgAP_STACK_fun 16 #define REP_StgAP_STACK_fun gcptr #define StgAP_STACK_fun(__ptr__) REP_StgAP_STACK_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_fun] #define OFFSET_StgAP_STACK_payload 24 #define StgAP_STACK_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_payload + WDS(__ix__)] #define SIZEOF_StgSelector_NoThunkHdr 8 #define SIZEOF_StgSelector_NoHdr 16 #define SIZEOF_StgSelector (SIZEOF_StgHeader+16) #define OFFSET_StgInd_indirectee 0 #define REP_StgInd_indirectee gcptr #define StgInd_indirectee(__ptr__) REP_StgInd_indirectee[__ptr__+SIZEOF_StgHeader+OFFSET_StgInd_indirectee] #define SIZEOF_StgMutVar_NoHdr 8 #define SIZEOF_StgMutVar (SIZEOF_StgHeader+8) #define OFFSET_StgMutVar_var 0 #define REP_StgMutVar_var b64 #define StgMutVar_var(__ptr__) REP_StgMutVar_var[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutVar_var] #define SIZEOF_StgAtomicallyFrame_NoHdr 16 #define SIZEOF_StgAtomicallyFrame (SIZEOF_StgHeader+16) #define OFFSET_StgAtomicallyFrame_code 0 #define REP_StgAtomicallyFrame_code b64 #define StgAtomicallyFrame_code(__ptr__) REP_StgAtomicallyFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_code] #define OFFSET_StgAtomicallyFrame_result 8 #define REP_StgAtomicallyFrame_result b64 #define StgAtomicallyFrame_result(__ptr__) REP_StgAtomicallyFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_result] #define OFFSET_StgTRecHeader_enclosing_trec 0 #define REP_StgTRecHeader_enclosing_trec b64 #define StgTRecHeader_enclosing_trec(__ptr__) REP_StgTRecHeader_enclosing_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTRecHeader_enclosing_trec] #define SIZEOF_StgCatchSTMFrame_NoHdr 16 #define SIZEOF_StgCatchSTMFrame (SIZEOF_StgHeader+16) #define OFFSET_StgCatchSTMFrame_handler 8 #define REP_StgCatchSTMFrame_handler b64 #define StgCatchSTMFrame_handler(__ptr__) REP_StgCatchSTMFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_handler] #define OFFSET_StgCatchSTMFrame_code 0 #define REP_StgCatchSTMFrame_code b64 #define StgCatchSTMFrame_code(__ptr__) REP_StgCatchSTMFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_code] #define SIZEOF_StgCatchRetryFrame_NoHdr 24 #define SIZEOF_StgCatchRetryFrame (SIZEOF_StgHeader+24) #define OFFSET_StgCatchRetryFrame_running_alt_code 0 #define REP_StgCatchRetryFrame_running_alt_code b64 #define StgCatchRetryFrame_running_alt_code(__ptr__) REP_StgCatchRetryFrame_running_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_running_alt_code] #define OFFSET_StgCatchRetryFrame_first_code 8 #define REP_StgCatchRetryFrame_first_code b64 #define StgCatchRetryFrame_first_code(__ptr__) REP_StgCatchRetryFrame_first_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_first_code] #define OFFSET_StgCatchRetryFrame_alt_code 16 #define REP_StgCatchRetryFrame_alt_code b64 #define StgCatchRetryFrame_alt_code(__ptr__) REP_StgCatchRetryFrame_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_alt_code] #define OFFSET_StgTVarWatchQueue_closure 0 #define REP_StgTVarWatchQueue_closure b64 #define StgTVarWatchQueue_closure(__ptr__) REP_StgTVarWatchQueue_closure[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_closure] #define OFFSET_StgTVarWatchQueue_next_queue_entry 8 #define REP_StgTVarWatchQueue_next_queue_entry b64 #define StgTVarWatchQueue_next_queue_entry(__ptr__) REP_StgTVarWatchQueue_next_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_next_queue_entry] #define OFFSET_StgTVarWatchQueue_prev_queue_entry 16 #define REP_StgTVarWatchQueue_prev_queue_entry b64 #define StgTVarWatchQueue_prev_queue_entry(__ptr__) REP_StgTVarWatchQueue_prev_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_prev_queue_entry] #define SIZEOF_StgTVar_NoHdr 24 #define SIZEOF_StgTVar (SIZEOF_StgHeader+24) #define OFFSET_StgTVar_current_value 0 #define REP_StgTVar_current_value b64 #define StgTVar_current_value(__ptr__) REP_StgTVar_current_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_current_value] #define OFFSET_StgTVar_first_watch_queue_entry 8 #define REP_StgTVar_first_watch_queue_entry b64 #define StgTVar_first_watch_queue_entry(__ptr__) REP_StgTVar_first_watch_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_first_watch_queue_entry] #define OFFSET_StgTVar_num_updates 16 #define REP_StgTVar_num_updates b64 #define StgTVar_num_updates(__ptr__) REP_StgTVar_num_updates[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_num_updates] #define SIZEOF_StgWeak_NoHdr 40 #define SIZEOF_StgWeak (SIZEOF_StgHeader+40) #define OFFSET_StgWeak_link 32 #define REP_StgWeak_link b64 #define StgWeak_link(__ptr__) REP_StgWeak_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_link] #define OFFSET_StgWeak_key 8 #define REP_StgWeak_key b64 #define StgWeak_key(__ptr__) REP_StgWeak_key[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_key] #define OFFSET_StgWeak_value 16 #define REP_StgWeak_value b64 #define StgWeak_value(__ptr__) REP_StgWeak_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_value] #define OFFSET_StgWeak_finalizer 24 #define REP_StgWeak_finalizer b64 #define StgWeak_finalizer(__ptr__) REP_StgWeak_finalizer[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_finalizer] #define OFFSET_StgWeak_cfinalizers 0 #define REP_StgWeak_cfinalizers b64 #define StgWeak_cfinalizers(__ptr__) REP_StgWeak_cfinalizers[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_cfinalizers] #define SIZEOF_StgCFinalizerList_NoHdr 40 #define SIZEOF_StgCFinalizerList (SIZEOF_StgHeader+40) #define OFFSET_StgCFinalizerList_link 0 #define REP_StgCFinalizerList_link b64 #define StgCFinalizerList_link(__ptr__) REP_StgCFinalizerList_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_link] #define OFFSET_StgCFinalizerList_fptr 8 #define REP_StgCFinalizerList_fptr b64 #define StgCFinalizerList_fptr(__ptr__) REP_StgCFinalizerList_fptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_fptr] #define OFFSET_StgCFinalizerList_ptr 16 #define REP_StgCFinalizerList_ptr b64 #define StgCFinalizerList_ptr(__ptr__) REP_StgCFinalizerList_ptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_ptr] #define OFFSET_StgCFinalizerList_eptr 24 #define REP_StgCFinalizerList_eptr b64 #define StgCFinalizerList_eptr(__ptr__) REP_StgCFinalizerList_eptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_eptr] #define OFFSET_StgCFinalizerList_flag 32 #define REP_StgCFinalizerList_flag b64 #define StgCFinalizerList_flag(__ptr__) REP_StgCFinalizerList_flag[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_flag] #define SIZEOF_StgMVar_NoHdr 24 #define SIZEOF_StgMVar (SIZEOF_StgHeader+24) #define OFFSET_StgMVar_head 0 #define REP_StgMVar_head b64 #define StgMVar_head(__ptr__) REP_StgMVar_head[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_head] #define OFFSET_StgMVar_tail 8 #define REP_StgMVar_tail b64 #define StgMVar_tail(__ptr__) REP_StgMVar_tail[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_tail] #define OFFSET_StgMVar_value 16 #define REP_StgMVar_value b64 #define StgMVar_value(__ptr__) REP_StgMVar_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_value] #define SIZEOF_StgMVarTSOQueue_NoHdr 16 #define SIZEOF_StgMVarTSOQueue (SIZEOF_StgHeader+16) #define OFFSET_StgMVarTSOQueue_link 0 #define REP_StgMVarTSOQueue_link b64 #define StgMVarTSOQueue_link(__ptr__) REP_StgMVarTSOQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_link] #define OFFSET_StgMVarTSOQueue_tso 8 #define REP_StgMVarTSOQueue_tso b64 #define StgMVarTSOQueue_tso(__ptr__) REP_StgMVarTSOQueue_tso[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_tso] #define SIZEOF_StgBCO_NoHdr 32 #define SIZEOF_StgBCO (SIZEOF_StgHeader+32) #define OFFSET_StgBCO_instrs 0 #define REP_StgBCO_instrs b64 #define StgBCO_instrs(__ptr__) REP_StgBCO_instrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_instrs] #define OFFSET_StgBCO_literals 8 #define REP_StgBCO_literals b64 #define StgBCO_literals(__ptr__) REP_StgBCO_literals[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_literals] #define OFFSET_StgBCO_ptrs 16 #define REP_StgBCO_ptrs b64 #define StgBCO_ptrs(__ptr__) REP_StgBCO_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_ptrs] #define OFFSET_StgBCO_arity 24 #define REP_StgBCO_arity b32 #define StgBCO_arity(__ptr__) REP_StgBCO_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_arity] #define OFFSET_StgBCO_size 28 #define REP_StgBCO_size b32 #define StgBCO_size(__ptr__) REP_StgBCO_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_size] #define OFFSET_StgBCO_bitmap 32 #define StgBCO_bitmap(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_bitmap + WDS(__ix__)] #define SIZEOF_StgStableName_NoHdr 8 #define SIZEOF_StgStableName (SIZEOF_StgHeader+8) #define OFFSET_StgStableName_sn 0 #define REP_StgStableName_sn b64 #define StgStableName_sn(__ptr__) REP_StgStableName_sn[__ptr__+SIZEOF_StgHeader+OFFSET_StgStableName_sn] #define SIZEOF_StgBlockingQueue_NoHdr 32 #define SIZEOF_StgBlockingQueue (SIZEOF_StgHeader+32) #define OFFSET_StgBlockingQueue_bh 8 #define REP_StgBlockingQueue_bh b64 #define StgBlockingQueue_bh(__ptr__) REP_StgBlockingQueue_bh[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_bh] #define OFFSET_StgBlockingQueue_owner 16 #define REP_StgBlockingQueue_owner b64 #define StgBlockingQueue_owner(__ptr__) REP_StgBlockingQueue_owner[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_owner] #define OFFSET_StgBlockingQueue_queue 24 #define REP_StgBlockingQueue_queue b64 #define StgBlockingQueue_queue(__ptr__) REP_StgBlockingQueue_queue[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_queue] #define OFFSET_StgBlockingQueue_link 0 #define REP_StgBlockingQueue_link b64 #define StgBlockingQueue_link(__ptr__) REP_StgBlockingQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_link] #define SIZEOF_MessageBlackHole_NoHdr 24 #define SIZEOF_MessageBlackHole (SIZEOF_StgHeader+24) #define OFFSET_MessageBlackHole_link 0 #define REP_MessageBlackHole_link b64 #define MessageBlackHole_link(__ptr__) REP_MessageBlackHole_link[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_link] #define OFFSET_MessageBlackHole_tso 8 #define REP_MessageBlackHole_tso b64 #define MessageBlackHole_tso(__ptr__) REP_MessageBlackHole_tso[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_tso] #define OFFSET_MessageBlackHole_bh 16 #define REP_MessageBlackHole_bh b64 #define MessageBlackHole_bh(__ptr__) REP_MessageBlackHole_bh[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_bh] #define SIZEOF_StgCompactNFData_NoHdr 64 #define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+64) #define OFFSET_StgCompactNFData_totalW 0 #define REP_StgCompactNFData_totalW b64 #define StgCompactNFData_totalW(__ptr__) REP_StgCompactNFData_totalW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_totalW] #define OFFSET_StgCompactNFData_autoBlockW 8 #define REP_StgCompactNFData_autoBlockW b64 #define StgCompactNFData_autoBlockW(__ptr__) REP_StgCompactNFData_autoBlockW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_autoBlockW] #define OFFSET_StgCompactNFData_nursery 32 #define REP_StgCompactNFData_nursery b64 #define StgCompactNFData_nursery(__ptr__) REP_StgCompactNFData_nursery[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_nursery] #define OFFSET_StgCompactNFData_last 40 #define REP_StgCompactNFData_last b64 #define StgCompactNFData_last(__ptr__) REP_StgCompactNFData_last[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_last] #define OFFSET_StgCompactNFData_hp 16 #define REP_StgCompactNFData_hp b64 #define StgCompactNFData_hp(__ptr__) REP_StgCompactNFData_hp[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hp] #define OFFSET_StgCompactNFData_hpLim 24 #define REP_StgCompactNFData_hpLim b64 #define StgCompactNFData_hpLim(__ptr__) REP_StgCompactNFData_hpLim[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hpLim] #define OFFSET_StgCompactNFData_hash 48 #define REP_StgCompactNFData_hash b64 #define StgCompactNFData_hash(__ptr__) REP_StgCompactNFData_hash[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hash] #define OFFSET_StgCompactNFData_result 56 #define REP_StgCompactNFData_result b64 #define StgCompactNFData_result(__ptr__) REP_StgCompactNFData_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_result] #define SIZEOF_StgCompactNFDataBlock 24 #define OFFSET_StgCompactNFDataBlock_self 0 #define REP_StgCompactNFDataBlock_self b64 #define StgCompactNFDataBlock_self(__ptr__) REP_StgCompactNFDataBlock_self[__ptr__+OFFSET_StgCompactNFDataBlock_self] #define OFFSET_StgCompactNFDataBlock_owner 8 #define REP_StgCompactNFDataBlock_owner b64 #define StgCompactNFDataBlock_owner(__ptr__) REP_StgCompactNFDataBlock_owner[__ptr__+OFFSET_StgCompactNFDataBlock_owner] #define OFFSET_StgCompactNFDataBlock_next 16 #define REP_StgCompactNFDataBlock_next b64 #define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next] #define OFFSET_RtsFlags_ProfFlags_showCCSOnException 285 #define REP_RtsFlags_ProfFlags_showCCSOnException b8 #define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException] #define OFFSET_RtsFlags_DebugFlags_apply 228 #define REP_RtsFlags_DebugFlags_apply b8 #define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply] #define OFFSET_RtsFlags_DebugFlags_sanity 223 #define REP_RtsFlags_DebugFlags_sanity b8 #define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity] #define OFFSET_RtsFlags_DebugFlags_weak 218 #define REP_RtsFlags_DebugFlags_weak b8 #define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak] #define OFFSET_RtsFlags_GcFlags_initialStkSize 16 #define REP_RtsFlags_GcFlags_initialStkSize b32 #define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize] #define OFFSET_RtsFlags_MiscFlags_tickInterval 192 #define REP_RtsFlags_MiscFlags_tickInterval b64 #define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval] #define SIZEOF_StgFunInfoExtraFwd 32 #define OFFSET_StgFunInfoExtraFwd_slow_apply 24 #define REP_StgFunInfoExtraFwd_slow_apply b64 #define StgFunInfoExtraFwd_slow_apply(__ptr__) REP_StgFunInfoExtraFwd_slow_apply[__ptr__+OFFSET_StgFunInfoExtraFwd_slow_apply] #define OFFSET_StgFunInfoExtraFwd_fun_type 0 #define REP_StgFunInfoExtraFwd_fun_type b32 #define StgFunInfoExtraFwd_fun_type(__ptr__) REP_StgFunInfoExtraFwd_fun_type[__ptr__+OFFSET_StgFunInfoExtraFwd_fun_type] #define OFFSET_StgFunInfoExtraFwd_arity 4 #define REP_StgFunInfoExtraFwd_arity b32 #define StgFunInfoExtraFwd_arity(__ptr__) REP_StgFunInfoExtraFwd_arity[__ptr__+OFFSET_StgFunInfoExtraFwd_arity] #define OFFSET_StgFunInfoExtraFwd_bitmap 16 #define REP_StgFunInfoExtraFwd_bitmap b64 #define StgFunInfoExtraFwd_bitmap(__ptr__) REP_StgFunInfoExtraFwd_bitmap[__ptr__+OFFSET_StgFunInfoExtraFwd_bitmap] #define SIZEOF_StgFunInfoExtraRev 24 #define OFFSET_StgFunInfoExtraRev_slow_apply_offset 0 #define REP_StgFunInfoExtraRev_slow_apply_offset b32 #define StgFunInfoExtraRev_slow_apply_offset(__ptr__) REP_StgFunInfoExtraRev_slow_apply_offset[__ptr__+OFFSET_StgFunInfoExtraRev_slow_apply_offset] #define OFFSET_StgFunInfoExtraRev_fun_type 16 #define REP_StgFunInfoExtraRev_fun_type b32 #define StgFunInfoExtraRev_fun_type(__ptr__) REP_StgFunInfoExtraRev_fun_type[__ptr__+OFFSET_StgFunInfoExtraRev_fun_type] #define OFFSET_StgFunInfoExtraRev_arity 20 #define REP_StgFunInfoExtraRev_arity b32 #define StgFunInfoExtraRev_arity(__ptr__) REP_StgFunInfoExtraRev_arity[__ptr__+OFFSET_StgFunInfoExtraRev_arity] #define OFFSET_StgFunInfoExtraRev_bitmap 8 #define REP_StgFunInfoExtraRev_bitmap b64 #define StgFunInfoExtraRev_bitmap(__ptr__) REP_StgFunInfoExtraRev_bitmap[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap] #define OFFSET_StgFunInfoExtraRev_bitmap_offset 8 #define REP_StgFunInfoExtraRev_bitmap_offset b32 #define StgFunInfoExtraRev_bitmap_offset(__ptr__) REP_StgFunInfoExtraRev_bitmap_offset[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap_offset] #define OFFSET_StgLargeBitmap_size 0 #define REP_StgLargeBitmap_size b64 #define StgLargeBitmap_size(__ptr__) REP_StgLargeBitmap_size[__ptr__+OFFSET_StgLargeBitmap_size] #define OFFSET_StgLargeBitmap_bitmap 8 #define SIZEOF_snEntry 24 #define OFFSET_snEntry_sn_obj 16 #define REP_snEntry_sn_obj b64 #define snEntry_sn_obj(__ptr__) REP_snEntry_sn_obj[__ptr__+OFFSET_snEntry_sn_obj] #define OFFSET_snEntry_addr 0 #define REP_snEntry_addr b64 #define snEntry_addr(__ptr__) REP_snEntry_addr[__ptr__+OFFSET_snEntry_addr] #define SIZEOF_spEntry 8 #define OFFSET_spEntry_addr 0 #define REP_spEntry_addr b64 #define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr] ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs0000644000000000000000000000645313713636030024464 0ustar0000000000000000 cONTROL_GROUP_CONST_291, sTD_HDR_SIZE, pROF_HDR_SIZE, bLOCK_SIZE, bLOCKS_PER_MBLOCK, tICKY_BIN_COUNT, oFFSET_StgRegTable_rR1, oFFSET_StgRegTable_rR2, oFFSET_StgRegTable_rR3, oFFSET_StgRegTable_rR4, oFFSET_StgRegTable_rR5, oFFSET_StgRegTable_rR6, oFFSET_StgRegTable_rR7, oFFSET_StgRegTable_rR8, oFFSET_StgRegTable_rR9, oFFSET_StgRegTable_rR10, oFFSET_StgRegTable_rF1, oFFSET_StgRegTable_rF2, oFFSET_StgRegTable_rF3, oFFSET_StgRegTable_rF4, oFFSET_StgRegTable_rF5, oFFSET_StgRegTable_rF6, oFFSET_StgRegTable_rD1, oFFSET_StgRegTable_rD2, oFFSET_StgRegTable_rD3, oFFSET_StgRegTable_rD4, oFFSET_StgRegTable_rD5, oFFSET_StgRegTable_rD6, oFFSET_StgRegTable_rXMM1, oFFSET_StgRegTable_rXMM2, oFFSET_StgRegTable_rXMM3, oFFSET_StgRegTable_rXMM4, oFFSET_StgRegTable_rXMM5, oFFSET_StgRegTable_rXMM6, oFFSET_StgRegTable_rYMM1, oFFSET_StgRegTable_rYMM2, oFFSET_StgRegTable_rYMM3, oFFSET_StgRegTable_rYMM4, oFFSET_StgRegTable_rYMM5, oFFSET_StgRegTable_rYMM6, oFFSET_StgRegTable_rZMM1, oFFSET_StgRegTable_rZMM2, oFFSET_StgRegTable_rZMM3, oFFSET_StgRegTable_rZMM4, oFFSET_StgRegTable_rZMM5, oFFSET_StgRegTable_rZMM6, oFFSET_StgRegTable_rL1, oFFSET_StgRegTable_rSp, oFFSET_StgRegTable_rSpLim, oFFSET_StgRegTable_rHp, oFFSET_StgRegTable_rHpLim, oFFSET_StgRegTable_rCCCS, oFFSET_StgRegTable_rCurrentTSO, oFFSET_StgRegTable_rCurrentNursery, oFFSET_StgRegTable_rHpAlloc, oFFSET_stgEagerBlackholeInfo, oFFSET_stgGCEnter1, oFFSET_stgGCFun, oFFSET_Capability_r, oFFSET_bdescr_start, oFFSET_bdescr_free, oFFSET_bdescr_blocks, oFFSET_bdescr_flags, sIZEOF_CostCentreStack, oFFSET_CostCentreStack_mem_alloc, oFFSET_CostCentreStack_scc_count, oFFSET_StgHeader_ccs, oFFSET_StgHeader_ldvw, sIZEOF_StgSMPThunkHeader, oFFSET_StgEntCounter_allocs, oFFSET_StgEntCounter_allocd, oFFSET_StgEntCounter_registeredp, oFFSET_StgEntCounter_link, oFFSET_StgEntCounter_entry_count, sIZEOF_StgUpdateFrame_NoHdr, sIZEOF_StgMutArrPtrs_NoHdr, oFFSET_StgMutArrPtrs_ptrs, oFFSET_StgMutArrPtrs_size, sIZEOF_StgSmallMutArrPtrs_NoHdr, oFFSET_StgSmallMutArrPtrs_ptrs, sIZEOF_StgArrBytes_NoHdr, oFFSET_StgArrBytes_bytes, oFFSET_StgTSO_alloc_limit, oFFSET_StgTSO_cccs, oFFSET_StgTSO_stackobj, oFFSET_StgStack_sp, oFFSET_StgStack_stack, oFFSET_StgUpdateFrame_updatee, oFFSET_StgFunInfoExtraFwd_arity, sIZEOF_StgFunInfoExtraRev, oFFSET_StgFunInfoExtraRev_arity, mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE, mIN_PAYLOAD_SIZE, mIN_INTLIKE, mAX_INTLIKE, mIN_CHARLIKE, mAX_CHARLIKE, mUT_ARR_PTRS_CARD_BITS, mAX_Vanilla_REG, mAX_Float_REG, mAX_Double_REG, mAX_Long_REG, mAX_XMM_REG, mAX_Real_Vanilla_REG, mAX_Real_Float_REG, mAX_Real_Double_REG, mAX_Real_XMM_REG, mAX_Real_Long_REG, rESERVED_C_STACK_BYTES, rESERVED_STACK_WORDS, aP_STACK_SPLIM, wORD_SIZE, dOUBLE_SIZE, cINT_SIZE, cLONG_SIZE, cLONG_LONG_SIZE, bITMAP_BITS_SHIFT, tAG_BITS, wORDS_BIGENDIAN, dYNAMIC_BY_DEFAULT, lDV_SHIFT, iLDV_CREATE_MASK, iLDV_STATE_CREATE, iLDV_STATE_USE, ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs0000644000000000000000000003621613713636027024631 0ustar0000000000000000cONTROL_GROUP_CONST_291 :: DynFlags -> Int cONTROL_GROUP_CONST_291 dflags = pc_CONTROL_GROUP_CONST_291 (platformConstants dflags) sTD_HDR_SIZE :: DynFlags -> Int sTD_HDR_SIZE dflags = pc_STD_HDR_SIZE (platformConstants dflags) pROF_HDR_SIZE :: DynFlags -> Int pROF_HDR_SIZE dflags = pc_PROF_HDR_SIZE (platformConstants dflags) bLOCK_SIZE :: DynFlags -> Int bLOCK_SIZE dflags = pc_BLOCK_SIZE (platformConstants dflags) bLOCKS_PER_MBLOCK :: DynFlags -> Int bLOCKS_PER_MBLOCK dflags = pc_BLOCKS_PER_MBLOCK (platformConstants dflags) tICKY_BIN_COUNT :: DynFlags -> Int tICKY_BIN_COUNT dflags = pc_TICKY_BIN_COUNT (platformConstants dflags) oFFSET_StgRegTable_rR1 :: DynFlags -> Int oFFSET_StgRegTable_rR1 dflags = pc_OFFSET_StgRegTable_rR1 (platformConstants dflags) oFFSET_StgRegTable_rR2 :: DynFlags -> Int oFFSET_StgRegTable_rR2 dflags = pc_OFFSET_StgRegTable_rR2 (platformConstants dflags) oFFSET_StgRegTable_rR3 :: DynFlags -> Int oFFSET_StgRegTable_rR3 dflags = pc_OFFSET_StgRegTable_rR3 (platformConstants dflags) oFFSET_StgRegTable_rR4 :: DynFlags -> Int oFFSET_StgRegTable_rR4 dflags = pc_OFFSET_StgRegTable_rR4 (platformConstants dflags) oFFSET_StgRegTable_rR5 :: DynFlags -> Int oFFSET_StgRegTable_rR5 dflags = pc_OFFSET_StgRegTable_rR5 (platformConstants dflags) oFFSET_StgRegTable_rR6 :: DynFlags -> Int oFFSET_StgRegTable_rR6 dflags = pc_OFFSET_StgRegTable_rR6 (platformConstants dflags) oFFSET_StgRegTable_rR7 :: DynFlags -> Int oFFSET_StgRegTable_rR7 dflags = pc_OFFSET_StgRegTable_rR7 (platformConstants dflags) oFFSET_StgRegTable_rR8 :: DynFlags -> Int oFFSET_StgRegTable_rR8 dflags = pc_OFFSET_StgRegTable_rR8 (platformConstants dflags) oFFSET_StgRegTable_rR9 :: DynFlags -> Int oFFSET_StgRegTable_rR9 dflags = pc_OFFSET_StgRegTable_rR9 (platformConstants dflags) oFFSET_StgRegTable_rR10 :: DynFlags -> Int oFFSET_StgRegTable_rR10 dflags = pc_OFFSET_StgRegTable_rR10 (platformConstants dflags) oFFSET_StgRegTable_rF1 :: DynFlags -> Int oFFSET_StgRegTable_rF1 dflags = pc_OFFSET_StgRegTable_rF1 (platformConstants dflags) oFFSET_StgRegTable_rF2 :: DynFlags -> Int oFFSET_StgRegTable_rF2 dflags = pc_OFFSET_StgRegTable_rF2 (platformConstants dflags) oFFSET_StgRegTable_rF3 :: DynFlags -> Int oFFSET_StgRegTable_rF3 dflags = pc_OFFSET_StgRegTable_rF3 (platformConstants dflags) oFFSET_StgRegTable_rF4 :: DynFlags -> Int oFFSET_StgRegTable_rF4 dflags = pc_OFFSET_StgRegTable_rF4 (platformConstants dflags) oFFSET_StgRegTable_rF5 :: DynFlags -> Int oFFSET_StgRegTable_rF5 dflags = pc_OFFSET_StgRegTable_rF5 (platformConstants dflags) oFFSET_StgRegTable_rF6 :: DynFlags -> Int oFFSET_StgRegTable_rF6 dflags = pc_OFFSET_StgRegTable_rF6 (platformConstants dflags) oFFSET_StgRegTable_rD1 :: DynFlags -> Int oFFSET_StgRegTable_rD1 dflags = pc_OFFSET_StgRegTable_rD1 (platformConstants dflags) oFFSET_StgRegTable_rD2 :: DynFlags -> Int oFFSET_StgRegTable_rD2 dflags = pc_OFFSET_StgRegTable_rD2 (platformConstants dflags) oFFSET_StgRegTable_rD3 :: DynFlags -> Int oFFSET_StgRegTable_rD3 dflags = pc_OFFSET_StgRegTable_rD3 (platformConstants dflags) oFFSET_StgRegTable_rD4 :: DynFlags -> Int oFFSET_StgRegTable_rD4 dflags = pc_OFFSET_StgRegTable_rD4 (platformConstants dflags) oFFSET_StgRegTable_rD5 :: DynFlags -> Int oFFSET_StgRegTable_rD5 dflags = pc_OFFSET_StgRegTable_rD5 (platformConstants dflags) oFFSET_StgRegTable_rD6 :: DynFlags -> Int oFFSET_StgRegTable_rD6 dflags = pc_OFFSET_StgRegTable_rD6 (platformConstants dflags) oFFSET_StgRegTable_rXMM1 :: DynFlags -> Int oFFSET_StgRegTable_rXMM1 dflags = pc_OFFSET_StgRegTable_rXMM1 (platformConstants dflags) oFFSET_StgRegTable_rXMM2 :: DynFlags -> Int oFFSET_StgRegTable_rXMM2 dflags = pc_OFFSET_StgRegTable_rXMM2 (platformConstants dflags) oFFSET_StgRegTable_rXMM3 :: DynFlags -> Int oFFSET_StgRegTable_rXMM3 dflags = pc_OFFSET_StgRegTable_rXMM3 (platformConstants dflags) oFFSET_StgRegTable_rXMM4 :: DynFlags -> Int oFFSET_StgRegTable_rXMM4 dflags = pc_OFFSET_StgRegTable_rXMM4 (platformConstants dflags) oFFSET_StgRegTable_rXMM5 :: DynFlags -> Int oFFSET_StgRegTable_rXMM5 dflags = pc_OFFSET_StgRegTable_rXMM5 (platformConstants dflags) oFFSET_StgRegTable_rXMM6 :: DynFlags -> Int oFFSET_StgRegTable_rXMM6 dflags = pc_OFFSET_StgRegTable_rXMM6 (platformConstants dflags) oFFSET_StgRegTable_rYMM1 :: DynFlags -> Int oFFSET_StgRegTable_rYMM1 dflags = pc_OFFSET_StgRegTable_rYMM1 (platformConstants dflags) oFFSET_StgRegTable_rYMM2 :: DynFlags -> Int oFFSET_StgRegTable_rYMM2 dflags = pc_OFFSET_StgRegTable_rYMM2 (platformConstants dflags) oFFSET_StgRegTable_rYMM3 :: DynFlags -> Int oFFSET_StgRegTable_rYMM3 dflags = pc_OFFSET_StgRegTable_rYMM3 (platformConstants dflags) oFFSET_StgRegTable_rYMM4 :: DynFlags -> Int oFFSET_StgRegTable_rYMM4 dflags = pc_OFFSET_StgRegTable_rYMM4 (platformConstants dflags) oFFSET_StgRegTable_rYMM5 :: DynFlags -> Int oFFSET_StgRegTable_rYMM5 dflags = pc_OFFSET_StgRegTable_rYMM5 (platformConstants dflags) oFFSET_StgRegTable_rYMM6 :: DynFlags -> Int oFFSET_StgRegTable_rYMM6 dflags = pc_OFFSET_StgRegTable_rYMM6 (platformConstants dflags) oFFSET_StgRegTable_rZMM1 :: DynFlags -> Int oFFSET_StgRegTable_rZMM1 dflags = pc_OFFSET_StgRegTable_rZMM1 (platformConstants dflags) oFFSET_StgRegTable_rZMM2 :: DynFlags -> Int oFFSET_StgRegTable_rZMM2 dflags = pc_OFFSET_StgRegTable_rZMM2 (platformConstants dflags) oFFSET_StgRegTable_rZMM3 :: DynFlags -> Int oFFSET_StgRegTable_rZMM3 dflags = pc_OFFSET_StgRegTable_rZMM3 (platformConstants dflags) oFFSET_StgRegTable_rZMM4 :: DynFlags -> Int oFFSET_StgRegTable_rZMM4 dflags = pc_OFFSET_StgRegTable_rZMM4 (platformConstants dflags) oFFSET_StgRegTable_rZMM5 :: DynFlags -> Int oFFSET_StgRegTable_rZMM5 dflags = pc_OFFSET_StgRegTable_rZMM5 (platformConstants dflags) oFFSET_StgRegTable_rZMM6 :: DynFlags -> Int oFFSET_StgRegTable_rZMM6 dflags = pc_OFFSET_StgRegTable_rZMM6 (platformConstants dflags) oFFSET_StgRegTable_rL1 :: DynFlags -> Int oFFSET_StgRegTable_rL1 dflags = pc_OFFSET_StgRegTable_rL1 (platformConstants dflags) oFFSET_StgRegTable_rSp :: DynFlags -> Int oFFSET_StgRegTable_rSp dflags = pc_OFFSET_StgRegTable_rSp (platformConstants dflags) oFFSET_StgRegTable_rSpLim :: DynFlags -> Int oFFSET_StgRegTable_rSpLim dflags = pc_OFFSET_StgRegTable_rSpLim (platformConstants dflags) oFFSET_StgRegTable_rHp :: DynFlags -> Int oFFSET_StgRegTable_rHp dflags = pc_OFFSET_StgRegTable_rHp (platformConstants dflags) oFFSET_StgRegTable_rHpLim :: DynFlags -> Int oFFSET_StgRegTable_rHpLim dflags = pc_OFFSET_StgRegTable_rHpLim (platformConstants dflags) oFFSET_StgRegTable_rCCCS :: DynFlags -> Int oFFSET_StgRegTable_rCCCS dflags = pc_OFFSET_StgRegTable_rCCCS (platformConstants dflags) oFFSET_StgRegTable_rCurrentTSO :: DynFlags -> Int oFFSET_StgRegTable_rCurrentTSO dflags = pc_OFFSET_StgRegTable_rCurrentTSO (platformConstants dflags) oFFSET_StgRegTable_rCurrentNursery :: DynFlags -> Int oFFSET_StgRegTable_rCurrentNursery dflags = pc_OFFSET_StgRegTable_rCurrentNursery (platformConstants dflags) oFFSET_StgRegTable_rHpAlloc :: DynFlags -> Int oFFSET_StgRegTable_rHpAlloc dflags = pc_OFFSET_StgRegTable_rHpAlloc (platformConstants dflags) oFFSET_stgEagerBlackholeInfo :: DynFlags -> Int oFFSET_stgEagerBlackholeInfo dflags = pc_OFFSET_stgEagerBlackholeInfo (platformConstants dflags) oFFSET_stgGCEnter1 :: DynFlags -> Int oFFSET_stgGCEnter1 dflags = pc_OFFSET_stgGCEnter1 (platformConstants dflags) oFFSET_stgGCFun :: DynFlags -> Int oFFSET_stgGCFun dflags = pc_OFFSET_stgGCFun (platformConstants dflags) oFFSET_Capability_r :: DynFlags -> Int oFFSET_Capability_r dflags = pc_OFFSET_Capability_r (platformConstants dflags) oFFSET_bdescr_start :: DynFlags -> Int oFFSET_bdescr_start dflags = pc_OFFSET_bdescr_start (platformConstants dflags) oFFSET_bdescr_free :: DynFlags -> Int oFFSET_bdescr_free dflags = pc_OFFSET_bdescr_free (platformConstants dflags) oFFSET_bdescr_blocks :: DynFlags -> Int oFFSET_bdescr_blocks dflags = pc_OFFSET_bdescr_blocks (platformConstants dflags) oFFSET_bdescr_flags :: DynFlags -> Int oFFSET_bdescr_flags dflags = pc_OFFSET_bdescr_flags (platformConstants dflags) sIZEOF_CostCentreStack :: DynFlags -> Int sIZEOF_CostCentreStack dflags = pc_SIZEOF_CostCentreStack (platformConstants dflags) oFFSET_CostCentreStack_mem_alloc :: DynFlags -> Int oFFSET_CostCentreStack_mem_alloc dflags = pc_OFFSET_CostCentreStack_mem_alloc (platformConstants dflags) oFFSET_CostCentreStack_scc_count :: DynFlags -> Int oFFSET_CostCentreStack_scc_count dflags = pc_OFFSET_CostCentreStack_scc_count (platformConstants dflags) oFFSET_StgHeader_ccs :: DynFlags -> Int oFFSET_StgHeader_ccs dflags = pc_OFFSET_StgHeader_ccs (platformConstants dflags) oFFSET_StgHeader_ldvw :: DynFlags -> Int oFFSET_StgHeader_ldvw dflags = pc_OFFSET_StgHeader_ldvw (platformConstants dflags) sIZEOF_StgSMPThunkHeader :: DynFlags -> Int sIZEOF_StgSMPThunkHeader dflags = pc_SIZEOF_StgSMPThunkHeader (platformConstants dflags) oFFSET_StgEntCounter_allocs :: DynFlags -> Int oFFSET_StgEntCounter_allocs dflags = pc_OFFSET_StgEntCounter_allocs (platformConstants dflags) oFFSET_StgEntCounter_allocd :: DynFlags -> Int oFFSET_StgEntCounter_allocd dflags = pc_OFFSET_StgEntCounter_allocd (platformConstants dflags) oFFSET_StgEntCounter_registeredp :: DynFlags -> Int oFFSET_StgEntCounter_registeredp dflags = pc_OFFSET_StgEntCounter_registeredp (platformConstants dflags) oFFSET_StgEntCounter_link :: DynFlags -> Int oFFSET_StgEntCounter_link dflags = pc_OFFSET_StgEntCounter_link (platformConstants dflags) oFFSET_StgEntCounter_entry_count :: DynFlags -> Int oFFSET_StgEntCounter_entry_count dflags = pc_OFFSET_StgEntCounter_entry_count (platformConstants dflags) sIZEOF_StgUpdateFrame_NoHdr :: DynFlags -> Int sIZEOF_StgUpdateFrame_NoHdr dflags = pc_SIZEOF_StgUpdateFrame_NoHdr (platformConstants dflags) sIZEOF_StgMutArrPtrs_NoHdr :: DynFlags -> Int sIZEOF_StgMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgMutArrPtrs_NoHdr (platformConstants dflags) oFFSET_StgMutArrPtrs_ptrs :: DynFlags -> Int oFFSET_StgMutArrPtrs_ptrs dflags = pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants dflags) oFFSET_StgMutArrPtrs_size :: DynFlags -> Int oFFSET_StgMutArrPtrs_size dflags = pc_OFFSET_StgMutArrPtrs_size (platformConstants dflags) sIZEOF_StgSmallMutArrPtrs_NoHdr :: DynFlags -> Int sIZEOF_StgSmallMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (platformConstants dflags) oFFSET_StgSmallMutArrPtrs_ptrs :: DynFlags -> Int oFFSET_StgSmallMutArrPtrs_ptrs dflags = pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants dflags) sIZEOF_StgArrBytes_NoHdr :: DynFlags -> Int sIZEOF_StgArrBytes_NoHdr dflags = pc_SIZEOF_StgArrBytes_NoHdr (platformConstants dflags) oFFSET_StgArrBytes_bytes :: DynFlags -> Int oFFSET_StgArrBytes_bytes dflags = pc_OFFSET_StgArrBytes_bytes (platformConstants dflags) oFFSET_StgTSO_alloc_limit :: DynFlags -> Int oFFSET_StgTSO_alloc_limit dflags = pc_OFFSET_StgTSO_alloc_limit (platformConstants dflags) oFFSET_StgTSO_cccs :: DynFlags -> Int oFFSET_StgTSO_cccs dflags = pc_OFFSET_StgTSO_cccs (platformConstants dflags) oFFSET_StgTSO_stackobj :: DynFlags -> Int oFFSET_StgTSO_stackobj dflags = pc_OFFSET_StgTSO_stackobj (platformConstants dflags) oFFSET_StgStack_sp :: DynFlags -> Int oFFSET_StgStack_sp dflags = pc_OFFSET_StgStack_sp (platformConstants dflags) oFFSET_StgStack_stack :: DynFlags -> Int oFFSET_StgStack_stack dflags = pc_OFFSET_StgStack_stack (platformConstants dflags) oFFSET_StgUpdateFrame_updatee :: DynFlags -> Int oFFSET_StgUpdateFrame_updatee dflags = pc_OFFSET_StgUpdateFrame_updatee (platformConstants dflags) oFFSET_StgFunInfoExtraFwd_arity :: DynFlags -> Int oFFSET_StgFunInfoExtraFwd_arity dflags = pc_OFFSET_StgFunInfoExtraFwd_arity (platformConstants dflags) sIZEOF_StgFunInfoExtraRev :: DynFlags -> Int sIZEOF_StgFunInfoExtraRev dflags = pc_SIZEOF_StgFunInfoExtraRev (platformConstants dflags) oFFSET_StgFunInfoExtraRev_arity :: DynFlags -> Int oFFSET_StgFunInfoExtraRev_arity dflags = pc_OFFSET_StgFunInfoExtraRev_arity (platformConstants dflags) mAX_SPEC_SELECTEE_SIZE :: DynFlags -> Int mAX_SPEC_SELECTEE_SIZE dflags = pc_MAX_SPEC_SELECTEE_SIZE (platformConstants dflags) mAX_SPEC_AP_SIZE :: DynFlags -> Int mAX_SPEC_AP_SIZE dflags = pc_MAX_SPEC_AP_SIZE (platformConstants dflags) mIN_PAYLOAD_SIZE :: DynFlags -> Int mIN_PAYLOAD_SIZE dflags = pc_MIN_PAYLOAD_SIZE (platformConstants dflags) mIN_INTLIKE :: DynFlags -> Int mIN_INTLIKE dflags = pc_MIN_INTLIKE (platformConstants dflags) mAX_INTLIKE :: DynFlags -> Int mAX_INTLIKE dflags = pc_MAX_INTLIKE (platformConstants dflags) mIN_CHARLIKE :: DynFlags -> Int mIN_CHARLIKE dflags = pc_MIN_CHARLIKE (platformConstants dflags) mAX_CHARLIKE :: DynFlags -> Int mAX_CHARLIKE dflags = pc_MAX_CHARLIKE (platformConstants dflags) mUT_ARR_PTRS_CARD_BITS :: DynFlags -> Int mUT_ARR_PTRS_CARD_BITS dflags = pc_MUT_ARR_PTRS_CARD_BITS (platformConstants dflags) mAX_Vanilla_REG :: DynFlags -> Int mAX_Vanilla_REG dflags = pc_MAX_Vanilla_REG (platformConstants dflags) mAX_Float_REG :: DynFlags -> Int mAX_Float_REG dflags = pc_MAX_Float_REG (platformConstants dflags) mAX_Double_REG :: DynFlags -> Int mAX_Double_REG dflags = pc_MAX_Double_REG (platformConstants dflags) mAX_Long_REG :: DynFlags -> Int mAX_Long_REG dflags = pc_MAX_Long_REG (platformConstants dflags) mAX_XMM_REG :: DynFlags -> Int mAX_XMM_REG dflags = pc_MAX_XMM_REG (platformConstants dflags) mAX_Real_Vanilla_REG :: DynFlags -> Int mAX_Real_Vanilla_REG dflags = pc_MAX_Real_Vanilla_REG (platformConstants dflags) mAX_Real_Float_REG :: DynFlags -> Int mAX_Real_Float_REG dflags = pc_MAX_Real_Float_REG (platformConstants dflags) mAX_Real_Double_REG :: DynFlags -> Int mAX_Real_Double_REG dflags = pc_MAX_Real_Double_REG (platformConstants dflags) mAX_Real_XMM_REG :: DynFlags -> Int mAX_Real_XMM_REG dflags = pc_MAX_Real_XMM_REG (platformConstants dflags) mAX_Real_Long_REG :: DynFlags -> Int mAX_Real_Long_REG dflags = pc_MAX_Real_Long_REG (platformConstants dflags) rESERVED_C_STACK_BYTES :: DynFlags -> Int rESERVED_C_STACK_BYTES dflags = pc_RESERVED_C_STACK_BYTES (platformConstants dflags) rESERVED_STACK_WORDS :: DynFlags -> Int rESERVED_STACK_WORDS dflags = pc_RESERVED_STACK_WORDS (platformConstants dflags) aP_STACK_SPLIM :: DynFlags -> Int aP_STACK_SPLIM dflags = pc_AP_STACK_SPLIM (platformConstants dflags) wORD_SIZE :: DynFlags -> Int wORD_SIZE dflags = pc_WORD_SIZE (platformConstants dflags) dOUBLE_SIZE :: DynFlags -> Int dOUBLE_SIZE dflags = pc_DOUBLE_SIZE (platformConstants dflags) cINT_SIZE :: DynFlags -> Int cINT_SIZE dflags = pc_CINT_SIZE (platformConstants dflags) cLONG_SIZE :: DynFlags -> Int cLONG_SIZE dflags = pc_CLONG_SIZE (platformConstants dflags) cLONG_LONG_SIZE :: DynFlags -> Int cLONG_LONG_SIZE dflags = pc_CLONG_LONG_SIZE (platformConstants dflags) bITMAP_BITS_SHIFT :: DynFlags -> Int bITMAP_BITS_SHIFT dflags = pc_BITMAP_BITS_SHIFT (platformConstants dflags) tAG_BITS :: DynFlags -> Int tAG_BITS dflags = pc_TAG_BITS (platformConstants dflags) wORDS_BIGENDIAN :: DynFlags -> Bool wORDS_BIGENDIAN dflags = pc_WORDS_BIGENDIAN (platformConstants dflags) dYNAMIC_BY_DEFAULT :: DynFlags -> Bool dYNAMIC_BY_DEFAULT dflags = pc_DYNAMIC_BY_DEFAULT (platformConstants dflags) lDV_SHIFT :: DynFlags -> Int lDV_SHIFT dflags = pc_LDV_SHIFT (platformConstants dflags) iLDV_CREATE_MASK :: DynFlags -> Integer iLDV_CREATE_MASK dflags = pc_ILDV_CREATE_MASK (platformConstants dflags) iLDV_STATE_CREATE :: DynFlags -> Integer iLDV_STATE_CREATE dflags = pc_ILDV_STATE_CREATE (platformConstants dflags) iLDV_STATE_USE :: DynFlags -> Integer iLDV_STATE_USE dflags = pc_ILDV_STATE_USE (platformConstants dflags) ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/lib/GHCConstantsHaskellType.hs0000644000000000000000000001214113713636027023736 0ustar0000000000000000data PlatformConstants = PlatformConstants { pc_CONTROL_GROUP_CONST_291 :: Int, pc_STD_HDR_SIZE :: Int, pc_PROF_HDR_SIZE :: Int, pc_BLOCK_SIZE :: Int, pc_BLOCKS_PER_MBLOCK :: Int, pc_TICKY_BIN_COUNT :: Int, pc_OFFSET_StgRegTable_rR1 :: Int, pc_OFFSET_StgRegTable_rR2 :: Int, pc_OFFSET_StgRegTable_rR3 :: Int, pc_OFFSET_StgRegTable_rR4 :: Int, pc_OFFSET_StgRegTable_rR5 :: Int, pc_OFFSET_StgRegTable_rR6 :: Int, pc_OFFSET_StgRegTable_rR7 :: Int, pc_OFFSET_StgRegTable_rR8 :: Int, pc_OFFSET_StgRegTable_rR9 :: Int, pc_OFFSET_StgRegTable_rR10 :: Int, pc_OFFSET_StgRegTable_rF1 :: Int, pc_OFFSET_StgRegTable_rF2 :: Int, pc_OFFSET_StgRegTable_rF3 :: Int, pc_OFFSET_StgRegTable_rF4 :: Int, pc_OFFSET_StgRegTable_rF5 :: Int, pc_OFFSET_StgRegTable_rF6 :: Int, pc_OFFSET_StgRegTable_rD1 :: Int, pc_OFFSET_StgRegTable_rD2 :: Int, pc_OFFSET_StgRegTable_rD3 :: Int, pc_OFFSET_StgRegTable_rD4 :: Int, pc_OFFSET_StgRegTable_rD5 :: Int, pc_OFFSET_StgRegTable_rD6 :: Int, pc_OFFSET_StgRegTable_rXMM1 :: Int, pc_OFFSET_StgRegTable_rXMM2 :: Int, pc_OFFSET_StgRegTable_rXMM3 :: Int, pc_OFFSET_StgRegTable_rXMM4 :: Int, pc_OFFSET_StgRegTable_rXMM5 :: Int, pc_OFFSET_StgRegTable_rXMM6 :: Int, pc_OFFSET_StgRegTable_rYMM1 :: Int, pc_OFFSET_StgRegTable_rYMM2 :: Int, pc_OFFSET_StgRegTable_rYMM3 :: Int, pc_OFFSET_StgRegTable_rYMM4 :: Int, pc_OFFSET_StgRegTable_rYMM5 :: Int, pc_OFFSET_StgRegTable_rYMM6 :: Int, pc_OFFSET_StgRegTable_rZMM1 :: Int, pc_OFFSET_StgRegTable_rZMM2 :: Int, pc_OFFSET_StgRegTable_rZMM3 :: Int, pc_OFFSET_StgRegTable_rZMM4 :: Int, pc_OFFSET_StgRegTable_rZMM5 :: Int, pc_OFFSET_StgRegTable_rZMM6 :: Int, pc_OFFSET_StgRegTable_rL1 :: Int, pc_OFFSET_StgRegTable_rSp :: Int, pc_OFFSET_StgRegTable_rSpLim :: Int, pc_OFFSET_StgRegTable_rHp :: Int, pc_OFFSET_StgRegTable_rHpLim :: Int, pc_OFFSET_StgRegTable_rCCCS :: Int, pc_OFFSET_StgRegTable_rCurrentTSO :: Int, pc_OFFSET_StgRegTable_rCurrentNursery :: Int, pc_OFFSET_StgRegTable_rHpAlloc :: Int, pc_OFFSET_stgEagerBlackholeInfo :: Int, pc_OFFSET_stgGCEnter1 :: Int, pc_OFFSET_stgGCFun :: Int, pc_OFFSET_Capability_r :: Int, pc_OFFSET_bdescr_start :: Int, pc_OFFSET_bdescr_free :: Int, pc_OFFSET_bdescr_blocks :: Int, pc_OFFSET_bdescr_flags :: Int, pc_SIZEOF_CostCentreStack :: Int, pc_OFFSET_CostCentreStack_mem_alloc :: Int, pc_REP_CostCentreStack_mem_alloc :: Int, pc_OFFSET_CostCentreStack_scc_count :: Int, pc_REP_CostCentreStack_scc_count :: Int, pc_OFFSET_StgHeader_ccs :: Int, pc_OFFSET_StgHeader_ldvw :: Int, pc_SIZEOF_StgSMPThunkHeader :: Int, pc_OFFSET_StgEntCounter_allocs :: Int, pc_REP_StgEntCounter_allocs :: Int, pc_OFFSET_StgEntCounter_allocd :: Int, pc_REP_StgEntCounter_allocd :: Int, pc_OFFSET_StgEntCounter_registeredp :: Int, pc_OFFSET_StgEntCounter_link :: Int, pc_OFFSET_StgEntCounter_entry_count :: Int, pc_SIZEOF_StgUpdateFrame_NoHdr :: Int, pc_SIZEOF_StgMutArrPtrs_NoHdr :: Int, pc_OFFSET_StgMutArrPtrs_ptrs :: Int, pc_OFFSET_StgMutArrPtrs_size :: Int, pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: Int, pc_OFFSET_StgSmallMutArrPtrs_ptrs :: Int, pc_SIZEOF_StgArrBytes_NoHdr :: Int, pc_OFFSET_StgArrBytes_bytes :: Int, pc_OFFSET_StgTSO_alloc_limit :: Int, pc_OFFSET_StgTSO_cccs :: Int, pc_OFFSET_StgTSO_stackobj :: Int, pc_OFFSET_StgStack_sp :: Int, pc_OFFSET_StgStack_stack :: Int, pc_OFFSET_StgUpdateFrame_updatee :: Int, pc_OFFSET_StgFunInfoExtraFwd_arity :: Int, pc_REP_StgFunInfoExtraFwd_arity :: Int, pc_SIZEOF_StgFunInfoExtraRev :: Int, pc_OFFSET_StgFunInfoExtraRev_arity :: Int, pc_REP_StgFunInfoExtraRev_arity :: Int, pc_MAX_SPEC_SELECTEE_SIZE :: Int, pc_MAX_SPEC_AP_SIZE :: Int, pc_MIN_PAYLOAD_SIZE :: Int, pc_MIN_INTLIKE :: Int, pc_MAX_INTLIKE :: Int, pc_MIN_CHARLIKE :: Int, pc_MAX_CHARLIKE :: Int, pc_MUT_ARR_PTRS_CARD_BITS :: Int, pc_MAX_Vanilla_REG :: Int, pc_MAX_Float_REG :: Int, pc_MAX_Double_REG :: Int, pc_MAX_Long_REG :: Int, pc_MAX_XMM_REG :: Int, pc_MAX_Real_Vanilla_REG :: Int, pc_MAX_Real_Float_REG :: Int, pc_MAX_Real_Double_REG :: Int, pc_MAX_Real_XMM_REG :: Int, pc_MAX_Real_Long_REG :: Int, pc_RESERVED_C_STACK_BYTES :: Int, pc_RESERVED_STACK_WORDS :: Int, pc_AP_STACK_SPLIM :: Int, pc_WORD_SIZE :: Int, pc_DOUBLE_SIZE :: Int, pc_CINT_SIZE :: Int, pc_CLONG_SIZE :: Int, pc_CLONG_LONG_SIZE :: Int, pc_BITMAP_BITS_SHIFT :: Int, pc_TAG_BITS :: Int, pc_WORDS_BIGENDIAN :: Bool, pc_DYNAMIC_BY_DEFAULT :: Bool, pc_LDV_SHIFT :: Int, pc_ILDV_CREATE_MASK :: Integer, pc_ILDV_STATE_CREATE :: Integer, pc_ILDV_STATE_USE :: Integer } deriving Read ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl0000644000000000000000000002363313713636035025345 0ustar0000000000000000primOpCanFail IntQuotOp = True primOpCanFail IntRemOp = True primOpCanFail IntQuotRemOp = True primOpCanFail Int8QuotOp = True primOpCanFail Int8RemOp = True primOpCanFail Int8QuotRemOp = True primOpCanFail Word8QuotOp = True primOpCanFail Word8RemOp = True primOpCanFail Word8QuotRemOp = True primOpCanFail Int16QuotOp = True primOpCanFail Int16RemOp = True primOpCanFail Int16QuotRemOp = True primOpCanFail Word16QuotOp = True primOpCanFail Word16RemOp = True primOpCanFail Word16QuotRemOp = True primOpCanFail WordQuotOp = True primOpCanFail WordRemOp = True primOpCanFail WordQuotRemOp = True primOpCanFail WordQuotRem2Op = True primOpCanFail DoubleDivOp = True primOpCanFail DoubleLogOp = True primOpCanFail DoubleLog1POp = True primOpCanFail DoubleAsinOp = True primOpCanFail DoubleAcosOp = True primOpCanFail FloatDivOp = True primOpCanFail FloatLogOp = True primOpCanFail FloatLog1POp = True primOpCanFail FloatAsinOp = True primOpCanFail FloatAcosOp = True primOpCanFail ReadArrayOp = True primOpCanFail WriteArrayOp = True primOpCanFail IndexArrayOp = True primOpCanFail CopyArrayOp = True primOpCanFail CopyMutableArrayOp = True primOpCanFail CloneArrayOp = True primOpCanFail CloneMutableArrayOp = True primOpCanFail FreezeArrayOp = True primOpCanFail ThawArrayOp = True primOpCanFail ReadSmallArrayOp = True primOpCanFail WriteSmallArrayOp = True primOpCanFail IndexSmallArrayOp = True primOpCanFail CopySmallArrayOp = True primOpCanFail CopySmallMutableArrayOp = True primOpCanFail CloneSmallArrayOp = True primOpCanFail CloneSmallMutableArrayOp = True primOpCanFail FreezeSmallArrayOp = True primOpCanFail ThawSmallArrayOp = True primOpCanFail IndexByteArrayOp_Char = True primOpCanFail IndexByteArrayOp_WideChar = True primOpCanFail IndexByteArrayOp_Int = True primOpCanFail IndexByteArrayOp_Word = True primOpCanFail IndexByteArrayOp_Addr = True primOpCanFail IndexByteArrayOp_Float = True primOpCanFail IndexByteArrayOp_Double = True primOpCanFail IndexByteArrayOp_StablePtr = True primOpCanFail IndexByteArrayOp_Int8 = True primOpCanFail IndexByteArrayOp_Int16 = True primOpCanFail IndexByteArrayOp_Int32 = True primOpCanFail IndexByteArrayOp_Int64 = True primOpCanFail IndexByteArrayOp_Word8 = True primOpCanFail IndexByteArrayOp_Word16 = True primOpCanFail IndexByteArrayOp_Word32 = True primOpCanFail IndexByteArrayOp_Word64 = True primOpCanFail IndexByteArrayOp_Word8AsChar = True primOpCanFail IndexByteArrayOp_Word8AsWideChar = True primOpCanFail IndexByteArrayOp_Word8AsAddr = True primOpCanFail IndexByteArrayOp_Word8AsFloat = True primOpCanFail IndexByteArrayOp_Word8AsDouble = True primOpCanFail IndexByteArrayOp_Word8AsStablePtr = True primOpCanFail IndexByteArrayOp_Word8AsInt16 = True primOpCanFail IndexByteArrayOp_Word8AsInt32 = True primOpCanFail IndexByteArrayOp_Word8AsInt64 = True primOpCanFail IndexByteArrayOp_Word8AsInt = True primOpCanFail IndexByteArrayOp_Word8AsWord16 = True primOpCanFail IndexByteArrayOp_Word8AsWord32 = True primOpCanFail IndexByteArrayOp_Word8AsWord64 = True primOpCanFail IndexByteArrayOp_Word8AsWord = True primOpCanFail ReadByteArrayOp_Char = True primOpCanFail ReadByteArrayOp_WideChar = True primOpCanFail ReadByteArrayOp_Int = True primOpCanFail ReadByteArrayOp_Word = True primOpCanFail ReadByteArrayOp_Addr = True primOpCanFail ReadByteArrayOp_Float = True primOpCanFail ReadByteArrayOp_Double = True primOpCanFail ReadByteArrayOp_StablePtr = True primOpCanFail ReadByteArrayOp_Int8 = True primOpCanFail ReadByteArrayOp_Int16 = True primOpCanFail ReadByteArrayOp_Int32 = True primOpCanFail ReadByteArrayOp_Int64 = True primOpCanFail ReadByteArrayOp_Word8 = True primOpCanFail ReadByteArrayOp_Word16 = True primOpCanFail ReadByteArrayOp_Word32 = True primOpCanFail ReadByteArrayOp_Word64 = True primOpCanFail ReadByteArrayOp_Word8AsChar = True primOpCanFail ReadByteArrayOp_Word8AsWideChar = True primOpCanFail ReadByteArrayOp_Word8AsAddr = True primOpCanFail ReadByteArrayOp_Word8AsFloat = True primOpCanFail ReadByteArrayOp_Word8AsDouble = True primOpCanFail ReadByteArrayOp_Word8AsStablePtr = True primOpCanFail ReadByteArrayOp_Word8AsInt16 = True primOpCanFail ReadByteArrayOp_Word8AsInt32 = True primOpCanFail ReadByteArrayOp_Word8AsInt64 = True primOpCanFail ReadByteArrayOp_Word8AsInt = True primOpCanFail ReadByteArrayOp_Word8AsWord16 = True primOpCanFail ReadByteArrayOp_Word8AsWord32 = True primOpCanFail ReadByteArrayOp_Word8AsWord64 = True primOpCanFail ReadByteArrayOp_Word8AsWord = True primOpCanFail WriteByteArrayOp_Char = True primOpCanFail WriteByteArrayOp_WideChar = True primOpCanFail WriteByteArrayOp_Int = True primOpCanFail WriteByteArrayOp_Word = True primOpCanFail WriteByteArrayOp_Addr = True primOpCanFail WriteByteArrayOp_Float = True primOpCanFail WriteByteArrayOp_Double = True primOpCanFail WriteByteArrayOp_StablePtr = True primOpCanFail WriteByteArrayOp_Int8 = True primOpCanFail WriteByteArrayOp_Int16 = True primOpCanFail WriteByteArrayOp_Int32 = True primOpCanFail WriteByteArrayOp_Int64 = True primOpCanFail WriteByteArrayOp_Word8 = True primOpCanFail WriteByteArrayOp_Word16 = True primOpCanFail WriteByteArrayOp_Word32 = True primOpCanFail WriteByteArrayOp_Word64 = True primOpCanFail WriteByteArrayOp_Word8AsChar = True primOpCanFail WriteByteArrayOp_Word8AsWideChar = True primOpCanFail WriteByteArrayOp_Word8AsAddr = True primOpCanFail WriteByteArrayOp_Word8AsFloat = True primOpCanFail WriteByteArrayOp_Word8AsDouble = True primOpCanFail WriteByteArrayOp_Word8AsStablePtr = True primOpCanFail WriteByteArrayOp_Word8AsInt16 = True primOpCanFail WriteByteArrayOp_Word8AsInt32 = True primOpCanFail WriteByteArrayOp_Word8AsInt64 = True primOpCanFail WriteByteArrayOp_Word8AsInt = True primOpCanFail WriteByteArrayOp_Word8AsWord16 = True primOpCanFail WriteByteArrayOp_Word8AsWord32 = True primOpCanFail WriteByteArrayOp_Word8AsWord64 = True primOpCanFail WriteByteArrayOp_Word8AsWord = True primOpCanFail CompareByteArraysOp = True primOpCanFail CopyByteArrayOp = True primOpCanFail CopyMutableByteArrayOp = True primOpCanFail CopyByteArrayToAddrOp = True primOpCanFail CopyMutableByteArrayToAddrOp = True primOpCanFail CopyAddrToByteArrayOp = True primOpCanFail SetByteArrayOp = True primOpCanFail AtomicReadByteArrayOp_Int = True primOpCanFail AtomicWriteByteArrayOp_Int = True primOpCanFail CasByteArrayOp_Int = True primOpCanFail FetchAddByteArrayOp_Int = True primOpCanFail FetchSubByteArrayOp_Int = True primOpCanFail FetchAndByteArrayOp_Int = True primOpCanFail FetchNandByteArrayOp_Int = True primOpCanFail FetchOrByteArrayOp_Int = True primOpCanFail FetchXorByteArrayOp_Int = True primOpCanFail IndexArrayArrayOp_ByteArray = True primOpCanFail IndexArrayArrayOp_ArrayArray = True primOpCanFail ReadArrayArrayOp_ByteArray = True primOpCanFail ReadArrayArrayOp_MutableByteArray = True primOpCanFail ReadArrayArrayOp_ArrayArray = True primOpCanFail ReadArrayArrayOp_MutableArrayArray = True primOpCanFail WriteArrayArrayOp_ByteArray = True primOpCanFail WriteArrayArrayOp_MutableByteArray = True primOpCanFail WriteArrayArrayOp_ArrayArray = True primOpCanFail WriteArrayArrayOp_MutableArrayArray = True primOpCanFail CopyArrayArrayOp = True primOpCanFail CopyMutableArrayArrayOp = True primOpCanFail IndexOffAddrOp_Char = True primOpCanFail IndexOffAddrOp_WideChar = True primOpCanFail IndexOffAddrOp_Int = True primOpCanFail IndexOffAddrOp_Word = True primOpCanFail IndexOffAddrOp_Addr = True primOpCanFail IndexOffAddrOp_Float = True primOpCanFail IndexOffAddrOp_Double = True primOpCanFail IndexOffAddrOp_StablePtr = True primOpCanFail IndexOffAddrOp_Int8 = True primOpCanFail IndexOffAddrOp_Int16 = True primOpCanFail IndexOffAddrOp_Int32 = True primOpCanFail IndexOffAddrOp_Int64 = True primOpCanFail IndexOffAddrOp_Word8 = True primOpCanFail IndexOffAddrOp_Word16 = True primOpCanFail IndexOffAddrOp_Word32 = True primOpCanFail IndexOffAddrOp_Word64 = True primOpCanFail ReadOffAddrOp_Char = True primOpCanFail ReadOffAddrOp_WideChar = True primOpCanFail ReadOffAddrOp_Int = True primOpCanFail ReadOffAddrOp_Word = True primOpCanFail ReadOffAddrOp_Addr = True primOpCanFail ReadOffAddrOp_Float = True primOpCanFail ReadOffAddrOp_Double = True primOpCanFail ReadOffAddrOp_StablePtr = True primOpCanFail ReadOffAddrOp_Int8 = True primOpCanFail ReadOffAddrOp_Int16 = True primOpCanFail ReadOffAddrOp_Int32 = True primOpCanFail ReadOffAddrOp_Int64 = True primOpCanFail ReadOffAddrOp_Word8 = True primOpCanFail ReadOffAddrOp_Word16 = True primOpCanFail ReadOffAddrOp_Word32 = True primOpCanFail ReadOffAddrOp_Word64 = True primOpCanFail WriteOffAddrOp_Char = True primOpCanFail WriteOffAddrOp_WideChar = True primOpCanFail WriteOffAddrOp_Int = True primOpCanFail WriteOffAddrOp_Word = True primOpCanFail WriteOffAddrOp_Addr = True primOpCanFail WriteOffAddrOp_Float = True primOpCanFail WriteOffAddrOp_Double = True primOpCanFail WriteOffAddrOp_StablePtr = True primOpCanFail WriteOffAddrOp_Int8 = True primOpCanFail WriteOffAddrOp_Int16 = True primOpCanFail WriteOffAddrOp_Int32 = True primOpCanFail WriteOffAddrOp_Int64 = True primOpCanFail WriteOffAddrOp_Word8 = True primOpCanFail WriteOffAddrOp_Word16 = True primOpCanFail WriteOffAddrOp_Word32 = True primOpCanFail WriteOffAddrOp_Word64 = True primOpCanFail AtomicModifyMutVar2Op = True primOpCanFail AtomicModifyMutVar_Op = True primOpCanFail ReallyUnsafePtrEqualityOp = True primOpCanFail (VecInsertOp _ _ _) = True primOpCanFail (VecDivOp _ _ _) = True primOpCanFail (VecQuotOp _ _ _) = True primOpCanFail (VecRemOp _ _ _) = True primOpCanFail (VecIndexByteArrayOp _ _ _) = True primOpCanFail (VecReadByteArrayOp _ _ _) = True primOpCanFail (VecWriteByteArrayOp _ _ _) = True primOpCanFail (VecIndexOffAddrOp _ _ _) = True primOpCanFail (VecReadOffAddrOp _ _ _) = True primOpCanFail (VecWriteOffAddrOp _ _ _) = True primOpCanFail (VecIndexScalarByteArrayOp _ _ _) = True primOpCanFail (VecReadScalarByteArrayOp _ _ _) = True primOpCanFail (VecWriteScalarByteArrayOp _ _ _) = True primOpCanFail (VecIndexScalarOffAddrOp _ _ _) = True primOpCanFail (VecReadScalarOffAddrOp _ _ _) = True primOpCanFail (VecWriteScalarOffAddrOp _ _ _) = True primOpCanFail _ = False ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl0000644000000000000000000000610013713636035025543 0ustar0000000000000000primOpCodeSize OrdOp = 0 primOpCodeSize IntAddCOp = 2 primOpCodeSize IntSubCOp = 2 primOpCodeSize ChrOp = 0 primOpCodeSize Int2WordOp = 0 primOpCodeSize WordAddCOp = 2 primOpCodeSize WordSubCOp = 2 primOpCodeSize WordAdd2Op = 2 primOpCodeSize Word2IntOp = 0 primOpCodeSize DoubleExpOp = primOpCodeSizeForeignCall primOpCodeSize DoubleExpM1Op = primOpCodeSizeForeignCall primOpCodeSize DoubleLogOp = primOpCodeSizeForeignCall primOpCodeSize DoubleLog1POp = primOpCodeSizeForeignCall primOpCodeSize DoubleSqrtOp = primOpCodeSizeForeignCall primOpCodeSize DoubleSinOp = primOpCodeSizeForeignCall primOpCodeSize DoubleCosOp = primOpCodeSizeForeignCall primOpCodeSize DoubleTanOp = primOpCodeSizeForeignCall primOpCodeSize DoubleAsinOp = primOpCodeSizeForeignCall primOpCodeSize DoubleAcosOp = primOpCodeSizeForeignCall primOpCodeSize DoubleAtanOp = primOpCodeSizeForeignCall primOpCodeSize DoubleSinhOp = primOpCodeSizeForeignCall primOpCodeSize DoubleCoshOp = primOpCodeSizeForeignCall primOpCodeSize DoubleTanhOp = primOpCodeSizeForeignCall primOpCodeSize DoubleAsinhOp = primOpCodeSizeForeignCall primOpCodeSize DoubleAcoshOp = primOpCodeSizeForeignCall primOpCodeSize DoubleAtanhOp = primOpCodeSizeForeignCall primOpCodeSize DoublePowerOp = primOpCodeSizeForeignCall primOpCodeSize FloatExpOp = primOpCodeSizeForeignCall primOpCodeSize FloatExpM1Op = primOpCodeSizeForeignCall primOpCodeSize FloatLogOp = primOpCodeSizeForeignCall primOpCodeSize FloatLog1POp = primOpCodeSizeForeignCall primOpCodeSize FloatSqrtOp = primOpCodeSizeForeignCall primOpCodeSize FloatSinOp = primOpCodeSizeForeignCall primOpCodeSize FloatCosOp = primOpCodeSizeForeignCall primOpCodeSize FloatTanOp = primOpCodeSizeForeignCall primOpCodeSize FloatAsinOp = primOpCodeSizeForeignCall primOpCodeSize FloatAcosOp = primOpCodeSizeForeignCall primOpCodeSize FloatAtanOp = primOpCodeSizeForeignCall primOpCodeSize FloatSinhOp = primOpCodeSizeForeignCall primOpCodeSize FloatCoshOp = primOpCodeSizeForeignCall primOpCodeSize FloatTanhOp = primOpCodeSizeForeignCall primOpCodeSize FloatAsinhOp = primOpCodeSizeForeignCall primOpCodeSize FloatAcoshOp = primOpCodeSizeForeignCall primOpCodeSize FloatAtanhOp = primOpCodeSizeForeignCall primOpCodeSize FloatPowerOp = primOpCodeSizeForeignCall primOpCodeSize WriteArrayOp = 2 primOpCodeSize CopyByteArrayOp = primOpCodeSizeForeignCall + 4 primOpCodeSize CopyMutableByteArrayOp = primOpCodeSizeForeignCall + 4 primOpCodeSize CopyByteArrayToAddrOp = primOpCodeSizeForeignCall + 4 primOpCodeSize CopyMutableByteArrayToAddrOp = primOpCodeSizeForeignCall + 4 primOpCodeSize CopyAddrToByteArrayOp = primOpCodeSizeForeignCall + 4 primOpCodeSize SetByteArrayOp = primOpCodeSizeForeignCall + 4 primOpCodeSize Addr2IntOp = 0 primOpCodeSize Int2AddrOp = 0 primOpCodeSize WriteMutVarOp = primOpCodeSizeForeignCall primOpCodeSize TouchOp = 0 primOpCodeSize ParOp = primOpCodeSizeForeignCall primOpCodeSize SparkOp = primOpCodeSizeForeignCall primOpCodeSize AddrToAnyOp = 0 primOpCodeSize AnyToAddrOp = 0 primOpCodeSize _ = primOpCodeSizeDefault ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/primop-commutable.hs-incl0000644000000000000000000000216513713636035026020 0ustar0000000000000000commutableOp CharEqOp = True commutableOp CharNeOp = True commutableOp IntAddOp = True commutableOp IntMulOp = True commutableOp IntMulMayOfloOp = True commutableOp AndIOp = True commutableOp OrIOp = True commutableOp XorIOp = True commutableOp IntAddCOp = True commutableOp IntEqOp = True commutableOp IntNeOp = True commutableOp Int8AddOp = True commutableOp Int8MulOp = True commutableOp Word8AddOp = True commutableOp Word8MulOp = True commutableOp Int16AddOp = True commutableOp Int16MulOp = True commutableOp Word16AddOp = True commutableOp Word16MulOp = True commutableOp WordAddOp = True commutableOp WordAddCOp = True commutableOp WordAdd2Op = True commutableOp WordMulOp = True commutableOp WordMul2Op = True commutableOp AndOp = True commutableOp OrOp = True commutableOp XorOp = True commutableOp DoubleEqOp = True commutableOp DoubleNeOp = True commutableOp DoubleAddOp = True commutableOp DoubleMulOp = True commutableOp FloatEqOp = True commutableOp FloatNeOp = True commutableOp FloatAddOp = True commutableOp FloatMulOp = True commutableOp (VecAddOp _ _ _) = True commutableOp (VecMulOp _ _ _) = True commutableOp _ = False ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl0000644000000000000000000003154713713636035025514 0ustar0000000000000000data PrimOp = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | OrdOp | IntAddOp | IntSubOp | IntMulOp | IntMulMayOfloOp | IntQuotOp | IntRemOp | IntQuotRemOp | AndIOp | OrIOp | XorIOp | NotIOp | IntNegOp | IntAddCOp | IntSubCOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | ChrOp | Int2WordOp | Int2FloatOp | Int2DoubleOp | Word2FloatOp | Word2DoubleOp | ISllOp | ISraOp | ISrlOp | Int8Extend | Int8Narrow | Int8NegOp | Int8AddOp | Int8SubOp | Int8MulOp | Int8QuotOp | Int8RemOp | Int8QuotRemOp | Int8EqOp | Int8GeOp | Int8GtOp | Int8LeOp | Int8LtOp | Int8NeOp | Word8Extend | Word8Narrow | Word8NotOp | Word8AddOp | Word8SubOp | Word8MulOp | Word8QuotOp | Word8RemOp | Word8QuotRemOp | Word8EqOp | Word8GeOp | Word8GtOp | Word8LeOp | Word8LtOp | Word8NeOp | Int16Extend | Int16Narrow | Int16NegOp | Int16AddOp | Int16SubOp | Int16MulOp | Int16QuotOp | Int16RemOp | Int16QuotRemOp | Int16EqOp | Int16GeOp | Int16GtOp | Int16LeOp | Int16LtOp | Int16NeOp | Word16Extend | Word16Narrow | Word16NotOp | Word16AddOp | Word16SubOp | Word16MulOp | Word16QuotOp | Word16RemOp | Word16QuotRemOp | Word16EqOp | Word16GeOp | Word16GtOp | Word16LeOp | Word16LtOp | Word16NeOp | WordAddOp | WordAddCOp | WordSubCOp | WordAdd2Op | WordSubOp | WordMulOp | WordMul2Op | WordQuotOp | WordRemOp | WordQuotRemOp | WordQuotRem2Op | AndOp | OrOp | XorOp | NotOp | SllOp | SrlOp | Word2IntOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | PopCnt8Op | PopCnt16Op | PopCnt32Op | PopCnt64Op | PopCntOp | Pdep8Op | Pdep16Op | Pdep32Op | Pdep64Op | PdepOp | Pext8Op | Pext16Op | Pext32Op | Pext64Op | PextOp | Clz8Op | Clz16Op | Clz32Op | Clz64Op | ClzOp | Ctz8Op | Ctz16Op | Ctz32Op | Ctz64Op | CtzOp | BSwap16Op | BSwap32Op | BSwap64Op | BSwapOp | BRev8Op | BRev16Op | BRev32Op | BRev64Op | BRevOp | Narrow8IntOp | Narrow16IntOp | Narrow32IntOp | Narrow8WordOp | Narrow16WordOp | Narrow32WordOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | DoubleFabsOp | Double2IntOp | Double2FloatOp | DoubleExpOp | DoubleExpM1Op | DoubleLogOp | DoubleLog1POp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoubleAsinhOp | DoubleAcoshOp | DoubleAtanhOp | DoublePowerOp | DoubleDecode_2IntOp | DoubleDecode_Int64Op | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | FloatFabsOp | Float2IntOp | FloatExpOp | FloatExpM1Op | FloatLogOp | FloatLog1POp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatAsinhOp | FloatAcoshOp | FloatAtanhOp | FloatPowerOp | Float2DoubleOp | FloatDecode_IntOp | NewArrayOp | SameMutableArrayOp | ReadArrayOp | WriteArrayOp | SizeofArrayOp | SizeofMutableArrayOp | IndexArrayOp | UnsafeFreezeArrayOp | UnsafeThawArrayOp | CopyArrayOp | CopyMutableArrayOp | CloneArrayOp | CloneMutableArrayOp | FreezeArrayOp | ThawArrayOp | CasArrayOp | NewSmallArrayOp | SameSmallMutableArrayOp | ShrinkSmallMutableArrayOp_Char | ReadSmallArrayOp | WriteSmallArrayOp | SizeofSmallArrayOp | SizeofSmallMutableArrayOp | GetSizeofSmallMutableArrayOp | IndexSmallArrayOp | UnsafeFreezeSmallArrayOp | UnsafeThawSmallArrayOp | CopySmallArrayOp | CopySmallMutableArrayOp | CloneSmallArrayOp | CloneSmallMutableArrayOp | FreezeSmallArrayOp | ThawSmallArrayOp | CasSmallArrayOp | NewByteArrayOp_Char | NewPinnedByteArrayOp_Char | NewAlignedPinnedByteArrayOp_Char | MutableByteArrayIsPinnedOp | ByteArrayIsPinnedOp | ByteArrayContents_Char | SameMutableByteArrayOp | ShrinkMutableByteArrayOp_Char | ResizeMutableByteArrayOp_Char | UnsafeFreezeByteArrayOp | SizeofByteArrayOp | SizeofMutableByteArrayOp | GetSizeofMutableByteArrayOp | IndexByteArrayOp_Char | IndexByteArrayOp_WideChar | IndexByteArrayOp_Int | IndexByteArrayOp_Word | IndexByteArrayOp_Addr | IndexByteArrayOp_Float | IndexByteArrayOp_Double | IndexByteArrayOp_StablePtr | IndexByteArrayOp_Int8 | IndexByteArrayOp_Int16 | IndexByteArrayOp_Int32 | IndexByteArrayOp_Int64 | IndexByteArrayOp_Word8 | IndexByteArrayOp_Word16 | IndexByteArrayOp_Word32 | IndexByteArrayOp_Word64 | IndexByteArrayOp_Word8AsChar | IndexByteArrayOp_Word8AsWideChar | IndexByteArrayOp_Word8AsAddr | IndexByteArrayOp_Word8AsFloat | IndexByteArrayOp_Word8AsDouble | IndexByteArrayOp_Word8AsStablePtr | IndexByteArrayOp_Word8AsInt16 | IndexByteArrayOp_Word8AsInt32 | IndexByteArrayOp_Word8AsInt64 | IndexByteArrayOp_Word8AsInt | IndexByteArrayOp_Word8AsWord16 | IndexByteArrayOp_Word8AsWord32 | IndexByteArrayOp_Word8AsWord64 | IndexByteArrayOp_Word8AsWord | ReadByteArrayOp_Char | ReadByteArrayOp_WideChar | ReadByteArrayOp_Int | ReadByteArrayOp_Word | ReadByteArrayOp_Addr | ReadByteArrayOp_Float | ReadByteArrayOp_Double | ReadByteArrayOp_StablePtr | ReadByteArrayOp_Int8 | ReadByteArrayOp_Int16 | ReadByteArrayOp_Int32 | ReadByteArrayOp_Int64 | ReadByteArrayOp_Word8 | ReadByteArrayOp_Word16 | ReadByteArrayOp_Word32 | ReadByteArrayOp_Word64 | ReadByteArrayOp_Word8AsChar | ReadByteArrayOp_Word8AsWideChar | ReadByteArrayOp_Word8AsAddr | ReadByteArrayOp_Word8AsFloat | ReadByteArrayOp_Word8AsDouble | ReadByteArrayOp_Word8AsStablePtr | ReadByteArrayOp_Word8AsInt16 | ReadByteArrayOp_Word8AsInt32 | ReadByteArrayOp_Word8AsInt64 | ReadByteArrayOp_Word8AsInt | ReadByteArrayOp_Word8AsWord16 | ReadByteArrayOp_Word8AsWord32 | ReadByteArrayOp_Word8AsWord64 | ReadByteArrayOp_Word8AsWord | WriteByteArrayOp_Char | WriteByteArrayOp_WideChar | WriteByteArrayOp_Int | WriteByteArrayOp_Word | WriteByteArrayOp_Addr | WriteByteArrayOp_Float | WriteByteArrayOp_Double | WriteByteArrayOp_StablePtr | WriteByteArrayOp_Int8 | WriteByteArrayOp_Int16 | WriteByteArrayOp_Int32 | WriteByteArrayOp_Int64 | WriteByteArrayOp_Word8 | WriteByteArrayOp_Word16 | WriteByteArrayOp_Word32 | WriteByteArrayOp_Word64 | WriteByteArrayOp_Word8AsChar | WriteByteArrayOp_Word8AsWideChar | WriteByteArrayOp_Word8AsAddr | WriteByteArrayOp_Word8AsFloat | WriteByteArrayOp_Word8AsDouble | WriteByteArrayOp_Word8AsStablePtr | WriteByteArrayOp_Word8AsInt16 | WriteByteArrayOp_Word8AsInt32 | WriteByteArrayOp_Word8AsInt64 | WriteByteArrayOp_Word8AsInt | WriteByteArrayOp_Word8AsWord16 | WriteByteArrayOp_Word8AsWord32 | WriteByteArrayOp_Word8AsWord64 | WriteByteArrayOp_Word8AsWord | CompareByteArraysOp | CopyByteArrayOp | CopyMutableByteArrayOp | CopyByteArrayToAddrOp | CopyMutableByteArrayToAddrOp | CopyAddrToByteArrayOp | SetByteArrayOp | AtomicReadByteArrayOp_Int | AtomicWriteByteArrayOp_Int | CasByteArrayOp_Int | FetchAddByteArrayOp_Int | FetchSubByteArrayOp_Int | FetchAndByteArrayOp_Int | FetchNandByteArrayOp_Int | FetchOrByteArrayOp_Int | FetchXorByteArrayOp_Int | NewArrayArrayOp | SameMutableArrayArrayOp | UnsafeFreezeArrayArrayOp | SizeofArrayArrayOp | SizeofMutableArrayArrayOp | IndexArrayArrayOp_ByteArray | IndexArrayArrayOp_ArrayArray | ReadArrayArrayOp_ByteArray | ReadArrayArrayOp_MutableByteArray | ReadArrayArrayOp_ArrayArray | ReadArrayArrayOp_MutableArrayArray | WriteArrayArrayOp_ByteArray | WriteArrayArrayOp_MutableByteArray | WriteArrayArrayOp_ArrayArray | WriteArrayArrayOp_MutableArrayArray | CopyArrayArrayOp | CopyMutableArrayArrayOp | AddrAddOp | AddrSubOp | AddrRemOp | Addr2IntOp | Int2AddrOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | IndexOffAddrOp_Char | IndexOffAddrOp_WideChar | IndexOffAddrOp_Int | IndexOffAddrOp_Word | IndexOffAddrOp_Addr | IndexOffAddrOp_Float | IndexOffAddrOp_Double | IndexOffAddrOp_StablePtr | IndexOffAddrOp_Int8 | IndexOffAddrOp_Int16 | IndexOffAddrOp_Int32 | IndexOffAddrOp_Int64 | IndexOffAddrOp_Word8 | IndexOffAddrOp_Word16 | IndexOffAddrOp_Word32 | IndexOffAddrOp_Word64 | ReadOffAddrOp_Char | ReadOffAddrOp_WideChar | ReadOffAddrOp_Int | ReadOffAddrOp_Word | ReadOffAddrOp_Addr | ReadOffAddrOp_Float | ReadOffAddrOp_Double | ReadOffAddrOp_StablePtr | ReadOffAddrOp_Int8 | ReadOffAddrOp_Int16 | ReadOffAddrOp_Int32 | ReadOffAddrOp_Int64 | ReadOffAddrOp_Word8 | ReadOffAddrOp_Word16 | ReadOffAddrOp_Word32 | ReadOffAddrOp_Word64 | WriteOffAddrOp_Char | WriteOffAddrOp_WideChar | WriteOffAddrOp_Int | WriteOffAddrOp_Word | WriteOffAddrOp_Addr | WriteOffAddrOp_Float | WriteOffAddrOp_Double | WriteOffAddrOp_StablePtr | WriteOffAddrOp_Int8 | WriteOffAddrOp_Int16 | WriteOffAddrOp_Int32 | WriteOffAddrOp_Int64 | WriteOffAddrOp_Word8 | WriteOffAddrOp_Word16 | WriteOffAddrOp_Word32 | WriteOffAddrOp_Word64 | NewMutVarOp | ReadMutVarOp | WriteMutVarOp | SameMutVarOp | AtomicModifyMutVar2Op | AtomicModifyMutVar_Op | CasMutVarOp | CatchOp | RaiseOp | RaiseIOOp | MaskAsyncExceptionsOp | MaskUninterruptibleOp | UnmaskAsyncExceptionsOp | MaskStatus | AtomicallyOp | RetryOp | CatchRetryOp | CatchSTMOp | NewTVarOp | ReadTVarOp | ReadTVarIOOp | WriteTVarOp | SameTVarOp | NewMVarOp | TakeMVarOp | TryTakeMVarOp | PutMVarOp | TryPutMVarOp | ReadMVarOp | TryReadMVarOp | SameMVarOp | IsEmptyMVarOp | DelayOp | WaitReadOp | WaitWriteOp | ForkOp | ForkOnOp | KillThreadOp | YieldOp | MyThreadIdOp | LabelThreadOp | IsCurrentThreadBoundOp | NoDuplicateOp | ThreadStatusOp | MkWeakOp | MkWeakNoFinalizerOp | AddCFinalizerToWeakOp | DeRefWeakOp | FinalizeWeakOp | TouchOp | MakeStablePtrOp | DeRefStablePtrOp | EqStablePtrOp | MakeStableNameOp | EqStableNameOp | StableNameToIntOp | CompactNewOp | CompactResizeOp | CompactContainsOp | CompactContainsAnyOp | CompactGetFirstBlockOp | CompactGetNextBlockOp | CompactAllocateBlockOp | CompactFixupPointersOp | CompactAdd | CompactAddWithSharing | CompactSize | ReallyUnsafePtrEqualityOp | ParOp | SparkOp | SeqOp | GetSparkOp | NumSparks | DataToTagOp | TagToEnumOp | AddrToAnyOp | AnyToAddrOp | MkApUpd0_Op | NewBCOOp | UnpackClosureOp | ClosureSizeOp | GetApStackValOp | GetCCSOfOp | GetCurrentCCSOp | ClearCCSOp | TraceEventOp | TraceEventBinaryOp | TraceMarkerOp | SetThreadAllocationCounter | VecBroadcastOp PrimOpVecCat Length Width | VecPackOp PrimOpVecCat Length Width | VecUnpackOp PrimOpVecCat Length Width | VecInsertOp PrimOpVecCat Length Width | VecAddOp PrimOpVecCat Length Width | VecSubOp PrimOpVecCat Length Width | VecMulOp PrimOpVecCat Length Width | VecDivOp PrimOpVecCat Length Width | VecQuotOp PrimOpVecCat Length Width | VecRemOp PrimOpVecCat Length Width | VecNegOp PrimOpVecCat Length Width | VecIndexByteArrayOp PrimOpVecCat Length Width | VecReadByteArrayOp PrimOpVecCat Length Width | VecWriteByteArrayOp PrimOpVecCat Length Width | VecIndexOffAddrOp PrimOpVecCat Length Width | VecReadOffAddrOp PrimOpVecCat Length Width | VecWriteOffAddrOp PrimOpVecCat Length Width | VecIndexScalarByteArrayOp PrimOpVecCat Length Width | VecReadScalarByteArrayOp PrimOpVecCat Length Width | VecWriteScalarByteArrayOp PrimOpVecCat Length Width | VecIndexScalarOffAddrOp PrimOpVecCat Length Width | VecReadScalarOffAddrOp PrimOpVecCat Length Width | VecWriteScalarOffAddrOp PrimOpVecCat Length Width | PrefetchByteArrayOp3 | PrefetchMutableByteArrayOp3 | PrefetchAddrOp3 | PrefetchValueOp3 | PrefetchByteArrayOp2 | PrefetchMutableByteArrayOp2 | PrefetchAddrOp2 | PrefetchValueOp2 | PrefetchByteArrayOp1 | PrefetchMutableByteArrayOp1 | PrefetchAddrOp1 | PrefetchValueOp1 | PrefetchByteArrayOp0 | PrefetchMutableByteArrayOp0 | PrefetchAddrOp0 | PrefetchValueOp0 ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/primop-fixity.hs-incl0000644000000000000000000000223713713636035025204 0ustar0000000000000000primOpFixity IntAddOp = Just (Fixity NoSourceText 6 InfixL) primOpFixity IntSubOp = Just (Fixity NoSourceText 6 InfixL) primOpFixity IntMulOp = Just (Fixity NoSourceText 7 InfixL) primOpFixity IntGtOp = Just (Fixity NoSourceText 4 InfixN) primOpFixity IntGeOp = Just (Fixity NoSourceText 4 InfixN) primOpFixity IntEqOp = Just (Fixity NoSourceText 4 InfixN) primOpFixity IntNeOp = Just (Fixity NoSourceText 4 InfixN) primOpFixity IntLtOp = Just (Fixity NoSourceText 4 InfixN) primOpFixity IntLeOp = Just (Fixity NoSourceText 4 InfixN) primOpFixity DoubleGtOp = Just (Fixity NoSourceText 4 InfixN) primOpFixity DoubleGeOp = Just (Fixity NoSourceText 4 InfixN) primOpFixity DoubleEqOp = Just (Fixity NoSourceText 4 InfixN) primOpFixity DoubleNeOp = Just (Fixity NoSourceText 4 InfixN) primOpFixity DoubleLtOp = Just (Fixity NoSourceText 4 InfixN) primOpFixity DoubleLeOp = Just (Fixity NoSourceText 4 InfixN) primOpFixity DoubleAddOp = Just (Fixity NoSourceText 6 InfixL) primOpFixity DoubleSubOp = Just (Fixity NoSourceText 6 InfixL) primOpFixity DoubleMulOp = Just (Fixity NoSourceText 7 InfixL) primOpFixity DoubleDivOp = Just (Fixity NoSourceText 7 InfixL) primOpFixity _ = Nothing ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl0000644000000000000000000002700413713636035027001 0ustar0000000000000000primOpHasSideEffects NewArrayOp = True primOpHasSideEffects ReadArrayOp = True primOpHasSideEffects WriteArrayOp = True primOpHasSideEffects UnsafeFreezeArrayOp = True primOpHasSideEffects UnsafeThawArrayOp = True primOpHasSideEffects CopyArrayOp = True primOpHasSideEffects CopyMutableArrayOp = True primOpHasSideEffects CloneArrayOp = True primOpHasSideEffects CloneMutableArrayOp = True primOpHasSideEffects FreezeArrayOp = True primOpHasSideEffects ThawArrayOp = True primOpHasSideEffects CasArrayOp = True primOpHasSideEffects NewSmallArrayOp = True primOpHasSideEffects ShrinkSmallMutableArrayOp_Char = True primOpHasSideEffects ReadSmallArrayOp = True primOpHasSideEffects WriteSmallArrayOp = True primOpHasSideEffects UnsafeFreezeSmallArrayOp = True primOpHasSideEffects UnsafeThawSmallArrayOp = True primOpHasSideEffects CopySmallArrayOp = True primOpHasSideEffects CopySmallMutableArrayOp = True primOpHasSideEffects CloneSmallArrayOp = True primOpHasSideEffects CloneSmallMutableArrayOp = True primOpHasSideEffects FreezeSmallArrayOp = True primOpHasSideEffects ThawSmallArrayOp = True primOpHasSideEffects CasSmallArrayOp = True primOpHasSideEffects NewByteArrayOp_Char = True primOpHasSideEffects NewPinnedByteArrayOp_Char = True primOpHasSideEffects NewAlignedPinnedByteArrayOp_Char = True primOpHasSideEffects ShrinkMutableByteArrayOp_Char = True primOpHasSideEffects ResizeMutableByteArrayOp_Char = True primOpHasSideEffects UnsafeFreezeByteArrayOp = True primOpHasSideEffects ReadByteArrayOp_Char = True primOpHasSideEffects ReadByteArrayOp_WideChar = True primOpHasSideEffects ReadByteArrayOp_Int = True primOpHasSideEffects ReadByteArrayOp_Word = True primOpHasSideEffects ReadByteArrayOp_Addr = True primOpHasSideEffects ReadByteArrayOp_Float = True primOpHasSideEffects ReadByteArrayOp_Double = True primOpHasSideEffects ReadByteArrayOp_StablePtr = True primOpHasSideEffects ReadByteArrayOp_Int8 = True primOpHasSideEffects ReadByteArrayOp_Int16 = True primOpHasSideEffects ReadByteArrayOp_Int32 = True primOpHasSideEffects ReadByteArrayOp_Int64 = True primOpHasSideEffects ReadByteArrayOp_Word8 = True primOpHasSideEffects ReadByteArrayOp_Word16 = True primOpHasSideEffects ReadByteArrayOp_Word32 = True primOpHasSideEffects ReadByteArrayOp_Word64 = True primOpHasSideEffects ReadByteArrayOp_Word8AsChar = True primOpHasSideEffects ReadByteArrayOp_Word8AsWideChar = True primOpHasSideEffects ReadByteArrayOp_Word8AsAddr = True primOpHasSideEffects ReadByteArrayOp_Word8AsFloat = True primOpHasSideEffects ReadByteArrayOp_Word8AsDouble = True primOpHasSideEffects ReadByteArrayOp_Word8AsStablePtr = True primOpHasSideEffects ReadByteArrayOp_Word8AsInt16 = True primOpHasSideEffects ReadByteArrayOp_Word8AsInt32 = True primOpHasSideEffects ReadByteArrayOp_Word8AsInt64 = True primOpHasSideEffects ReadByteArrayOp_Word8AsInt = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord16 = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord32 = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord64 = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord = True primOpHasSideEffects WriteByteArrayOp_Char = True primOpHasSideEffects WriteByteArrayOp_WideChar = True primOpHasSideEffects WriteByteArrayOp_Int = True primOpHasSideEffects WriteByteArrayOp_Word = True primOpHasSideEffects WriteByteArrayOp_Addr = True primOpHasSideEffects WriteByteArrayOp_Float = True primOpHasSideEffects WriteByteArrayOp_Double = True primOpHasSideEffects WriteByteArrayOp_StablePtr = True primOpHasSideEffects WriteByteArrayOp_Int8 = True primOpHasSideEffects WriteByteArrayOp_Int16 = True primOpHasSideEffects WriteByteArrayOp_Int32 = True primOpHasSideEffects WriteByteArrayOp_Int64 = True primOpHasSideEffects WriteByteArrayOp_Word8 = True primOpHasSideEffects WriteByteArrayOp_Word16 = True primOpHasSideEffects WriteByteArrayOp_Word32 = True primOpHasSideEffects WriteByteArrayOp_Word64 = True primOpHasSideEffects WriteByteArrayOp_Word8AsChar = True primOpHasSideEffects WriteByteArrayOp_Word8AsWideChar = True primOpHasSideEffects WriteByteArrayOp_Word8AsAddr = True primOpHasSideEffects WriteByteArrayOp_Word8AsFloat = True primOpHasSideEffects WriteByteArrayOp_Word8AsDouble = True primOpHasSideEffects WriteByteArrayOp_Word8AsStablePtr = True primOpHasSideEffects WriteByteArrayOp_Word8AsInt16 = True primOpHasSideEffects WriteByteArrayOp_Word8AsInt32 = True primOpHasSideEffects WriteByteArrayOp_Word8AsInt64 = True primOpHasSideEffects WriteByteArrayOp_Word8AsInt = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord16 = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord32 = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord64 = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord = True primOpHasSideEffects CopyByteArrayOp = True primOpHasSideEffects CopyMutableByteArrayOp = True primOpHasSideEffects CopyByteArrayToAddrOp = True primOpHasSideEffects CopyMutableByteArrayToAddrOp = True primOpHasSideEffects CopyAddrToByteArrayOp = True primOpHasSideEffects SetByteArrayOp = True primOpHasSideEffects AtomicReadByteArrayOp_Int = True primOpHasSideEffects AtomicWriteByteArrayOp_Int = True primOpHasSideEffects CasByteArrayOp_Int = True primOpHasSideEffects FetchAddByteArrayOp_Int = True primOpHasSideEffects FetchSubByteArrayOp_Int = True primOpHasSideEffects FetchAndByteArrayOp_Int = True primOpHasSideEffects FetchNandByteArrayOp_Int = True primOpHasSideEffects FetchOrByteArrayOp_Int = True primOpHasSideEffects FetchXorByteArrayOp_Int = True primOpHasSideEffects NewArrayArrayOp = True primOpHasSideEffects UnsafeFreezeArrayArrayOp = True primOpHasSideEffects ReadArrayArrayOp_ByteArray = True primOpHasSideEffects ReadArrayArrayOp_MutableByteArray = True primOpHasSideEffects ReadArrayArrayOp_ArrayArray = True primOpHasSideEffects ReadArrayArrayOp_MutableArrayArray = True primOpHasSideEffects WriteArrayArrayOp_ByteArray = True primOpHasSideEffects WriteArrayArrayOp_MutableByteArray = True primOpHasSideEffects WriteArrayArrayOp_ArrayArray = True primOpHasSideEffects WriteArrayArrayOp_MutableArrayArray = True primOpHasSideEffects CopyArrayArrayOp = True primOpHasSideEffects CopyMutableArrayArrayOp = True primOpHasSideEffects ReadOffAddrOp_Char = True primOpHasSideEffects ReadOffAddrOp_WideChar = True primOpHasSideEffects ReadOffAddrOp_Int = True primOpHasSideEffects ReadOffAddrOp_Word = True primOpHasSideEffects ReadOffAddrOp_Addr = True primOpHasSideEffects ReadOffAddrOp_Float = True primOpHasSideEffects ReadOffAddrOp_Double = True primOpHasSideEffects ReadOffAddrOp_StablePtr = True primOpHasSideEffects ReadOffAddrOp_Int8 = True primOpHasSideEffects ReadOffAddrOp_Int16 = True primOpHasSideEffects ReadOffAddrOp_Int32 = True primOpHasSideEffects ReadOffAddrOp_Int64 = True primOpHasSideEffects ReadOffAddrOp_Word8 = True primOpHasSideEffects ReadOffAddrOp_Word16 = True primOpHasSideEffects ReadOffAddrOp_Word32 = True primOpHasSideEffects ReadOffAddrOp_Word64 = True primOpHasSideEffects WriteOffAddrOp_Char = True primOpHasSideEffects WriteOffAddrOp_WideChar = True primOpHasSideEffects WriteOffAddrOp_Int = True primOpHasSideEffects WriteOffAddrOp_Word = True primOpHasSideEffects WriteOffAddrOp_Addr = True primOpHasSideEffects WriteOffAddrOp_Float = True primOpHasSideEffects WriteOffAddrOp_Double = True primOpHasSideEffects WriteOffAddrOp_StablePtr = True primOpHasSideEffects WriteOffAddrOp_Int8 = True primOpHasSideEffects WriteOffAddrOp_Int16 = True primOpHasSideEffects WriteOffAddrOp_Int32 = True primOpHasSideEffects WriteOffAddrOp_Int64 = True primOpHasSideEffects WriteOffAddrOp_Word8 = True primOpHasSideEffects WriteOffAddrOp_Word16 = True primOpHasSideEffects WriteOffAddrOp_Word32 = True primOpHasSideEffects WriteOffAddrOp_Word64 = True primOpHasSideEffects NewMutVarOp = True primOpHasSideEffects ReadMutVarOp = True primOpHasSideEffects WriteMutVarOp = True primOpHasSideEffects AtomicModifyMutVar2Op = True primOpHasSideEffects AtomicModifyMutVar_Op = True primOpHasSideEffects CasMutVarOp = True primOpHasSideEffects CatchOp = True primOpHasSideEffects RaiseOp = True primOpHasSideEffects RaiseIOOp = True primOpHasSideEffects MaskAsyncExceptionsOp = True primOpHasSideEffects MaskUninterruptibleOp = True primOpHasSideEffects UnmaskAsyncExceptionsOp = True primOpHasSideEffects MaskStatus = True primOpHasSideEffects AtomicallyOp = True primOpHasSideEffects RetryOp = True primOpHasSideEffects CatchRetryOp = True primOpHasSideEffects CatchSTMOp = True primOpHasSideEffects NewTVarOp = True primOpHasSideEffects ReadTVarOp = True primOpHasSideEffects ReadTVarIOOp = True primOpHasSideEffects WriteTVarOp = True primOpHasSideEffects NewMVarOp = True primOpHasSideEffects TakeMVarOp = True primOpHasSideEffects TryTakeMVarOp = True primOpHasSideEffects PutMVarOp = True primOpHasSideEffects TryPutMVarOp = True primOpHasSideEffects ReadMVarOp = True primOpHasSideEffects TryReadMVarOp = True primOpHasSideEffects IsEmptyMVarOp = True primOpHasSideEffects DelayOp = True primOpHasSideEffects WaitReadOp = True primOpHasSideEffects WaitWriteOp = True primOpHasSideEffects ForkOp = True primOpHasSideEffects ForkOnOp = True primOpHasSideEffects KillThreadOp = True primOpHasSideEffects YieldOp = True primOpHasSideEffects MyThreadIdOp = True primOpHasSideEffects LabelThreadOp = True primOpHasSideEffects IsCurrentThreadBoundOp = True primOpHasSideEffects NoDuplicateOp = True primOpHasSideEffects ThreadStatusOp = True primOpHasSideEffects MkWeakOp = True primOpHasSideEffects MkWeakNoFinalizerOp = True primOpHasSideEffects AddCFinalizerToWeakOp = True primOpHasSideEffects DeRefWeakOp = True primOpHasSideEffects FinalizeWeakOp = True primOpHasSideEffects TouchOp = True primOpHasSideEffects MakeStablePtrOp = True primOpHasSideEffects DeRefStablePtrOp = True primOpHasSideEffects EqStablePtrOp = True primOpHasSideEffects MakeStableNameOp = True primOpHasSideEffects CompactNewOp = True primOpHasSideEffects CompactResizeOp = True primOpHasSideEffects CompactAllocateBlockOp = True primOpHasSideEffects CompactFixupPointersOp = True primOpHasSideEffects CompactAdd = True primOpHasSideEffects CompactAddWithSharing = True primOpHasSideEffects CompactSize = True primOpHasSideEffects ParOp = True primOpHasSideEffects SparkOp = True primOpHasSideEffects GetSparkOp = True primOpHasSideEffects NumSparks = True primOpHasSideEffects NewBCOOp = True primOpHasSideEffects TraceEventOp = True primOpHasSideEffects TraceEventBinaryOp = True primOpHasSideEffects TraceMarkerOp = True primOpHasSideEffects SetThreadAllocationCounter = True primOpHasSideEffects (VecReadByteArrayOp _ _ _) = True primOpHasSideEffects (VecWriteByteArrayOp _ _ _) = True primOpHasSideEffects (VecReadOffAddrOp _ _ _) = True primOpHasSideEffects (VecWriteOffAddrOp _ _ _) = True primOpHasSideEffects (VecReadScalarByteArrayOp _ _ _) = True primOpHasSideEffects (VecWriteScalarByteArrayOp _ _ _) = True primOpHasSideEffects (VecReadScalarOffAddrOp _ _ _) = True primOpHasSideEffects (VecWriteScalarOffAddrOp _ _ _) = True primOpHasSideEffects PrefetchByteArrayOp3 = True primOpHasSideEffects PrefetchMutableByteArrayOp3 = True primOpHasSideEffects PrefetchAddrOp3 = True primOpHasSideEffects PrefetchValueOp3 = True primOpHasSideEffects PrefetchByteArrayOp2 = True primOpHasSideEffects PrefetchMutableByteArrayOp2 = True primOpHasSideEffects PrefetchAddrOp2 = True primOpHasSideEffects PrefetchValueOp2 = True primOpHasSideEffects PrefetchByteArrayOp1 = True primOpHasSideEffects PrefetchMutableByteArrayOp1 = True primOpHasSideEffects PrefetchAddrOp1 = True primOpHasSideEffects PrefetchValueOp1 = True primOpHasSideEffects PrefetchByteArrayOp0 = True primOpHasSideEffects PrefetchMutableByteArrayOp0 = True primOpHasSideEffects PrefetchAddrOp0 = True primOpHasSideEffects PrefetchValueOp0 = True primOpHasSideEffects _ = False ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/primop-list.hs-incl0000644000000000000000000010672713713636035024654 0ustar0000000000000000 [CharGtOp , CharGeOp , CharEqOp , CharNeOp , CharLtOp , CharLeOp , OrdOp , IntAddOp , IntSubOp , IntMulOp , IntMulMayOfloOp , IntQuotOp , IntRemOp , IntQuotRemOp , AndIOp , OrIOp , XorIOp , NotIOp , IntNegOp , IntAddCOp , IntSubCOp , IntGtOp , IntGeOp , IntEqOp , IntNeOp , IntLtOp , IntLeOp , ChrOp , Int2WordOp , Int2FloatOp , Int2DoubleOp , Word2FloatOp , Word2DoubleOp , ISllOp , ISraOp , ISrlOp , Int8Extend , Int8Narrow , Int8NegOp , Int8AddOp , Int8SubOp , Int8MulOp , Int8QuotOp , Int8RemOp , Int8QuotRemOp , Int8EqOp , Int8GeOp , Int8GtOp , Int8LeOp , Int8LtOp , Int8NeOp , Word8Extend , Word8Narrow , Word8NotOp , Word8AddOp , Word8SubOp , Word8MulOp , Word8QuotOp , Word8RemOp , Word8QuotRemOp , Word8EqOp , Word8GeOp , Word8GtOp , Word8LeOp , Word8LtOp , Word8NeOp , Int16Extend , Int16Narrow , Int16NegOp , Int16AddOp , Int16SubOp , Int16MulOp , Int16QuotOp , Int16RemOp , Int16QuotRemOp , Int16EqOp , Int16GeOp , Int16GtOp , Int16LeOp , Int16LtOp , Int16NeOp , Word16Extend , Word16Narrow , Word16NotOp , Word16AddOp , Word16SubOp , Word16MulOp , Word16QuotOp , Word16RemOp , Word16QuotRemOp , Word16EqOp , Word16GeOp , Word16GtOp , Word16LeOp , Word16LtOp , Word16NeOp , WordAddOp , WordAddCOp , WordSubCOp , WordAdd2Op , WordSubOp , WordMulOp , WordMul2Op , WordQuotOp , WordRemOp , WordQuotRemOp , WordQuotRem2Op , AndOp , OrOp , XorOp , NotOp , SllOp , SrlOp , Word2IntOp , WordGtOp , WordGeOp , WordEqOp , WordNeOp , WordLtOp , WordLeOp , PopCnt8Op , PopCnt16Op , PopCnt32Op , PopCnt64Op , PopCntOp , Pdep8Op , Pdep16Op , Pdep32Op , Pdep64Op , PdepOp , Pext8Op , Pext16Op , Pext32Op , Pext64Op , PextOp , Clz8Op , Clz16Op , Clz32Op , Clz64Op , ClzOp , Ctz8Op , Ctz16Op , Ctz32Op , Ctz64Op , CtzOp , BSwap16Op , BSwap32Op , BSwap64Op , BSwapOp , BRev8Op , BRev16Op , BRev32Op , BRev64Op , BRevOp , Narrow8IntOp , Narrow16IntOp , Narrow32IntOp , Narrow8WordOp , Narrow16WordOp , Narrow32WordOp , DoubleGtOp , DoubleGeOp , DoubleEqOp , DoubleNeOp , DoubleLtOp , DoubleLeOp , DoubleAddOp , DoubleSubOp , DoubleMulOp , DoubleDivOp , DoubleNegOp , DoubleFabsOp , Double2IntOp , Double2FloatOp , DoubleExpOp , DoubleExpM1Op , DoubleLogOp , DoubleLog1POp , DoubleSqrtOp , DoubleSinOp , DoubleCosOp , DoubleTanOp , DoubleAsinOp , DoubleAcosOp , DoubleAtanOp , DoubleSinhOp , DoubleCoshOp , DoubleTanhOp , DoubleAsinhOp , DoubleAcoshOp , DoubleAtanhOp , DoublePowerOp , DoubleDecode_2IntOp , DoubleDecode_Int64Op , FloatGtOp , FloatGeOp , FloatEqOp , FloatNeOp , FloatLtOp , FloatLeOp , FloatAddOp , FloatSubOp , FloatMulOp , FloatDivOp , FloatNegOp , FloatFabsOp , Float2IntOp , FloatExpOp , FloatExpM1Op , FloatLogOp , FloatLog1POp , FloatSqrtOp , FloatSinOp , FloatCosOp , FloatTanOp , FloatAsinOp , FloatAcosOp , FloatAtanOp , FloatSinhOp , FloatCoshOp , FloatTanhOp , FloatAsinhOp , FloatAcoshOp , FloatAtanhOp , FloatPowerOp , Float2DoubleOp , FloatDecode_IntOp , NewArrayOp , SameMutableArrayOp , ReadArrayOp , WriteArrayOp , SizeofArrayOp , SizeofMutableArrayOp , IndexArrayOp , UnsafeFreezeArrayOp , UnsafeThawArrayOp , CopyArrayOp , CopyMutableArrayOp , CloneArrayOp , CloneMutableArrayOp , FreezeArrayOp , ThawArrayOp , CasArrayOp , NewSmallArrayOp , SameSmallMutableArrayOp , ShrinkSmallMutableArrayOp_Char , ReadSmallArrayOp , WriteSmallArrayOp , SizeofSmallArrayOp , SizeofSmallMutableArrayOp , GetSizeofSmallMutableArrayOp , IndexSmallArrayOp , UnsafeFreezeSmallArrayOp , UnsafeThawSmallArrayOp , CopySmallArrayOp , CopySmallMutableArrayOp , CloneSmallArrayOp , CloneSmallMutableArrayOp , FreezeSmallArrayOp , ThawSmallArrayOp , CasSmallArrayOp , NewByteArrayOp_Char , NewPinnedByteArrayOp_Char , NewAlignedPinnedByteArrayOp_Char , MutableByteArrayIsPinnedOp , ByteArrayIsPinnedOp , ByteArrayContents_Char , SameMutableByteArrayOp , ShrinkMutableByteArrayOp_Char , ResizeMutableByteArrayOp_Char , UnsafeFreezeByteArrayOp , SizeofByteArrayOp , SizeofMutableByteArrayOp , GetSizeofMutableByteArrayOp , IndexByteArrayOp_Char , IndexByteArrayOp_WideChar , IndexByteArrayOp_Int , IndexByteArrayOp_Word , IndexByteArrayOp_Addr , IndexByteArrayOp_Float , IndexByteArrayOp_Double , IndexByteArrayOp_StablePtr , IndexByteArrayOp_Int8 , IndexByteArrayOp_Int16 , IndexByteArrayOp_Int32 , IndexByteArrayOp_Int64 , IndexByteArrayOp_Word8 , IndexByteArrayOp_Word16 , IndexByteArrayOp_Word32 , IndexByteArrayOp_Word64 , IndexByteArrayOp_Word8AsChar , IndexByteArrayOp_Word8AsWideChar , IndexByteArrayOp_Word8AsAddr , IndexByteArrayOp_Word8AsFloat , IndexByteArrayOp_Word8AsDouble , IndexByteArrayOp_Word8AsStablePtr , IndexByteArrayOp_Word8AsInt16 , IndexByteArrayOp_Word8AsInt32 , IndexByteArrayOp_Word8AsInt64 , IndexByteArrayOp_Word8AsInt , IndexByteArrayOp_Word8AsWord16 , IndexByteArrayOp_Word8AsWord32 , IndexByteArrayOp_Word8AsWord64 , IndexByteArrayOp_Word8AsWord , ReadByteArrayOp_Char , ReadByteArrayOp_WideChar , ReadByteArrayOp_Int , ReadByteArrayOp_Word , ReadByteArrayOp_Addr , ReadByteArrayOp_Float , ReadByteArrayOp_Double , ReadByteArrayOp_StablePtr , ReadByteArrayOp_Int8 , ReadByteArrayOp_Int16 , ReadByteArrayOp_Int32 , ReadByteArrayOp_Int64 , ReadByteArrayOp_Word8 , ReadByteArrayOp_Word16 , ReadByteArrayOp_Word32 , ReadByteArrayOp_Word64 , ReadByteArrayOp_Word8AsChar , ReadByteArrayOp_Word8AsWideChar , ReadByteArrayOp_Word8AsAddr , ReadByteArrayOp_Word8AsFloat , ReadByteArrayOp_Word8AsDouble , ReadByteArrayOp_Word8AsStablePtr , ReadByteArrayOp_Word8AsInt16 , ReadByteArrayOp_Word8AsInt32 , ReadByteArrayOp_Word8AsInt64 , ReadByteArrayOp_Word8AsInt , ReadByteArrayOp_Word8AsWord16 , ReadByteArrayOp_Word8AsWord32 , ReadByteArrayOp_Word8AsWord64 , ReadByteArrayOp_Word8AsWord , WriteByteArrayOp_Char , WriteByteArrayOp_WideChar , WriteByteArrayOp_Int , WriteByteArrayOp_Word , WriteByteArrayOp_Addr , WriteByteArrayOp_Float , WriteByteArrayOp_Double , WriteByteArrayOp_StablePtr , WriteByteArrayOp_Int8 , WriteByteArrayOp_Int16 , WriteByteArrayOp_Int32 , WriteByteArrayOp_Int64 , WriteByteArrayOp_Word8 , WriteByteArrayOp_Word16 , WriteByteArrayOp_Word32 , WriteByteArrayOp_Word64 , WriteByteArrayOp_Word8AsChar , WriteByteArrayOp_Word8AsWideChar , WriteByteArrayOp_Word8AsAddr , WriteByteArrayOp_Word8AsFloat , WriteByteArrayOp_Word8AsDouble , WriteByteArrayOp_Word8AsStablePtr , WriteByteArrayOp_Word8AsInt16 , WriteByteArrayOp_Word8AsInt32 , WriteByteArrayOp_Word8AsInt64 , WriteByteArrayOp_Word8AsInt , WriteByteArrayOp_Word8AsWord16 , WriteByteArrayOp_Word8AsWord32 , WriteByteArrayOp_Word8AsWord64 , WriteByteArrayOp_Word8AsWord , CompareByteArraysOp , CopyByteArrayOp , CopyMutableByteArrayOp , CopyByteArrayToAddrOp , CopyMutableByteArrayToAddrOp , CopyAddrToByteArrayOp , SetByteArrayOp , AtomicReadByteArrayOp_Int , AtomicWriteByteArrayOp_Int , CasByteArrayOp_Int , FetchAddByteArrayOp_Int , FetchSubByteArrayOp_Int , FetchAndByteArrayOp_Int , FetchNandByteArrayOp_Int , FetchOrByteArrayOp_Int , FetchXorByteArrayOp_Int , NewArrayArrayOp , SameMutableArrayArrayOp , UnsafeFreezeArrayArrayOp , SizeofArrayArrayOp , SizeofMutableArrayArrayOp , IndexArrayArrayOp_ByteArray , IndexArrayArrayOp_ArrayArray , ReadArrayArrayOp_ByteArray , ReadArrayArrayOp_MutableByteArray , ReadArrayArrayOp_ArrayArray , ReadArrayArrayOp_MutableArrayArray , WriteArrayArrayOp_ByteArray , WriteArrayArrayOp_MutableByteArray , WriteArrayArrayOp_ArrayArray , WriteArrayArrayOp_MutableArrayArray , CopyArrayArrayOp , CopyMutableArrayArrayOp , AddrAddOp , AddrSubOp , AddrRemOp , Addr2IntOp , Int2AddrOp , AddrGtOp , AddrGeOp , AddrEqOp , AddrNeOp , AddrLtOp , AddrLeOp , IndexOffAddrOp_Char , IndexOffAddrOp_WideChar , IndexOffAddrOp_Int , IndexOffAddrOp_Word , IndexOffAddrOp_Addr , IndexOffAddrOp_Float , IndexOffAddrOp_Double , IndexOffAddrOp_StablePtr , IndexOffAddrOp_Int8 , IndexOffAddrOp_Int16 , IndexOffAddrOp_Int32 , IndexOffAddrOp_Int64 , IndexOffAddrOp_Word8 , IndexOffAddrOp_Word16 , IndexOffAddrOp_Word32 , IndexOffAddrOp_Word64 , ReadOffAddrOp_Char , ReadOffAddrOp_WideChar , ReadOffAddrOp_Int , ReadOffAddrOp_Word , ReadOffAddrOp_Addr , ReadOffAddrOp_Float , ReadOffAddrOp_Double , ReadOffAddrOp_StablePtr , ReadOffAddrOp_Int8 , ReadOffAddrOp_Int16 , ReadOffAddrOp_Int32 , ReadOffAddrOp_Int64 , ReadOffAddrOp_Word8 , ReadOffAddrOp_Word16 , ReadOffAddrOp_Word32 , ReadOffAddrOp_Word64 , WriteOffAddrOp_Char , WriteOffAddrOp_WideChar , WriteOffAddrOp_Int , WriteOffAddrOp_Word , WriteOffAddrOp_Addr , WriteOffAddrOp_Float , WriteOffAddrOp_Double , WriteOffAddrOp_StablePtr , WriteOffAddrOp_Int8 , WriteOffAddrOp_Int16 , WriteOffAddrOp_Int32 , WriteOffAddrOp_Int64 , WriteOffAddrOp_Word8 , WriteOffAddrOp_Word16 , WriteOffAddrOp_Word32 , WriteOffAddrOp_Word64 , NewMutVarOp , ReadMutVarOp , WriteMutVarOp , SameMutVarOp , AtomicModifyMutVar2Op , AtomicModifyMutVar_Op , CasMutVarOp , CatchOp , RaiseOp , RaiseIOOp , MaskAsyncExceptionsOp , MaskUninterruptibleOp , UnmaskAsyncExceptionsOp , MaskStatus , AtomicallyOp , RetryOp , CatchRetryOp , CatchSTMOp , NewTVarOp , ReadTVarOp , ReadTVarIOOp , WriteTVarOp , SameTVarOp , NewMVarOp , TakeMVarOp , TryTakeMVarOp , PutMVarOp , TryPutMVarOp , ReadMVarOp , TryReadMVarOp , SameMVarOp , IsEmptyMVarOp , DelayOp , WaitReadOp , WaitWriteOp , ForkOp , ForkOnOp , KillThreadOp , YieldOp , MyThreadIdOp , LabelThreadOp , IsCurrentThreadBoundOp , NoDuplicateOp , ThreadStatusOp , MkWeakOp , MkWeakNoFinalizerOp , AddCFinalizerToWeakOp , DeRefWeakOp , FinalizeWeakOp , TouchOp , MakeStablePtrOp , DeRefStablePtrOp , EqStablePtrOp , MakeStableNameOp , EqStableNameOp , StableNameToIntOp , CompactNewOp , CompactResizeOp , CompactContainsOp , CompactContainsAnyOp , CompactGetFirstBlockOp , CompactGetNextBlockOp , CompactAllocateBlockOp , CompactFixupPointersOp , CompactAdd , CompactAddWithSharing , CompactSize , ReallyUnsafePtrEqualityOp , ParOp , SparkOp , SeqOp , GetSparkOp , NumSparks , DataToTagOp , TagToEnumOp , AddrToAnyOp , AnyToAddrOp , MkApUpd0_Op , NewBCOOp , UnpackClosureOp , ClosureSizeOp , GetApStackValOp , GetCCSOfOp , GetCurrentCCSOp , ClearCCSOp , TraceEventOp , TraceEventBinaryOp , TraceMarkerOp , SetThreadAllocationCounter , (VecBroadcastOp IntVec 16 W8) , (VecBroadcastOp IntVec 8 W16) , (VecBroadcastOp IntVec 4 W32) , (VecBroadcastOp IntVec 2 W64) , (VecBroadcastOp IntVec 32 W8) , (VecBroadcastOp IntVec 16 W16) , (VecBroadcastOp IntVec 8 W32) , (VecBroadcastOp IntVec 4 W64) , (VecBroadcastOp IntVec 64 W8) , (VecBroadcastOp IntVec 32 W16) , (VecBroadcastOp IntVec 16 W32) , (VecBroadcastOp IntVec 8 W64) , (VecBroadcastOp WordVec 16 W8) , (VecBroadcastOp WordVec 8 W16) , (VecBroadcastOp WordVec 4 W32) , (VecBroadcastOp WordVec 2 W64) , (VecBroadcastOp WordVec 32 W8) , (VecBroadcastOp WordVec 16 W16) , (VecBroadcastOp WordVec 8 W32) , (VecBroadcastOp WordVec 4 W64) , (VecBroadcastOp WordVec 64 W8) , (VecBroadcastOp WordVec 32 W16) , (VecBroadcastOp WordVec 16 W32) , (VecBroadcastOp WordVec 8 W64) , (VecBroadcastOp FloatVec 4 W32) , (VecBroadcastOp FloatVec 2 W64) , (VecBroadcastOp FloatVec 8 W32) , (VecBroadcastOp FloatVec 4 W64) , (VecBroadcastOp FloatVec 16 W32) , (VecBroadcastOp FloatVec 8 W64) , (VecPackOp IntVec 16 W8) , (VecPackOp IntVec 8 W16) , (VecPackOp IntVec 4 W32) , (VecPackOp IntVec 2 W64) , (VecPackOp IntVec 32 W8) , (VecPackOp IntVec 16 W16) , (VecPackOp IntVec 8 W32) , (VecPackOp IntVec 4 W64) , (VecPackOp IntVec 64 W8) , (VecPackOp IntVec 32 W16) , (VecPackOp IntVec 16 W32) , (VecPackOp IntVec 8 W64) , (VecPackOp WordVec 16 W8) , (VecPackOp WordVec 8 W16) , (VecPackOp WordVec 4 W32) , (VecPackOp WordVec 2 W64) , (VecPackOp WordVec 32 W8) , (VecPackOp WordVec 16 W16) , (VecPackOp WordVec 8 W32) , (VecPackOp WordVec 4 W64) , (VecPackOp WordVec 64 W8) , (VecPackOp WordVec 32 W16) , (VecPackOp WordVec 16 W32) , (VecPackOp WordVec 8 W64) , (VecPackOp FloatVec 4 W32) , (VecPackOp FloatVec 2 W64) , (VecPackOp FloatVec 8 W32) , (VecPackOp FloatVec 4 W64) , (VecPackOp FloatVec 16 W32) , (VecPackOp FloatVec 8 W64) , (VecUnpackOp IntVec 16 W8) , (VecUnpackOp IntVec 8 W16) , (VecUnpackOp IntVec 4 W32) , (VecUnpackOp IntVec 2 W64) , (VecUnpackOp IntVec 32 W8) , (VecUnpackOp IntVec 16 W16) , (VecUnpackOp IntVec 8 W32) , (VecUnpackOp IntVec 4 W64) , (VecUnpackOp IntVec 64 W8) , (VecUnpackOp IntVec 32 W16) , (VecUnpackOp IntVec 16 W32) , (VecUnpackOp IntVec 8 W64) , (VecUnpackOp WordVec 16 W8) , (VecUnpackOp WordVec 8 W16) , (VecUnpackOp WordVec 4 W32) , (VecUnpackOp WordVec 2 W64) , (VecUnpackOp WordVec 32 W8) , (VecUnpackOp WordVec 16 W16) , (VecUnpackOp WordVec 8 W32) , (VecUnpackOp WordVec 4 W64) , (VecUnpackOp WordVec 64 W8) , (VecUnpackOp WordVec 32 W16) , (VecUnpackOp WordVec 16 W32) , (VecUnpackOp WordVec 8 W64) , (VecUnpackOp FloatVec 4 W32) , (VecUnpackOp FloatVec 2 W64) , (VecUnpackOp FloatVec 8 W32) , (VecUnpackOp FloatVec 4 W64) , (VecUnpackOp FloatVec 16 W32) , (VecUnpackOp FloatVec 8 W64) , (VecInsertOp IntVec 16 W8) , (VecInsertOp IntVec 8 W16) , (VecInsertOp IntVec 4 W32) , (VecInsertOp IntVec 2 W64) , (VecInsertOp IntVec 32 W8) , (VecInsertOp IntVec 16 W16) , (VecInsertOp IntVec 8 W32) , (VecInsertOp IntVec 4 W64) , (VecInsertOp IntVec 64 W8) , (VecInsertOp IntVec 32 W16) , (VecInsertOp IntVec 16 W32) , (VecInsertOp IntVec 8 W64) , (VecInsertOp WordVec 16 W8) , (VecInsertOp WordVec 8 W16) , (VecInsertOp WordVec 4 W32) , (VecInsertOp WordVec 2 W64) , (VecInsertOp WordVec 32 W8) , (VecInsertOp WordVec 16 W16) , (VecInsertOp WordVec 8 W32) , (VecInsertOp WordVec 4 W64) , (VecInsertOp WordVec 64 W8) , (VecInsertOp WordVec 32 W16) , (VecInsertOp WordVec 16 W32) , (VecInsertOp WordVec 8 W64) , (VecInsertOp FloatVec 4 W32) , (VecInsertOp FloatVec 2 W64) , (VecInsertOp FloatVec 8 W32) , (VecInsertOp FloatVec 4 W64) , (VecInsertOp FloatVec 16 W32) , (VecInsertOp FloatVec 8 W64) , (VecAddOp IntVec 16 W8) , (VecAddOp IntVec 8 W16) , (VecAddOp IntVec 4 W32) , (VecAddOp IntVec 2 W64) , (VecAddOp IntVec 32 W8) , (VecAddOp IntVec 16 W16) , (VecAddOp IntVec 8 W32) , (VecAddOp IntVec 4 W64) , (VecAddOp IntVec 64 W8) , (VecAddOp IntVec 32 W16) , (VecAddOp IntVec 16 W32) , (VecAddOp IntVec 8 W64) , (VecAddOp WordVec 16 W8) , (VecAddOp WordVec 8 W16) , (VecAddOp WordVec 4 W32) , (VecAddOp WordVec 2 W64) , (VecAddOp WordVec 32 W8) , (VecAddOp WordVec 16 W16) , (VecAddOp WordVec 8 W32) , (VecAddOp WordVec 4 W64) , (VecAddOp WordVec 64 W8) , (VecAddOp WordVec 32 W16) , (VecAddOp WordVec 16 W32) , (VecAddOp WordVec 8 W64) , (VecAddOp FloatVec 4 W32) , (VecAddOp FloatVec 2 W64) , (VecAddOp FloatVec 8 W32) , (VecAddOp FloatVec 4 W64) , (VecAddOp FloatVec 16 W32) , (VecAddOp FloatVec 8 W64) , (VecSubOp IntVec 16 W8) , (VecSubOp IntVec 8 W16) , (VecSubOp IntVec 4 W32) , (VecSubOp IntVec 2 W64) , (VecSubOp IntVec 32 W8) , (VecSubOp IntVec 16 W16) , (VecSubOp IntVec 8 W32) , (VecSubOp IntVec 4 W64) , (VecSubOp IntVec 64 W8) , (VecSubOp IntVec 32 W16) , (VecSubOp IntVec 16 W32) , (VecSubOp IntVec 8 W64) , (VecSubOp WordVec 16 W8) , (VecSubOp WordVec 8 W16) , (VecSubOp WordVec 4 W32) , (VecSubOp WordVec 2 W64) , (VecSubOp WordVec 32 W8) , (VecSubOp WordVec 16 W16) , (VecSubOp WordVec 8 W32) , (VecSubOp WordVec 4 W64) , (VecSubOp WordVec 64 W8) , (VecSubOp WordVec 32 W16) , (VecSubOp WordVec 16 W32) , (VecSubOp WordVec 8 W64) , (VecSubOp FloatVec 4 W32) , (VecSubOp FloatVec 2 W64) , (VecSubOp FloatVec 8 W32) , (VecSubOp FloatVec 4 W64) , (VecSubOp FloatVec 16 W32) , (VecSubOp FloatVec 8 W64) , (VecMulOp IntVec 16 W8) , (VecMulOp IntVec 8 W16) , (VecMulOp IntVec 4 W32) , (VecMulOp IntVec 2 W64) , (VecMulOp IntVec 32 W8) , (VecMulOp IntVec 16 W16) , (VecMulOp IntVec 8 W32) , (VecMulOp IntVec 4 W64) , (VecMulOp IntVec 64 W8) , (VecMulOp IntVec 32 W16) , (VecMulOp IntVec 16 W32) , (VecMulOp IntVec 8 W64) , (VecMulOp WordVec 16 W8) , (VecMulOp WordVec 8 W16) , (VecMulOp WordVec 4 W32) , (VecMulOp WordVec 2 W64) , (VecMulOp WordVec 32 W8) , (VecMulOp WordVec 16 W16) , (VecMulOp WordVec 8 W32) , (VecMulOp WordVec 4 W64) , (VecMulOp WordVec 64 W8) , (VecMulOp WordVec 32 W16) , (VecMulOp WordVec 16 W32) , (VecMulOp WordVec 8 W64) , (VecMulOp FloatVec 4 W32) , (VecMulOp FloatVec 2 W64) , (VecMulOp FloatVec 8 W32) , (VecMulOp FloatVec 4 W64) , (VecMulOp FloatVec 16 W32) , (VecMulOp FloatVec 8 W64) , (VecDivOp FloatVec 4 W32) , (VecDivOp FloatVec 2 W64) , (VecDivOp FloatVec 8 W32) , (VecDivOp FloatVec 4 W64) , (VecDivOp FloatVec 16 W32) , (VecDivOp FloatVec 8 W64) , (VecQuotOp IntVec 16 W8) , (VecQuotOp IntVec 8 W16) , (VecQuotOp IntVec 4 W32) , (VecQuotOp IntVec 2 W64) , (VecQuotOp IntVec 32 W8) , (VecQuotOp IntVec 16 W16) , (VecQuotOp IntVec 8 W32) , (VecQuotOp IntVec 4 W64) , (VecQuotOp IntVec 64 W8) , (VecQuotOp IntVec 32 W16) , (VecQuotOp IntVec 16 W32) , (VecQuotOp IntVec 8 W64) , (VecQuotOp WordVec 16 W8) , (VecQuotOp WordVec 8 W16) , (VecQuotOp WordVec 4 W32) , (VecQuotOp WordVec 2 W64) , (VecQuotOp WordVec 32 W8) , (VecQuotOp WordVec 16 W16) , (VecQuotOp WordVec 8 W32) , (VecQuotOp WordVec 4 W64) , (VecQuotOp WordVec 64 W8) , (VecQuotOp WordVec 32 W16) , (VecQuotOp WordVec 16 W32) , (VecQuotOp WordVec 8 W64) , (VecRemOp IntVec 16 W8) , (VecRemOp IntVec 8 W16) , (VecRemOp IntVec 4 W32) , (VecRemOp IntVec 2 W64) , (VecRemOp IntVec 32 W8) , (VecRemOp IntVec 16 W16) , (VecRemOp IntVec 8 W32) , (VecRemOp IntVec 4 W64) , (VecRemOp IntVec 64 W8) , (VecRemOp IntVec 32 W16) , (VecRemOp IntVec 16 W32) , (VecRemOp IntVec 8 W64) , (VecRemOp WordVec 16 W8) , (VecRemOp WordVec 8 W16) , (VecRemOp WordVec 4 W32) , (VecRemOp WordVec 2 W64) , (VecRemOp WordVec 32 W8) , (VecRemOp WordVec 16 W16) , (VecRemOp WordVec 8 W32) , (VecRemOp WordVec 4 W64) , (VecRemOp WordVec 64 W8) , (VecRemOp WordVec 32 W16) , (VecRemOp WordVec 16 W32) , (VecRemOp WordVec 8 W64) , (VecNegOp IntVec 16 W8) , (VecNegOp IntVec 8 W16) , (VecNegOp IntVec 4 W32) , (VecNegOp IntVec 2 W64) , (VecNegOp IntVec 32 W8) , (VecNegOp IntVec 16 W16) , (VecNegOp IntVec 8 W32) , (VecNegOp IntVec 4 W64) , (VecNegOp IntVec 64 W8) , (VecNegOp IntVec 32 W16) , (VecNegOp IntVec 16 W32) , (VecNegOp IntVec 8 W64) , (VecNegOp FloatVec 4 W32) , (VecNegOp FloatVec 2 W64) , (VecNegOp FloatVec 8 W32) , (VecNegOp FloatVec 4 W64) , (VecNegOp FloatVec 16 W32) , (VecNegOp FloatVec 8 W64) , (VecIndexByteArrayOp IntVec 16 W8) , (VecIndexByteArrayOp IntVec 8 W16) , (VecIndexByteArrayOp IntVec 4 W32) , (VecIndexByteArrayOp IntVec 2 W64) , (VecIndexByteArrayOp IntVec 32 W8) , (VecIndexByteArrayOp IntVec 16 W16) , (VecIndexByteArrayOp IntVec 8 W32) , (VecIndexByteArrayOp IntVec 4 W64) , (VecIndexByteArrayOp IntVec 64 W8) , (VecIndexByteArrayOp IntVec 32 W16) , (VecIndexByteArrayOp IntVec 16 W32) , (VecIndexByteArrayOp IntVec 8 W64) , (VecIndexByteArrayOp WordVec 16 W8) , (VecIndexByteArrayOp WordVec 8 W16) , (VecIndexByteArrayOp WordVec 4 W32) , (VecIndexByteArrayOp WordVec 2 W64) , (VecIndexByteArrayOp WordVec 32 W8) , (VecIndexByteArrayOp WordVec 16 W16) , (VecIndexByteArrayOp WordVec 8 W32) , (VecIndexByteArrayOp WordVec 4 W64) , (VecIndexByteArrayOp WordVec 64 W8) , (VecIndexByteArrayOp WordVec 32 W16) , (VecIndexByteArrayOp WordVec 16 W32) , (VecIndexByteArrayOp WordVec 8 W64) , (VecIndexByteArrayOp FloatVec 4 W32) , (VecIndexByteArrayOp FloatVec 2 W64) , (VecIndexByteArrayOp FloatVec 8 W32) , (VecIndexByteArrayOp FloatVec 4 W64) , (VecIndexByteArrayOp FloatVec 16 W32) , (VecIndexByteArrayOp FloatVec 8 W64) , (VecReadByteArrayOp IntVec 16 W8) , (VecReadByteArrayOp IntVec 8 W16) , (VecReadByteArrayOp IntVec 4 W32) , (VecReadByteArrayOp IntVec 2 W64) , (VecReadByteArrayOp IntVec 32 W8) , (VecReadByteArrayOp IntVec 16 W16) , (VecReadByteArrayOp IntVec 8 W32) , (VecReadByteArrayOp IntVec 4 W64) , (VecReadByteArrayOp IntVec 64 W8) , (VecReadByteArrayOp IntVec 32 W16) , (VecReadByteArrayOp IntVec 16 W32) , (VecReadByteArrayOp IntVec 8 W64) , (VecReadByteArrayOp WordVec 16 W8) , (VecReadByteArrayOp WordVec 8 W16) , (VecReadByteArrayOp WordVec 4 W32) , (VecReadByteArrayOp WordVec 2 W64) , (VecReadByteArrayOp WordVec 32 W8) , (VecReadByteArrayOp WordVec 16 W16) , (VecReadByteArrayOp WordVec 8 W32) , (VecReadByteArrayOp WordVec 4 W64) , (VecReadByteArrayOp WordVec 64 W8) , (VecReadByteArrayOp WordVec 32 W16) , (VecReadByteArrayOp WordVec 16 W32) , (VecReadByteArrayOp WordVec 8 W64) , (VecReadByteArrayOp FloatVec 4 W32) , (VecReadByteArrayOp FloatVec 2 W64) , (VecReadByteArrayOp FloatVec 8 W32) , (VecReadByteArrayOp FloatVec 4 W64) , (VecReadByteArrayOp FloatVec 16 W32) , (VecReadByteArrayOp FloatVec 8 W64) , (VecWriteByteArrayOp IntVec 16 W8) , (VecWriteByteArrayOp IntVec 8 W16) , (VecWriteByteArrayOp IntVec 4 W32) , (VecWriteByteArrayOp IntVec 2 W64) , (VecWriteByteArrayOp IntVec 32 W8) , (VecWriteByteArrayOp IntVec 16 W16) , (VecWriteByteArrayOp IntVec 8 W32) , (VecWriteByteArrayOp IntVec 4 W64) , (VecWriteByteArrayOp IntVec 64 W8) , (VecWriteByteArrayOp IntVec 32 W16) , (VecWriteByteArrayOp IntVec 16 W32) , (VecWriteByteArrayOp IntVec 8 W64) , (VecWriteByteArrayOp WordVec 16 W8) , (VecWriteByteArrayOp WordVec 8 W16) , (VecWriteByteArrayOp WordVec 4 W32) , (VecWriteByteArrayOp WordVec 2 W64) , (VecWriteByteArrayOp WordVec 32 W8) , (VecWriteByteArrayOp WordVec 16 W16) , (VecWriteByteArrayOp WordVec 8 W32) , (VecWriteByteArrayOp WordVec 4 W64) , (VecWriteByteArrayOp WordVec 64 W8) , (VecWriteByteArrayOp WordVec 32 W16) , (VecWriteByteArrayOp WordVec 16 W32) , (VecWriteByteArrayOp WordVec 8 W64) , (VecWriteByteArrayOp FloatVec 4 W32) , (VecWriteByteArrayOp FloatVec 2 W64) , (VecWriteByteArrayOp FloatVec 8 W32) , (VecWriteByteArrayOp FloatVec 4 W64) , (VecWriteByteArrayOp FloatVec 16 W32) , (VecWriteByteArrayOp FloatVec 8 W64) , (VecIndexOffAddrOp IntVec 16 W8) , (VecIndexOffAddrOp IntVec 8 W16) , (VecIndexOffAddrOp IntVec 4 W32) , (VecIndexOffAddrOp IntVec 2 W64) , (VecIndexOffAddrOp IntVec 32 W8) , (VecIndexOffAddrOp IntVec 16 W16) , (VecIndexOffAddrOp IntVec 8 W32) , (VecIndexOffAddrOp IntVec 4 W64) , (VecIndexOffAddrOp IntVec 64 W8) , (VecIndexOffAddrOp IntVec 32 W16) , (VecIndexOffAddrOp IntVec 16 W32) , (VecIndexOffAddrOp IntVec 8 W64) , (VecIndexOffAddrOp WordVec 16 W8) , (VecIndexOffAddrOp WordVec 8 W16) , (VecIndexOffAddrOp WordVec 4 W32) , (VecIndexOffAddrOp WordVec 2 W64) , (VecIndexOffAddrOp WordVec 32 W8) , (VecIndexOffAddrOp WordVec 16 W16) , (VecIndexOffAddrOp WordVec 8 W32) , (VecIndexOffAddrOp WordVec 4 W64) , (VecIndexOffAddrOp WordVec 64 W8) , (VecIndexOffAddrOp WordVec 32 W16) , (VecIndexOffAddrOp WordVec 16 W32) , (VecIndexOffAddrOp WordVec 8 W64) , (VecIndexOffAddrOp FloatVec 4 W32) , (VecIndexOffAddrOp FloatVec 2 W64) , (VecIndexOffAddrOp FloatVec 8 W32) , (VecIndexOffAddrOp FloatVec 4 W64) , (VecIndexOffAddrOp FloatVec 16 W32) , (VecIndexOffAddrOp FloatVec 8 W64) , (VecReadOffAddrOp IntVec 16 W8) , (VecReadOffAddrOp IntVec 8 W16) , (VecReadOffAddrOp IntVec 4 W32) , (VecReadOffAddrOp IntVec 2 W64) , (VecReadOffAddrOp IntVec 32 W8) , (VecReadOffAddrOp IntVec 16 W16) , (VecReadOffAddrOp IntVec 8 W32) , (VecReadOffAddrOp IntVec 4 W64) , (VecReadOffAddrOp IntVec 64 W8) , (VecReadOffAddrOp IntVec 32 W16) , (VecReadOffAddrOp IntVec 16 W32) , (VecReadOffAddrOp IntVec 8 W64) , (VecReadOffAddrOp WordVec 16 W8) , (VecReadOffAddrOp WordVec 8 W16) , (VecReadOffAddrOp WordVec 4 W32) , (VecReadOffAddrOp WordVec 2 W64) , (VecReadOffAddrOp WordVec 32 W8) , (VecReadOffAddrOp WordVec 16 W16) , (VecReadOffAddrOp WordVec 8 W32) , (VecReadOffAddrOp WordVec 4 W64) , (VecReadOffAddrOp WordVec 64 W8) , (VecReadOffAddrOp WordVec 32 W16) , (VecReadOffAddrOp WordVec 16 W32) , (VecReadOffAddrOp WordVec 8 W64) , (VecReadOffAddrOp FloatVec 4 W32) , (VecReadOffAddrOp FloatVec 2 W64) , (VecReadOffAddrOp FloatVec 8 W32) , (VecReadOffAddrOp FloatVec 4 W64) , (VecReadOffAddrOp FloatVec 16 W32) , (VecReadOffAddrOp FloatVec 8 W64) , (VecWriteOffAddrOp IntVec 16 W8) , (VecWriteOffAddrOp IntVec 8 W16) , (VecWriteOffAddrOp IntVec 4 W32) , (VecWriteOffAddrOp IntVec 2 W64) , (VecWriteOffAddrOp IntVec 32 W8) , (VecWriteOffAddrOp IntVec 16 W16) , (VecWriteOffAddrOp IntVec 8 W32) , (VecWriteOffAddrOp IntVec 4 W64) , (VecWriteOffAddrOp IntVec 64 W8) , (VecWriteOffAddrOp IntVec 32 W16) , (VecWriteOffAddrOp IntVec 16 W32) , (VecWriteOffAddrOp IntVec 8 W64) , (VecWriteOffAddrOp WordVec 16 W8) , (VecWriteOffAddrOp WordVec 8 W16) , (VecWriteOffAddrOp WordVec 4 W32) , (VecWriteOffAddrOp WordVec 2 W64) , (VecWriteOffAddrOp WordVec 32 W8) , (VecWriteOffAddrOp WordVec 16 W16) , (VecWriteOffAddrOp WordVec 8 W32) , (VecWriteOffAddrOp WordVec 4 W64) , (VecWriteOffAddrOp WordVec 64 W8) , (VecWriteOffAddrOp WordVec 32 W16) , (VecWriteOffAddrOp WordVec 16 W32) , (VecWriteOffAddrOp WordVec 8 W64) , (VecWriteOffAddrOp FloatVec 4 W32) , (VecWriteOffAddrOp FloatVec 2 W64) , (VecWriteOffAddrOp FloatVec 8 W32) , (VecWriteOffAddrOp FloatVec 4 W64) , (VecWriteOffAddrOp FloatVec 16 W32) , (VecWriteOffAddrOp FloatVec 8 W64) , (VecIndexScalarByteArrayOp IntVec 16 W8) , (VecIndexScalarByteArrayOp IntVec 8 W16) , (VecIndexScalarByteArrayOp IntVec 4 W32) , (VecIndexScalarByteArrayOp IntVec 2 W64) , (VecIndexScalarByteArrayOp IntVec 32 W8) , (VecIndexScalarByteArrayOp IntVec 16 W16) , (VecIndexScalarByteArrayOp IntVec 8 W32) , (VecIndexScalarByteArrayOp IntVec 4 W64) , (VecIndexScalarByteArrayOp IntVec 64 W8) , (VecIndexScalarByteArrayOp IntVec 32 W16) , (VecIndexScalarByteArrayOp IntVec 16 W32) , (VecIndexScalarByteArrayOp IntVec 8 W64) , (VecIndexScalarByteArrayOp WordVec 16 W8) , (VecIndexScalarByteArrayOp WordVec 8 W16) , (VecIndexScalarByteArrayOp WordVec 4 W32) , (VecIndexScalarByteArrayOp WordVec 2 W64) , (VecIndexScalarByteArrayOp WordVec 32 W8) , (VecIndexScalarByteArrayOp WordVec 16 W16) , (VecIndexScalarByteArrayOp WordVec 8 W32) , (VecIndexScalarByteArrayOp WordVec 4 W64) , (VecIndexScalarByteArrayOp WordVec 64 W8) , (VecIndexScalarByteArrayOp WordVec 32 W16) , (VecIndexScalarByteArrayOp WordVec 16 W32) , (VecIndexScalarByteArrayOp WordVec 8 W64) , (VecIndexScalarByteArrayOp FloatVec 4 W32) , (VecIndexScalarByteArrayOp FloatVec 2 W64) , (VecIndexScalarByteArrayOp FloatVec 8 W32) , (VecIndexScalarByteArrayOp FloatVec 4 W64) , (VecIndexScalarByteArrayOp FloatVec 16 W32) , (VecIndexScalarByteArrayOp FloatVec 8 W64) , (VecReadScalarByteArrayOp IntVec 16 W8) , (VecReadScalarByteArrayOp IntVec 8 W16) , (VecReadScalarByteArrayOp IntVec 4 W32) , (VecReadScalarByteArrayOp IntVec 2 W64) , (VecReadScalarByteArrayOp IntVec 32 W8) , (VecReadScalarByteArrayOp IntVec 16 W16) , (VecReadScalarByteArrayOp IntVec 8 W32) , (VecReadScalarByteArrayOp IntVec 4 W64) , (VecReadScalarByteArrayOp IntVec 64 W8) , (VecReadScalarByteArrayOp IntVec 32 W16) , (VecReadScalarByteArrayOp IntVec 16 W32) , (VecReadScalarByteArrayOp IntVec 8 W64) , (VecReadScalarByteArrayOp WordVec 16 W8) , (VecReadScalarByteArrayOp WordVec 8 W16) , (VecReadScalarByteArrayOp WordVec 4 W32) , (VecReadScalarByteArrayOp WordVec 2 W64) , (VecReadScalarByteArrayOp WordVec 32 W8) , (VecReadScalarByteArrayOp WordVec 16 W16) , (VecReadScalarByteArrayOp WordVec 8 W32) , (VecReadScalarByteArrayOp WordVec 4 W64) , (VecReadScalarByteArrayOp WordVec 64 W8) , (VecReadScalarByteArrayOp WordVec 32 W16) , (VecReadScalarByteArrayOp WordVec 16 W32) , (VecReadScalarByteArrayOp WordVec 8 W64) , (VecReadScalarByteArrayOp FloatVec 4 W32) , (VecReadScalarByteArrayOp FloatVec 2 W64) , (VecReadScalarByteArrayOp FloatVec 8 W32) , (VecReadScalarByteArrayOp FloatVec 4 W64) , (VecReadScalarByteArrayOp FloatVec 16 W32) , (VecReadScalarByteArrayOp FloatVec 8 W64) , (VecWriteScalarByteArrayOp IntVec 16 W8) , (VecWriteScalarByteArrayOp IntVec 8 W16) , (VecWriteScalarByteArrayOp IntVec 4 W32) , (VecWriteScalarByteArrayOp IntVec 2 W64) , (VecWriteScalarByteArrayOp IntVec 32 W8) , (VecWriteScalarByteArrayOp IntVec 16 W16) , (VecWriteScalarByteArrayOp IntVec 8 W32) , (VecWriteScalarByteArrayOp IntVec 4 W64) , (VecWriteScalarByteArrayOp IntVec 64 W8) , (VecWriteScalarByteArrayOp IntVec 32 W16) , (VecWriteScalarByteArrayOp IntVec 16 W32) , (VecWriteScalarByteArrayOp IntVec 8 W64) , (VecWriteScalarByteArrayOp WordVec 16 W8) , (VecWriteScalarByteArrayOp WordVec 8 W16) , (VecWriteScalarByteArrayOp WordVec 4 W32) , (VecWriteScalarByteArrayOp WordVec 2 W64) , (VecWriteScalarByteArrayOp WordVec 32 W8) , (VecWriteScalarByteArrayOp WordVec 16 W16) , (VecWriteScalarByteArrayOp WordVec 8 W32) , (VecWriteScalarByteArrayOp WordVec 4 W64) , (VecWriteScalarByteArrayOp WordVec 64 W8) , (VecWriteScalarByteArrayOp WordVec 32 W16) , (VecWriteScalarByteArrayOp WordVec 16 W32) , (VecWriteScalarByteArrayOp WordVec 8 W64) , (VecWriteScalarByteArrayOp FloatVec 4 W32) , (VecWriteScalarByteArrayOp FloatVec 2 W64) , (VecWriteScalarByteArrayOp FloatVec 8 W32) , (VecWriteScalarByteArrayOp FloatVec 4 W64) , (VecWriteScalarByteArrayOp FloatVec 16 W32) , (VecWriteScalarByteArrayOp FloatVec 8 W64) , (VecIndexScalarOffAddrOp IntVec 16 W8) , (VecIndexScalarOffAddrOp IntVec 8 W16) , (VecIndexScalarOffAddrOp IntVec 4 W32) , (VecIndexScalarOffAddrOp IntVec 2 W64) , (VecIndexScalarOffAddrOp IntVec 32 W8) , (VecIndexScalarOffAddrOp IntVec 16 W16) , (VecIndexScalarOffAddrOp IntVec 8 W32) , (VecIndexScalarOffAddrOp IntVec 4 W64) , (VecIndexScalarOffAddrOp IntVec 64 W8) , (VecIndexScalarOffAddrOp IntVec 32 W16) , (VecIndexScalarOffAddrOp IntVec 16 W32) , (VecIndexScalarOffAddrOp IntVec 8 W64) , (VecIndexScalarOffAddrOp WordVec 16 W8) , (VecIndexScalarOffAddrOp WordVec 8 W16) , (VecIndexScalarOffAddrOp WordVec 4 W32) , (VecIndexScalarOffAddrOp WordVec 2 W64) , (VecIndexScalarOffAddrOp WordVec 32 W8) , (VecIndexScalarOffAddrOp WordVec 16 W16) , (VecIndexScalarOffAddrOp WordVec 8 W32) , (VecIndexScalarOffAddrOp WordVec 4 W64) , (VecIndexScalarOffAddrOp WordVec 64 W8) , (VecIndexScalarOffAddrOp WordVec 32 W16) , (VecIndexScalarOffAddrOp WordVec 16 W32) , (VecIndexScalarOffAddrOp WordVec 8 W64) , (VecIndexScalarOffAddrOp FloatVec 4 W32) , (VecIndexScalarOffAddrOp FloatVec 2 W64) , (VecIndexScalarOffAddrOp FloatVec 8 W32) , (VecIndexScalarOffAddrOp FloatVec 4 W64) , (VecIndexScalarOffAddrOp FloatVec 16 W32) , (VecIndexScalarOffAddrOp FloatVec 8 W64) , (VecReadScalarOffAddrOp IntVec 16 W8) , (VecReadScalarOffAddrOp IntVec 8 W16) , (VecReadScalarOffAddrOp IntVec 4 W32) , (VecReadScalarOffAddrOp IntVec 2 W64) , (VecReadScalarOffAddrOp IntVec 32 W8) , (VecReadScalarOffAddrOp IntVec 16 W16) , (VecReadScalarOffAddrOp IntVec 8 W32) , (VecReadScalarOffAddrOp IntVec 4 W64) , (VecReadScalarOffAddrOp IntVec 64 W8) , (VecReadScalarOffAddrOp IntVec 32 W16) , (VecReadScalarOffAddrOp IntVec 16 W32) , (VecReadScalarOffAddrOp IntVec 8 W64) , (VecReadScalarOffAddrOp WordVec 16 W8) , (VecReadScalarOffAddrOp WordVec 8 W16) , (VecReadScalarOffAddrOp WordVec 4 W32) , (VecReadScalarOffAddrOp WordVec 2 W64) , (VecReadScalarOffAddrOp WordVec 32 W8) , (VecReadScalarOffAddrOp WordVec 16 W16) , (VecReadScalarOffAddrOp WordVec 8 W32) , (VecReadScalarOffAddrOp WordVec 4 W64) , (VecReadScalarOffAddrOp WordVec 64 W8) , (VecReadScalarOffAddrOp WordVec 32 W16) , (VecReadScalarOffAddrOp WordVec 16 W32) , (VecReadScalarOffAddrOp WordVec 8 W64) , (VecReadScalarOffAddrOp FloatVec 4 W32) , (VecReadScalarOffAddrOp FloatVec 2 W64) , (VecReadScalarOffAddrOp FloatVec 8 W32) , (VecReadScalarOffAddrOp FloatVec 4 W64) , (VecReadScalarOffAddrOp FloatVec 16 W32) , (VecReadScalarOffAddrOp FloatVec 8 W64) , (VecWriteScalarOffAddrOp IntVec 16 W8) , (VecWriteScalarOffAddrOp IntVec 8 W16) , (VecWriteScalarOffAddrOp IntVec 4 W32) , (VecWriteScalarOffAddrOp IntVec 2 W64) , (VecWriteScalarOffAddrOp IntVec 32 W8) , (VecWriteScalarOffAddrOp IntVec 16 W16) , (VecWriteScalarOffAddrOp IntVec 8 W32) , (VecWriteScalarOffAddrOp IntVec 4 W64) , (VecWriteScalarOffAddrOp IntVec 64 W8) , (VecWriteScalarOffAddrOp IntVec 32 W16) , (VecWriteScalarOffAddrOp IntVec 16 W32) , (VecWriteScalarOffAddrOp IntVec 8 W64) , (VecWriteScalarOffAddrOp WordVec 16 W8) , (VecWriteScalarOffAddrOp WordVec 8 W16) , (VecWriteScalarOffAddrOp WordVec 4 W32) , (VecWriteScalarOffAddrOp WordVec 2 W64) , (VecWriteScalarOffAddrOp WordVec 32 W8) , (VecWriteScalarOffAddrOp WordVec 16 W16) , (VecWriteScalarOffAddrOp WordVec 8 W32) , (VecWriteScalarOffAddrOp WordVec 4 W64) , (VecWriteScalarOffAddrOp WordVec 64 W8) , (VecWriteScalarOffAddrOp WordVec 32 W16) , (VecWriteScalarOffAddrOp WordVec 16 W32) , (VecWriteScalarOffAddrOp WordVec 8 W64) , (VecWriteScalarOffAddrOp FloatVec 4 W32) , (VecWriteScalarOffAddrOp FloatVec 2 W64) , (VecWriteScalarOffAddrOp FloatVec 8 W32) , (VecWriteScalarOffAddrOp FloatVec 4 W64) , (VecWriteScalarOffAddrOp FloatVec 16 W32) , (VecWriteScalarOffAddrOp FloatVec 8 W64) , PrefetchByteArrayOp3 , PrefetchMutableByteArrayOp3 , PrefetchAddrOp3 , PrefetchValueOp3 , PrefetchByteArrayOp2 , PrefetchMutableByteArrayOp2 , PrefetchAddrOp2 , PrefetchValueOp2 , PrefetchByteArrayOp1 , PrefetchMutableByteArrayOp1 , PrefetchAddrOp1 , PrefetchValueOp1 , PrefetchByteArrayOp0 , PrefetchMutableByteArrayOp0 , PrefetchAddrOp0 , PrefetchValueOp0 ] ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl0000644000000000000000000000762213713636035026031 0ustar0000000000000000primOpOutOfLine DoubleDecode_2IntOp = True primOpOutOfLine DoubleDecode_Int64Op = True primOpOutOfLine FloatDecode_IntOp = True primOpOutOfLine NewArrayOp = True primOpOutOfLine UnsafeThawArrayOp = True primOpOutOfLine CopyArrayOp = True primOpOutOfLine CopyMutableArrayOp = True primOpOutOfLine CloneArrayOp = True primOpOutOfLine CloneMutableArrayOp = True primOpOutOfLine FreezeArrayOp = True primOpOutOfLine ThawArrayOp = True primOpOutOfLine CasArrayOp = True primOpOutOfLine NewSmallArrayOp = True primOpOutOfLine ShrinkSmallMutableArrayOp_Char = True primOpOutOfLine UnsafeThawSmallArrayOp = True primOpOutOfLine CopySmallArrayOp = True primOpOutOfLine CopySmallMutableArrayOp = True primOpOutOfLine CloneSmallArrayOp = True primOpOutOfLine CloneSmallMutableArrayOp = True primOpOutOfLine FreezeSmallArrayOp = True primOpOutOfLine ThawSmallArrayOp = True primOpOutOfLine CasSmallArrayOp = True primOpOutOfLine NewByteArrayOp_Char = True primOpOutOfLine NewPinnedByteArrayOp_Char = True primOpOutOfLine NewAlignedPinnedByteArrayOp_Char = True primOpOutOfLine MutableByteArrayIsPinnedOp = True primOpOutOfLine ByteArrayIsPinnedOp = True primOpOutOfLine ShrinkMutableByteArrayOp_Char = True primOpOutOfLine ResizeMutableByteArrayOp_Char = True primOpOutOfLine NewArrayArrayOp = True primOpOutOfLine CopyArrayArrayOp = True primOpOutOfLine CopyMutableArrayArrayOp = True primOpOutOfLine NewMutVarOp = True primOpOutOfLine AtomicModifyMutVar2Op = True primOpOutOfLine AtomicModifyMutVar_Op = True primOpOutOfLine CasMutVarOp = True primOpOutOfLine CatchOp = True primOpOutOfLine RaiseOp = True primOpOutOfLine RaiseIOOp = True primOpOutOfLine MaskAsyncExceptionsOp = True primOpOutOfLine MaskUninterruptibleOp = True primOpOutOfLine UnmaskAsyncExceptionsOp = True primOpOutOfLine MaskStatus = True primOpOutOfLine AtomicallyOp = True primOpOutOfLine RetryOp = True primOpOutOfLine CatchRetryOp = True primOpOutOfLine CatchSTMOp = True primOpOutOfLine NewTVarOp = True primOpOutOfLine ReadTVarOp = True primOpOutOfLine ReadTVarIOOp = True primOpOutOfLine WriteTVarOp = True primOpOutOfLine NewMVarOp = True primOpOutOfLine TakeMVarOp = True primOpOutOfLine TryTakeMVarOp = True primOpOutOfLine PutMVarOp = True primOpOutOfLine TryPutMVarOp = True primOpOutOfLine ReadMVarOp = True primOpOutOfLine TryReadMVarOp = True primOpOutOfLine IsEmptyMVarOp = True primOpOutOfLine DelayOp = True primOpOutOfLine WaitReadOp = True primOpOutOfLine WaitWriteOp = True primOpOutOfLine ForkOp = True primOpOutOfLine ForkOnOp = True primOpOutOfLine KillThreadOp = True primOpOutOfLine YieldOp = True primOpOutOfLine LabelThreadOp = True primOpOutOfLine IsCurrentThreadBoundOp = True primOpOutOfLine NoDuplicateOp = True primOpOutOfLine ThreadStatusOp = True primOpOutOfLine MkWeakOp = True primOpOutOfLine MkWeakNoFinalizerOp = True primOpOutOfLine AddCFinalizerToWeakOp = True primOpOutOfLine DeRefWeakOp = True primOpOutOfLine FinalizeWeakOp = True primOpOutOfLine MakeStablePtrOp = True primOpOutOfLine DeRefStablePtrOp = True primOpOutOfLine MakeStableNameOp = True primOpOutOfLine CompactNewOp = True primOpOutOfLine CompactResizeOp = True primOpOutOfLine CompactContainsOp = True primOpOutOfLine CompactContainsAnyOp = True primOpOutOfLine CompactGetFirstBlockOp = True primOpOutOfLine CompactGetNextBlockOp = True primOpOutOfLine CompactAllocateBlockOp = True primOpOutOfLine CompactFixupPointersOp = True primOpOutOfLine CompactAdd = True primOpOutOfLine CompactAddWithSharing = True primOpOutOfLine CompactSize = True primOpOutOfLine GetSparkOp = True primOpOutOfLine NumSparks = True primOpOutOfLine MkApUpd0_Op = True primOpOutOfLine NewBCOOp = True primOpOutOfLine UnpackClosureOp = True primOpOutOfLine ClosureSizeOp = True primOpOutOfLine GetApStackValOp = True primOpOutOfLine ClearCCSOp = True primOpOutOfLine TraceEventOp = True primOpOutOfLine TraceEventBinaryOp = True primOpOutOfLine TraceMarkerOp = True primOpOutOfLine SetThreadAllocationCounter = True primOpOutOfLine _ = False ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl0000644000000000000000000055562213713636035026142 0ustar0000000000000000primOpInfo CharGtOp = mkCompare (fsLit "gtChar#") charPrimTy primOpInfo CharGeOp = mkCompare (fsLit "geChar#") charPrimTy primOpInfo CharEqOp = mkCompare (fsLit "eqChar#") charPrimTy primOpInfo CharNeOp = mkCompare (fsLit "neChar#") charPrimTy primOpInfo CharLtOp = mkCompare (fsLit "ltChar#") charPrimTy primOpInfo CharLeOp = mkCompare (fsLit "leChar#") charPrimTy primOpInfo OrdOp = mkGenPrimOp (fsLit "ord#") [] [charPrimTy] (intPrimTy) primOpInfo IntAddOp = mkDyadic (fsLit "+#") intPrimTy primOpInfo IntSubOp = mkDyadic (fsLit "-#") intPrimTy primOpInfo IntMulOp = mkDyadic (fsLit "*#") intPrimTy primOpInfo IntMulMayOfloOp = mkDyadic (fsLit "mulIntMayOflo#") intPrimTy primOpInfo IntQuotOp = mkDyadic (fsLit "quotInt#") intPrimTy primOpInfo IntRemOp = mkDyadic (fsLit "remInt#") intPrimTy primOpInfo IntQuotRemOp = mkGenPrimOp (fsLit "quotRemInt#") [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) primOpInfo AndIOp = mkDyadic (fsLit "andI#") intPrimTy primOpInfo OrIOp = mkDyadic (fsLit "orI#") intPrimTy primOpInfo XorIOp = mkDyadic (fsLit "xorI#") intPrimTy primOpInfo NotIOp = mkMonadic (fsLit "notI#") intPrimTy primOpInfo IntNegOp = mkMonadic (fsLit "negateInt#") intPrimTy primOpInfo IntAddCOp = mkGenPrimOp (fsLit "addIntC#") [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) primOpInfo IntSubCOp = mkGenPrimOp (fsLit "subIntC#") [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) primOpInfo IntGtOp = mkCompare (fsLit ">#") intPrimTy primOpInfo IntGeOp = mkCompare (fsLit ">=#") intPrimTy primOpInfo IntEqOp = mkCompare (fsLit "==#") intPrimTy primOpInfo IntNeOp = mkCompare (fsLit "/=#") intPrimTy primOpInfo IntLtOp = mkCompare (fsLit "<#") intPrimTy primOpInfo IntLeOp = mkCompare (fsLit "<=#") intPrimTy primOpInfo ChrOp = mkGenPrimOp (fsLit "chr#") [] [intPrimTy] (charPrimTy) primOpInfo Int2WordOp = mkGenPrimOp (fsLit "int2Word#") [] [intPrimTy] (wordPrimTy) primOpInfo Int2FloatOp = mkGenPrimOp (fsLit "int2Float#") [] [intPrimTy] (floatPrimTy) primOpInfo Int2DoubleOp = mkGenPrimOp (fsLit "int2Double#") [] [intPrimTy] (doublePrimTy) primOpInfo Word2FloatOp = mkGenPrimOp (fsLit "word2Float#") [] [wordPrimTy] (floatPrimTy) primOpInfo Word2DoubleOp = mkGenPrimOp (fsLit "word2Double#") [] [wordPrimTy] (doublePrimTy) primOpInfo ISllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#") [] [intPrimTy, intPrimTy] (intPrimTy) primOpInfo ISraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#") [] [intPrimTy, intPrimTy] (intPrimTy) primOpInfo ISrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#") [] [intPrimTy, intPrimTy] (intPrimTy) primOpInfo Int8Extend = mkGenPrimOp (fsLit "extendInt8#") [] [int8PrimTy] (intPrimTy) primOpInfo Int8Narrow = mkGenPrimOp (fsLit "narrowInt8#") [] [intPrimTy] (int8PrimTy) primOpInfo Int8NegOp = mkMonadic (fsLit "negateInt8#") int8PrimTy primOpInfo Int8AddOp = mkDyadic (fsLit "plusInt8#") int8PrimTy primOpInfo Int8SubOp = mkDyadic (fsLit "subInt8#") int8PrimTy primOpInfo Int8MulOp = mkDyadic (fsLit "timesInt8#") int8PrimTy primOpInfo Int8QuotOp = mkDyadic (fsLit "quotInt8#") int8PrimTy primOpInfo Int8RemOp = mkDyadic (fsLit "remInt8#") int8PrimTy primOpInfo Int8QuotRemOp = mkGenPrimOp (fsLit "quotRemInt8#") [] [int8PrimTy, int8PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy])) primOpInfo Int8EqOp = mkCompare (fsLit "eqInt8#") int8PrimTy primOpInfo Int8GeOp = mkCompare (fsLit "geInt8#") int8PrimTy primOpInfo Int8GtOp = mkCompare (fsLit "gtInt8#") int8PrimTy primOpInfo Int8LeOp = mkCompare (fsLit "leInt8#") int8PrimTy primOpInfo Int8LtOp = mkCompare (fsLit "ltInt8#") int8PrimTy primOpInfo Int8NeOp = mkCompare (fsLit "neInt8#") int8PrimTy primOpInfo Word8Extend = mkGenPrimOp (fsLit "extendWord8#") [] [word8PrimTy] (wordPrimTy) primOpInfo Word8Narrow = mkGenPrimOp (fsLit "narrowWord8#") [] [wordPrimTy] (word8PrimTy) primOpInfo Word8NotOp = mkMonadic (fsLit "notWord8#") word8PrimTy primOpInfo Word8AddOp = mkDyadic (fsLit "plusWord8#") word8PrimTy primOpInfo Word8SubOp = mkDyadic (fsLit "subWord8#") word8PrimTy primOpInfo Word8MulOp = mkDyadic (fsLit "timesWord8#") word8PrimTy primOpInfo Word8QuotOp = mkDyadic (fsLit "quotWord8#") word8PrimTy primOpInfo Word8RemOp = mkDyadic (fsLit "remWord8#") word8PrimTy primOpInfo Word8QuotRemOp = mkGenPrimOp (fsLit "quotRemWord8#") [] [word8PrimTy, word8PrimTy] ((mkTupleTy Unboxed [word8PrimTy, word8PrimTy])) primOpInfo Word8EqOp = mkCompare (fsLit "eqWord8#") word8PrimTy primOpInfo Word8GeOp = mkCompare (fsLit "geWord8#") word8PrimTy primOpInfo Word8GtOp = mkCompare (fsLit "gtWord8#") word8PrimTy primOpInfo Word8LeOp = mkCompare (fsLit "leWord8#") word8PrimTy primOpInfo Word8LtOp = mkCompare (fsLit "ltWord8#") word8PrimTy primOpInfo Word8NeOp = mkCompare (fsLit "neWord8#") word8PrimTy primOpInfo Int16Extend = mkGenPrimOp (fsLit "extendInt16#") [] [int16PrimTy] (intPrimTy) primOpInfo Int16Narrow = mkGenPrimOp (fsLit "narrowInt16#") [] [intPrimTy] (int16PrimTy) primOpInfo Int16NegOp = mkMonadic (fsLit "negateInt16#") int16PrimTy primOpInfo Int16AddOp = mkDyadic (fsLit "plusInt16#") int16PrimTy primOpInfo Int16SubOp = mkDyadic (fsLit "subInt16#") int16PrimTy primOpInfo Int16MulOp = mkDyadic (fsLit "timesInt16#") int16PrimTy primOpInfo Int16QuotOp = mkDyadic (fsLit "quotInt16#") int16PrimTy primOpInfo Int16RemOp = mkDyadic (fsLit "remInt16#") int16PrimTy primOpInfo Int16QuotRemOp = mkGenPrimOp (fsLit "quotRemInt16#") [] [int16PrimTy, int16PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy])) primOpInfo Int16EqOp = mkCompare (fsLit "eqInt16#") int16PrimTy primOpInfo Int16GeOp = mkCompare (fsLit "geInt16#") int16PrimTy primOpInfo Int16GtOp = mkCompare (fsLit "gtInt16#") int16PrimTy primOpInfo Int16LeOp = mkCompare (fsLit "leInt16#") int16PrimTy primOpInfo Int16LtOp = mkCompare (fsLit "ltInt16#") int16PrimTy primOpInfo Int16NeOp = mkCompare (fsLit "neInt16#") int16PrimTy primOpInfo Word16Extend = mkGenPrimOp (fsLit "extendWord16#") [] [word16PrimTy] (wordPrimTy) primOpInfo Word16Narrow = mkGenPrimOp (fsLit "narrowWord16#") [] [wordPrimTy] (word16PrimTy) primOpInfo Word16NotOp = mkMonadic (fsLit "notWord16#") word16PrimTy primOpInfo Word16AddOp = mkDyadic (fsLit "plusWord16#") word16PrimTy primOpInfo Word16SubOp = mkDyadic (fsLit "subWord16#") word16PrimTy primOpInfo Word16MulOp = mkDyadic (fsLit "timesWord16#") word16PrimTy primOpInfo Word16QuotOp = mkDyadic (fsLit "quotWord16#") word16PrimTy primOpInfo Word16RemOp = mkDyadic (fsLit "remWord16#") word16PrimTy primOpInfo Word16QuotRemOp = mkGenPrimOp (fsLit "quotRemWord16#") [] [word16PrimTy, word16PrimTy] ((mkTupleTy Unboxed [word16PrimTy, word16PrimTy])) primOpInfo Word16EqOp = mkCompare (fsLit "eqWord16#") word16PrimTy primOpInfo Word16GeOp = mkCompare (fsLit "geWord16#") word16PrimTy primOpInfo Word16GtOp = mkCompare (fsLit "gtWord16#") word16PrimTy primOpInfo Word16LeOp = mkCompare (fsLit "leWord16#") word16PrimTy primOpInfo Word16LtOp = mkCompare (fsLit "ltWord16#") word16PrimTy primOpInfo Word16NeOp = mkCompare (fsLit "neWord16#") word16PrimTy primOpInfo WordAddOp = mkDyadic (fsLit "plusWord#") wordPrimTy primOpInfo WordAddCOp = mkGenPrimOp (fsLit "addWordC#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy])) primOpInfo WordSubCOp = mkGenPrimOp (fsLit "subWordC#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy])) primOpInfo WordAdd2Op = mkGenPrimOp (fsLit "plusWord2#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy])) primOpInfo WordSubOp = mkDyadic (fsLit "minusWord#") wordPrimTy primOpInfo WordMulOp = mkDyadic (fsLit "timesWord#") wordPrimTy primOpInfo WordMul2Op = mkGenPrimOp (fsLit "timesWord2#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy])) primOpInfo WordQuotOp = mkDyadic (fsLit "quotWord#") wordPrimTy primOpInfo WordRemOp = mkDyadic (fsLit "remWord#") wordPrimTy primOpInfo WordQuotRemOp = mkGenPrimOp (fsLit "quotRemWord#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy])) primOpInfo WordQuotRem2Op = mkGenPrimOp (fsLit "quotRemWord2#") [] [wordPrimTy, wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy])) primOpInfo AndOp = mkDyadic (fsLit "and#") wordPrimTy primOpInfo OrOp = mkDyadic (fsLit "or#") wordPrimTy primOpInfo XorOp = mkDyadic (fsLit "xor#") wordPrimTy primOpInfo NotOp = mkMonadic (fsLit "not#") wordPrimTy primOpInfo SllOp = mkGenPrimOp (fsLit "uncheckedShiftL#") [] [wordPrimTy, intPrimTy] (wordPrimTy) primOpInfo SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL#") [] [wordPrimTy, intPrimTy] (wordPrimTy) primOpInfo Word2IntOp = mkGenPrimOp (fsLit "word2Int#") [] [wordPrimTy] (intPrimTy) primOpInfo WordGtOp = mkCompare (fsLit "gtWord#") wordPrimTy primOpInfo WordGeOp = mkCompare (fsLit "geWord#") wordPrimTy primOpInfo WordEqOp = mkCompare (fsLit "eqWord#") wordPrimTy primOpInfo WordNeOp = mkCompare (fsLit "neWord#") wordPrimTy primOpInfo WordLtOp = mkCompare (fsLit "ltWord#") wordPrimTy primOpInfo WordLeOp = mkCompare (fsLit "leWord#") wordPrimTy primOpInfo PopCnt8Op = mkMonadic (fsLit "popCnt8#") wordPrimTy primOpInfo PopCnt16Op = mkMonadic (fsLit "popCnt16#") wordPrimTy primOpInfo PopCnt32Op = mkMonadic (fsLit "popCnt32#") wordPrimTy primOpInfo PopCnt64Op = mkGenPrimOp (fsLit "popCnt64#") [] [wordPrimTy] (wordPrimTy) primOpInfo PopCntOp = mkMonadic (fsLit "popCnt#") wordPrimTy primOpInfo Pdep8Op = mkDyadic (fsLit "pdep8#") wordPrimTy primOpInfo Pdep16Op = mkDyadic (fsLit "pdep16#") wordPrimTy primOpInfo Pdep32Op = mkDyadic (fsLit "pdep32#") wordPrimTy primOpInfo Pdep64Op = mkGenPrimOp (fsLit "pdep64#") [] [wordPrimTy, wordPrimTy] (wordPrimTy) primOpInfo PdepOp = mkDyadic (fsLit "pdep#") wordPrimTy primOpInfo Pext8Op = mkDyadic (fsLit "pext8#") wordPrimTy primOpInfo Pext16Op = mkDyadic (fsLit "pext16#") wordPrimTy primOpInfo Pext32Op = mkDyadic (fsLit "pext32#") wordPrimTy primOpInfo Pext64Op = mkGenPrimOp (fsLit "pext64#") [] [wordPrimTy, wordPrimTy] (wordPrimTy) primOpInfo PextOp = mkDyadic (fsLit "pext#") wordPrimTy primOpInfo Clz8Op = mkMonadic (fsLit "clz8#") wordPrimTy primOpInfo Clz16Op = mkMonadic (fsLit "clz16#") wordPrimTy primOpInfo Clz32Op = mkMonadic (fsLit "clz32#") wordPrimTy primOpInfo Clz64Op = mkGenPrimOp (fsLit "clz64#") [] [wordPrimTy] (wordPrimTy) primOpInfo ClzOp = mkMonadic (fsLit "clz#") wordPrimTy primOpInfo Ctz8Op = mkMonadic (fsLit "ctz8#") wordPrimTy primOpInfo Ctz16Op = mkMonadic (fsLit "ctz16#") wordPrimTy primOpInfo Ctz32Op = mkMonadic (fsLit "ctz32#") wordPrimTy primOpInfo Ctz64Op = mkGenPrimOp (fsLit "ctz64#") [] [wordPrimTy] (wordPrimTy) primOpInfo CtzOp = mkMonadic (fsLit "ctz#") wordPrimTy primOpInfo BSwap16Op = mkMonadic (fsLit "byteSwap16#") wordPrimTy primOpInfo BSwap32Op = mkMonadic (fsLit "byteSwap32#") wordPrimTy primOpInfo BSwap64Op = mkMonadic (fsLit "byteSwap64#") wordPrimTy primOpInfo BSwapOp = mkMonadic (fsLit "byteSwap#") wordPrimTy primOpInfo BRev8Op = mkMonadic (fsLit "bitReverse8#") wordPrimTy primOpInfo BRev16Op = mkMonadic (fsLit "bitReverse16#") wordPrimTy primOpInfo BRev32Op = mkMonadic (fsLit "bitReverse32#") wordPrimTy primOpInfo BRev64Op = mkMonadic (fsLit "bitReverse64#") wordPrimTy primOpInfo BRevOp = mkMonadic (fsLit "bitReverse#") wordPrimTy primOpInfo Narrow8IntOp = mkMonadic (fsLit "narrow8Int#") intPrimTy primOpInfo Narrow16IntOp = mkMonadic (fsLit "narrow16Int#") intPrimTy primOpInfo Narrow32IntOp = mkMonadic (fsLit "narrow32Int#") intPrimTy primOpInfo Narrow8WordOp = mkMonadic (fsLit "narrow8Word#") wordPrimTy primOpInfo Narrow16WordOp = mkMonadic (fsLit "narrow16Word#") wordPrimTy primOpInfo Narrow32WordOp = mkMonadic (fsLit "narrow32Word#") wordPrimTy primOpInfo DoubleGtOp = mkCompare (fsLit ">##") doublePrimTy primOpInfo DoubleGeOp = mkCompare (fsLit ">=##") doublePrimTy primOpInfo DoubleEqOp = mkCompare (fsLit "==##") doublePrimTy primOpInfo DoubleNeOp = mkCompare (fsLit "/=##") doublePrimTy primOpInfo DoubleLtOp = mkCompare (fsLit "<##") doublePrimTy primOpInfo DoubleLeOp = mkCompare (fsLit "<=##") doublePrimTy primOpInfo DoubleAddOp = mkDyadic (fsLit "+##") doublePrimTy primOpInfo DoubleSubOp = mkDyadic (fsLit "-##") doublePrimTy primOpInfo DoubleMulOp = mkDyadic (fsLit "*##") doublePrimTy primOpInfo DoubleDivOp = mkDyadic (fsLit "/##") doublePrimTy primOpInfo DoubleNegOp = mkMonadic (fsLit "negateDouble#") doublePrimTy primOpInfo DoubleFabsOp = mkMonadic (fsLit "fabsDouble#") doublePrimTy primOpInfo Double2IntOp = mkGenPrimOp (fsLit "double2Int#") [] [doublePrimTy] (intPrimTy) primOpInfo Double2FloatOp = mkGenPrimOp (fsLit "double2Float#") [] [doublePrimTy] (floatPrimTy) primOpInfo DoubleExpOp = mkMonadic (fsLit "expDouble#") doublePrimTy primOpInfo DoubleExpM1Op = mkMonadic (fsLit "expm1Double#") doublePrimTy primOpInfo DoubleLogOp = mkMonadic (fsLit "logDouble#") doublePrimTy primOpInfo DoubleLog1POp = mkMonadic (fsLit "log1pDouble#") doublePrimTy primOpInfo DoubleSqrtOp = mkMonadic (fsLit "sqrtDouble#") doublePrimTy primOpInfo DoubleSinOp = mkMonadic (fsLit "sinDouble#") doublePrimTy primOpInfo DoubleCosOp = mkMonadic (fsLit "cosDouble#") doublePrimTy primOpInfo DoubleTanOp = mkMonadic (fsLit "tanDouble#") doublePrimTy primOpInfo DoubleAsinOp = mkMonadic (fsLit "asinDouble#") doublePrimTy primOpInfo DoubleAcosOp = mkMonadic (fsLit "acosDouble#") doublePrimTy primOpInfo DoubleAtanOp = mkMonadic (fsLit "atanDouble#") doublePrimTy primOpInfo DoubleSinhOp = mkMonadic (fsLit "sinhDouble#") doublePrimTy primOpInfo DoubleCoshOp = mkMonadic (fsLit "coshDouble#") doublePrimTy primOpInfo DoubleTanhOp = mkMonadic (fsLit "tanhDouble#") doublePrimTy primOpInfo DoubleAsinhOp = mkMonadic (fsLit "asinhDouble#") doublePrimTy primOpInfo DoubleAcoshOp = mkMonadic (fsLit "acoshDouble#") doublePrimTy primOpInfo DoubleAtanhOp = mkMonadic (fsLit "atanhDouble#") doublePrimTy primOpInfo DoublePowerOp = mkDyadic (fsLit "**##") doublePrimTy primOpInfo DoubleDecode_2IntOp = mkGenPrimOp (fsLit "decodeDouble_2Int#") [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, wordPrimTy, wordPrimTy, intPrimTy])) primOpInfo DoubleDecode_Int64Op = mkGenPrimOp (fsLit "decodeDouble_Int64#") [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) primOpInfo FloatGtOp = mkCompare (fsLit "gtFloat#") floatPrimTy primOpInfo FloatGeOp = mkCompare (fsLit "geFloat#") floatPrimTy primOpInfo FloatEqOp = mkCompare (fsLit "eqFloat#") floatPrimTy primOpInfo FloatNeOp = mkCompare (fsLit "neFloat#") floatPrimTy primOpInfo FloatLtOp = mkCompare (fsLit "ltFloat#") floatPrimTy primOpInfo FloatLeOp = mkCompare (fsLit "leFloat#") floatPrimTy primOpInfo FloatAddOp = mkDyadic (fsLit "plusFloat#") floatPrimTy primOpInfo FloatSubOp = mkDyadic (fsLit "minusFloat#") floatPrimTy primOpInfo FloatMulOp = mkDyadic (fsLit "timesFloat#") floatPrimTy primOpInfo FloatDivOp = mkDyadic (fsLit "divideFloat#") floatPrimTy primOpInfo FloatNegOp = mkMonadic (fsLit "negateFloat#") floatPrimTy primOpInfo FloatFabsOp = mkMonadic (fsLit "fabsFloat#") floatPrimTy primOpInfo Float2IntOp = mkGenPrimOp (fsLit "float2Int#") [] [floatPrimTy] (intPrimTy) primOpInfo FloatExpOp = mkMonadic (fsLit "expFloat#") floatPrimTy primOpInfo FloatExpM1Op = mkMonadic (fsLit "expm1Float#") floatPrimTy primOpInfo FloatLogOp = mkMonadic (fsLit "logFloat#") floatPrimTy primOpInfo FloatLog1POp = mkMonadic (fsLit "log1pFloat#") floatPrimTy primOpInfo FloatSqrtOp = mkMonadic (fsLit "sqrtFloat#") floatPrimTy primOpInfo FloatSinOp = mkMonadic (fsLit "sinFloat#") floatPrimTy primOpInfo FloatCosOp = mkMonadic (fsLit "cosFloat#") floatPrimTy primOpInfo FloatTanOp = mkMonadic (fsLit "tanFloat#") floatPrimTy primOpInfo FloatAsinOp = mkMonadic (fsLit "asinFloat#") floatPrimTy primOpInfo FloatAcosOp = mkMonadic (fsLit "acosFloat#") floatPrimTy primOpInfo FloatAtanOp = mkMonadic (fsLit "atanFloat#") floatPrimTy primOpInfo FloatSinhOp = mkMonadic (fsLit "sinhFloat#") floatPrimTy primOpInfo FloatCoshOp = mkMonadic (fsLit "coshFloat#") floatPrimTy primOpInfo FloatTanhOp = mkMonadic (fsLit "tanhFloat#") floatPrimTy primOpInfo FloatAsinhOp = mkMonadic (fsLit "asinhFloat#") floatPrimTy primOpInfo FloatAcoshOp = mkMonadic (fsLit "acoshFloat#") floatPrimTy primOpInfo FloatAtanhOp = mkMonadic (fsLit "atanhFloat#") floatPrimTy primOpInfo FloatPowerOp = mkDyadic (fsLit "powerFloat#") floatPrimTy primOpInfo Float2DoubleOp = mkGenPrimOp (fsLit "float2Double#") [] [floatPrimTy] (doublePrimTy) primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#") [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#") [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) primOpInfo SameMutableArrayOp = mkGenPrimOp (fsLit "sameMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#") [alphaTyVar] [mkArrayPrimTy alphaTy] (intPrimTy) primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#") [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy])) primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy])) primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#") [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#") [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#") [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy alphaTy) primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy])) primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#") [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#") [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) primOpInfo SameSmallMutableArrayOp = mkGenPrimOp (fsLit "sameSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) primOpInfo ShrinkSmallMutableArrayOp_Char = mkGenPrimOp (fsLit "shrinkSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#") [alphaTyVar] [mkSmallArrayPrimTy alphaTy] (intPrimTy) primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) primOpInfo GetSizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "getSizeofSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#") [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy])) primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy])) primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#") [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#") [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#") [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy alphaTy) primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy])) primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#") [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) primOpInfo NewByteArrayOp_Char = mkGenPrimOp (fsLit "newByteArray#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) primOpInfo NewPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newPinnedByteArray#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#") [deltaTyVar] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) primOpInfo MutableByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isMutableByteArrayPinned#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy) primOpInfo ByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isByteArrayPinned#") [] [byteArrayPrimTy] (intPrimTy) primOpInfo ByteArrayContents_Char = mkGenPrimOp (fsLit "byteArrayContents#") [] [byteArrayPrimTy] (addrPrimTy) primOpInfo SameMutableByteArrayOp = mkGenPrimOp (fsLit "sameMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy] (intPrimTy) primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo ResizeMutableByteArrayOp_Char = mkGenPrimOp (fsLit "resizeMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) primOpInfo UnsafeFreezeByteArrayOp = mkGenPrimOp (fsLit "unsafeFreezeByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy])) primOpInfo SizeofByteArrayOp = mkGenPrimOp (fsLit "sizeofByteArray#") [] [byteArrayPrimTy] (intPrimTy) primOpInfo SizeofMutableByteArrayOp = mkGenPrimOp (fsLit "sizeofMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy) primOpInfo GetSizeofMutableByteArrayOp = mkGenPrimOp (fsLit "getSizeofMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo IndexByteArrayOp_Char = mkGenPrimOp (fsLit "indexCharArray#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) primOpInfo IndexByteArrayOp_WideChar = mkGenPrimOp (fsLit "indexWideCharArray#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) primOpInfo IndexByteArrayOp_Int = mkGenPrimOp (fsLit "indexIntArray#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexByteArrayOp_Word = mkGenPrimOp (fsLit "indexWordArray#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Addr = mkGenPrimOp (fsLit "indexAddrArray#") [] [byteArrayPrimTy, intPrimTy] (addrPrimTy) primOpInfo IndexByteArrayOp_Float = mkGenPrimOp (fsLit "indexFloatArray#") [] [byteArrayPrimTy, intPrimTy] (floatPrimTy) primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#") [] [byteArrayPrimTy, intPrimTy] (doublePrimTy) primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#") [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) primOpInfo IndexByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "indexWord8ArrayAsAddr#") [] [byteArrayPrimTy, intPrimTy] (addrPrimTy) primOpInfo IndexByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "indexWord8ArrayAsFloat#") [] [byteArrayPrimTy, intPrimTy] (floatPrimTy) primOpInfo IndexByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8ArrayAsDouble#") [] [byteArrayPrimTy, intPrimTy] (doublePrimTy) primOpInfo IndexByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "indexWord8ArrayAsStablePtr#") [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8ArrayAsWord#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadByteArrayOp_Word = mkGenPrimOp (fsLit "readWordArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Addr = mkGenPrimOp (fsLit "readAddrArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo ReadByteArrayOp_Float = mkGenPrimOp (fsLit "readFloatArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy])) primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#") [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "readWord8ArrayAsAddr#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo ReadByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "readWord8ArrayAsFloat#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy])) primOpInfo ReadByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8ArrayAsDouble#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) primOpInfo ReadByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "readWord8ArrayAsStablePtr#") [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8ArrayAsWord#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word = mkGenPrimOp (fsLit "writeWordArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Addr = mkGenPrimOp (fsLit "writeAddrArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Float = mkGenPrimOp (fsLit "writeFloatArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#") [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "writeWord8ArrayAsAddr#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "writeWord8ArrayAsFloat#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8ArrayAsDouble#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "writeWord8ArrayAsStablePtr#") [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8ArrayAsWord#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#") [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy) primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#") [deltaTyVar] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo FetchAddByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAddIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo FetchSubByteArrayOp_Int = mkGenPrimOp (fsLit "fetchSubIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo FetchAndByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAndIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo FetchNandByteArrayOp_Int = mkGenPrimOp (fsLit "fetchNandIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo FetchOrByteArrayOp_Int = mkGenPrimOp (fsLit "fetchOrIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo FetchXorByteArrayOp_Int = mkGenPrimOp (fsLit "fetchXorIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo NewArrayArrayOp = mkGenPrimOp (fsLit "newArrayArray#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy])) primOpInfo SameMutableArrayArrayOp = mkGenPrimOp (fsLit "sameMutableArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy] (intPrimTy) primOpInfo UnsafeFreezeArrayArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy])) primOpInfo SizeofArrayArrayOp = mkGenPrimOp (fsLit "sizeofArrayArray#") [] [mkArrayArrayPrimTy] (intPrimTy) primOpInfo SizeofMutableArrayArrayOp = mkGenPrimOp (fsLit "sizeofMutableArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy] (intPrimTy) primOpInfo IndexArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "indexByteArrayArray#") [] [mkArrayArrayPrimTy, intPrimTy] (byteArrayPrimTy) primOpInfo IndexArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "indexArrayArrayArray#") [] [mkArrayArrayPrimTy, intPrimTy] (mkArrayArrayPrimTy) primOpInfo ReadArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "readByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy])) primOpInfo ReadArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "readMutableByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) primOpInfo ReadArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "readArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy])) primOpInfo ReadArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "readMutableArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy])) primOpInfo WriteArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "writeByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "writeMutableByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "writeArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkArrayArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "writeMutableArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyArrayArrayOp = mkGenPrimOp (fsLit "copyArrayArray#") [deltaTyVar] [mkArrayArrayPrimTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyMutableArrayArrayOp = mkGenPrimOp (fsLit "copyMutableArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#") [] [addrPrimTy, intPrimTy] (addrPrimTy) primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#") [] [addrPrimTy, addrPrimTy] (intPrimTy) primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) primOpInfo Addr2IntOp = mkGenPrimOp (fsLit "addr2Int#") [] [addrPrimTy] (intPrimTy) primOpInfo Int2AddrOp = mkGenPrimOp (fsLit "int2Addr#") [] [intPrimTy] (addrPrimTy) primOpInfo AddrGtOp = mkCompare (fsLit "gtAddr#") addrPrimTy primOpInfo AddrGeOp = mkCompare (fsLit "geAddr#") addrPrimTy primOpInfo AddrEqOp = mkCompare (fsLit "eqAddr#") addrPrimTy primOpInfo AddrNeOp = mkCompare (fsLit "neAddr#") addrPrimTy primOpInfo AddrLtOp = mkCompare (fsLit "ltAddr#") addrPrimTy primOpInfo AddrLeOp = mkCompare (fsLit "leAddr#") addrPrimTy primOpInfo IndexOffAddrOp_Char = mkGenPrimOp (fsLit "indexCharOffAddr#") [] [addrPrimTy, intPrimTy] (charPrimTy) primOpInfo IndexOffAddrOp_WideChar = mkGenPrimOp (fsLit "indexWideCharOffAddr#") [] [addrPrimTy, intPrimTy] (charPrimTy) primOpInfo IndexOffAddrOp_Int = mkGenPrimOp (fsLit "indexIntOffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexOffAddrOp_Word = mkGenPrimOp (fsLit "indexWordOffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexOffAddrOp_Addr = mkGenPrimOp (fsLit "indexAddrOffAddr#") [] [addrPrimTy, intPrimTy] (addrPrimTy) primOpInfo IndexOffAddrOp_Float = mkGenPrimOp (fsLit "indexFloatOffAddr#") [] [addrPrimTy, intPrimTy] (floatPrimTy) primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#") [] [addrPrimTy, intPrimTy] (doublePrimTy) primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#") [alphaTyVar] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadOffAddrOp_Word = mkGenPrimOp (fsLit "readWordOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadOffAddrOp_Addr = mkGenPrimOp (fsLit "readAddrOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo ReadOffAddrOp_Float = mkGenPrimOp (fsLit "readFloatOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy])) primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy])) primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#") [deltaTyVar, alphaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word = mkGenPrimOp (fsLit "writeWordOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Addr = mkGenPrimOp (fsLit "writeAddrOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Float = mkGenPrimOp (fsLit "writeFloatOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#") [alphaTyVar, deltaTyVar] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy alphaTy])) primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo SameMutVarOp = mkGenPrimOp (fsLit "sameMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkMutVarPrimTy deltaTy alphaTy] (intPrimTy) primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#") [deltaTyVar, alphaTyVar, gammaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTy (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy])) primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTy (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy])) primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#") [alphaTyVar, betaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (betaTy) ((mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#") [betaTyVar, runtimeRep1TyVar, openAlphaTyVar] [betaTy] (openAlphaTy) primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#") [alphaTyVar, betaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])) primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#") [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#") [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#") [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#") [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#") [alphaTyVar] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#") [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#") [alphaTyVar, betaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (betaTy) ((mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy alphaTy])) primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo SameTVarOp = mkGenPrimOp (fsLit "sameTVar#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkTVarPrimTy deltaTy alphaTy] (intPrimTy) primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#") [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy alphaTy])) primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) primOpInfo SameMVarOp = mkGenPrimOp (fsLit "sameMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkMVarPrimTy deltaTy alphaTy] (intPrimTy) primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#") [alphaTyVar] [intPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#") [alphaTyVar] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#") [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#") [] [threadIdPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#") [deltaTyVar] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#") [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy])) primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#") [runtimeRep1TyVar, openAlphaTyVar, betaTyVar, gammaTyVar] [openAlphaTy, betaTy, (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#") [runtimeRep1TyVar, openAlphaTyVar, betaTyVar] [openAlphaTy, betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#") [betaTyVar] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#") [alphaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, alphaTy])) primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#") [alphaTyVar, betaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))])) primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#") [runtimeRep1TyVar, openAlphaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy alphaTy])) primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#") [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#") [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy alphaTy] (intPrimTy) primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy])) primOpInfo EqStableNameOp = mkGenPrimOp (fsLit "eqStableName#") [alphaTyVar, betaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy] (intPrimTy) primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#") [alphaTyVar] [mkStableNamePrimTy alphaTy] (intPrimTy) primOpInfo CompactNewOp = mkGenPrimOp (fsLit "compactNew#") [] [wordPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy])) primOpInfo CompactResizeOp = mkGenPrimOp (fsLit "compactResize#") [] [compactPrimTy, wordPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo CompactContainsOp = mkGenPrimOp (fsLit "compactContains#") [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo CompactContainsAnyOp = mkGenPrimOp (fsLit "compactContainsAny#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo CompactGetFirstBlockOp = mkGenPrimOp (fsLit "compactGetFirstBlock#") [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy])) primOpInfo CompactGetNextBlockOp = mkGenPrimOp (fsLit "compactGetNextBlock#") [] [compactPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy])) primOpInfo CompactAllocateBlockOp = mkGenPrimOp (fsLit "compactAllocateBlock#") [] [wordPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy])) primOpInfo CompactFixupPointersOp = mkGenPrimOp (fsLit "compactFixupPointers#") [] [addrPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy, addrPrimTy])) primOpInfo CompactAdd = mkGenPrimOp (fsLit "compactAdd#") [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo CompactAddWithSharing = mkGenPrimOp (fsLit "compactAddWithSharing#") [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo CompactSize = mkGenPrimOp (fsLit "compactSize#") [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, wordPrimTy])) primOpInfo ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#") [alphaTyVar] [alphaTy, alphaTy] (intPrimTy) primOpInfo ParOp = mkGenPrimOp (fsLit "par#") [alphaTyVar] [alphaTy] (intPrimTy) primOpInfo SparkOp = mkGenPrimOp (fsLit "spark#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#") [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#") [deltaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#") [alphaTyVar] [alphaTy] (intPrimTy) primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#") [alphaTyVar] [intPrimTy] (alphaTy) primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#") [alphaTyVar] [addrPrimTy] ((mkTupleTy Unboxed [alphaTy])) primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy])) primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#") [alphaTyVar] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy])) primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#") [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy])) primOpInfo UnpackClosureOp = mkGenPrimOp (fsLit "unpackClosure#") [alphaTyVar, betaTyVar] [alphaTy] ((mkTupleTy Unboxed [addrPrimTy, byteArrayPrimTy, mkArrayPrimTy betaTy])) primOpInfo ClosureSizeOp = mkGenPrimOp (fsLit "closureSize#") [alphaTyVar] [alphaTy] (intPrimTy) primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#") [alphaTyVar, betaTyVar] [alphaTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, betaTy])) primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#") [deltaTyVar, alphaTyVar] [(mkVisFunTy (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#") [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#") [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#") [] [intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#") [] [intPrimTy] (int8X16PrimTy) primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#") [] [intPrimTy] (int16X8PrimTy) primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#") [] [intPrimTy] (int32X4PrimTy) primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#") [] [intPrimTy] (int64X2PrimTy) primOpInfo (VecBroadcastOp IntVec 32 W8) = mkGenPrimOp (fsLit "broadcastInt8X32#") [] [intPrimTy] (int8X32PrimTy) primOpInfo (VecBroadcastOp IntVec 16 W16) = mkGenPrimOp (fsLit "broadcastInt16X16#") [] [intPrimTy] (int16X16PrimTy) primOpInfo (VecBroadcastOp IntVec 8 W32) = mkGenPrimOp (fsLit "broadcastInt32X8#") [] [intPrimTy] (int32X8PrimTy) primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#") [] [intPrimTy] (int64X4PrimTy) primOpInfo (VecBroadcastOp IntVec 64 W8) = mkGenPrimOp (fsLit "broadcastInt8X64#") [] [intPrimTy] (int8X64PrimTy) primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#") [] [intPrimTy] (int16X32PrimTy) primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#") [] [intPrimTy] (int32X16PrimTy) primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#") [] [intPrimTy] (int64X8PrimTy) primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#") [] [wordPrimTy] (word8X16PrimTy) primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#") [] [wordPrimTy] (word16X8PrimTy) primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#") [] [wordPrimTy] (word32X4PrimTy) primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#") [] [wordPrimTy] (word64X2PrimTy) primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#") [] [wordPrimTy] (word8X32PrimTy) primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#") [] [wordPrimTy] (word16X16PrimTy) primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#") [] [wordPrimTy] (word32X8PrimTy) primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#") [] [wordPrimTy] (word64X4PrimTy) primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#") [] [wordPrimTy] (word8X64PrimTy) primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#") [] [wordPrimTy] (word16X32PrimTy) primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#") [] [wordPrimTy] (word32X16PrimTy) primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#") [] [wordPrimTy] (word64X8PrimTy) primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#") [] [floatPrimTy] (floatX4PrimTy) primOpInfo (VecBroadcastOp FloatVec 2 W64) = mkGenPrimOp (fsLit "broadcastDoubleX2#") [] [doublePrimTy] (doubleX2PrimTy) primOpInfo (VecBroadcastOp FloatVec 8 W32) = mkGenPrimOp (fsLit "broadcastFloatX8#") [] [floatPrimTy] (floatX8PrimTy) primOpInfo (VecBroadcastOp FloatVec 4 W64) = mkGenPrimOp (fsLit "broadcastDoubleX4#") [] [doublePrimTy] (doubleX4PrimTy) primOpInfo (VecBroadcastOp FloatVec 16 W32) = mkGenPrimOp (fsLit "broadcastFloatX16#") [] [floatPrimTy] (floatX16PrimTy) primOpInfo (VecBroadcastOp FloatVec 8 W64) = mkGenPrimOp (fsLit "broadcastDoubleX8#") [] [doublePrimTy] (doubleX8PrimTy) primOpInfo (VecPackOp IntVec 16 W8) = mkGenPrimOp (fsLit "packInt8X16#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X16PrimTy) primOpInfo (VecPackOp IntVec 8 W16) = mkGenPrimOp (fsLit "packInt16X8#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X8PrimTy) primOpInfo (VecPackOp IntVec 4 W32) = mkGenPrimOp (fsLit "packInt32X4#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X4PrimTy) primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy])] (int64X2PrimTy) primOpInfo (VecPackOp IntVec 32 W8) = mkGenPrimOp (fsLit "packInt8X32#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X32PrimTy) primOpInfo (VecPackOp IntVec 16 W16) = mkGenPrimOp (fsLit "packInt16X16#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X16PrimTy) primOpInfo (VecPackOp IntVec 8 W32) = mkGenPrimOp (fsLit "packInt32X8#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X8PrimTy) primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X4PrimTy) primOpInfo (VecPackOp IntVec 64 W8) = mkGenPrimOp (fsLit "packInt8X64#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X64PrimTy) primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X32PrimTy) primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X16PrimTy) primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#") [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X8PrimTy) primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X16PrimTy) primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X8PrimTy) primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X4PrimTy) primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy])] (word64X2PrimTy) primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X32PrimTy) primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X16PrimTy) primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X8PrimTy) primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X4PrimTy) primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X64PrimTy) primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X32PrimTy) primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X16PrimTy) primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X8PrimTy) primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#") [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy) primOpInfo (VecPackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "packDoubleX2#") [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy])] (doubleX2PrimTy) primOpInfo (VecPackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "packFloatX8#") [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX8PrimTy) primOpInfo (VecPackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "packDoubleX4#") [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX4PrimTy) primOpInfo (VecPackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "packFloatX16#") [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX16PrimTy) primOpInfo (VecPackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "packDoubleX8#") [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX8PrimTy) primOpInfo (VecUnpackOp IntVec 16 W8) = mkGenPrimOp (fsLit "unpackInt8X16#") [] [int8X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) primOpInfo (VecUnpackOp IntVec 8 W16) = mkGenPrimOp (fsLit "unpackInt16X8#") [] [int16X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) primOpInfo (VecUnpackOp IntVec 4 W32) = mkGenPrimOp (fsLit "unpackInt32X4#") [] [int32X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])) primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#") [] [int64X2PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) primOpInfo (VecUnpackOp IntVec 32 W8) = mkGenPrimOp (fsLit "unpackInt8X32#") [] [int8X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) primOpInfo (VecUnpackOp IntVec 16 W16) = mkGenPrimOp (fsLit "unpackInt16X16#") [] [int16X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) primOpInfo (VecUnpackOp IntVec 8 W32) = mkGenPrimOp (fsLit "unpackInt32X8#") [] [int32X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#") [] [int64X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])) primOpInfo (VecUnpackOp IntVec 64 W8) = mkGenPrimOp (fsLit "unpackInt8X64#") [] [int8X64PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#") [] [int16X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#") [] [int32X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#") [] [int64X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#") [] [word8X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#") [] [word16X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#") [] [word32X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#") [] [word64X2PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#") [] [word8X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#") [] [word16X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#") [] [word32X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#") [] [word64X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#") [] [word8X64PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#") [] [word16X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#") [] [word32X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#") [] [word64X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#") [] [floatX4PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) primOpInfo (VecUnpackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "unpackDoubleX2#") [] [doubleX2PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy])) primOpInfo (VecUnpackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "unpackFloatX8#") [] [floatX8PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) primOpInfo (VecUnpackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "unpackDoubleX4#") [] [doubleX4PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])) primOpInfo (VecUnpackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "unpackFloatX16#") [] [floatX16PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) primOpInfo (VecUnpackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "unpackDoubleX8#") [] [doubleX8PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])) primOpInfo (VecInsertOp IntVec 16 W8) = mkGenPrimOp (fsLit "insertInt8X16#") [] [int8X16PrimTy, intPrimTy, intPrimTy] (int8X16PrimTy) primOpInfo (VecInsertOp IntVec 8 W16) = mkGenPrimOp (fsLit "insertInt16X8#") [] [int16X8PrimTy, intPrimTy, intPrimTy] (int16X8PrimTy) primOpInfo (VecInsertOp IntVec 4 W32) = mkGenPrimOp (fsLit "insertInt32X4#") [] [int32X4PrimTy, intPrimTy, intPrimTy] (int32X4PrimTy) primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#") [] [int64X2PrimTy, intPrimTy, intPrimTy] (int64X2PrimTy) primOpInfo (VecInsertOp IntVec 32 W8) = mkGenPrimOp (fsLit "insertInt8X32#") [] [int8X32PrimTy, intPrimTy, intPrimTy] (int8X32PrimTy) primOpInfo (VecInsertOp IntVec 16 W16) = mkGenPrimOp (fsLit "insertInt16X16#") [] [int16X16PrimTy, intPrimTy, intPrimTy] (int16X16PrimTy) primOpInfo (VecInsertOp IntVec 8 W32) = mkGenPrimOp (fsLit "insertInt32X8#") [] [int32X8PrimTy, intPrimTy, intPrimTy] (int32X8PrimTy) primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#") [] [int64X4PrimTy, intPrimTy, intPrimTy] (int64X4PrimTy) primOpInfo (VecInsertOp IntVec 64 W8) = mkGenPrimOp (fsLit "insertInt8X64#") [] [int8X64PrimTy, intPrimTy, intPrimTy] (int8X64PrimTy) primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#") [] [int16X32PrimTy, intPrimTy, intPrimTy] (int16X32PrimTy) primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#") [] [int32X16PrimTy, intPrimTy, intPrimTy] (int32X16PrimTy) primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#") [] [int64X8PrimTy, intPrimTy, intPrimTy] (int64X8PrimTy) primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#") [] [word8X16PrimTy, wordPrimTy, intPrimTy] (word8X16PrimTy) primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#") [] [word16X8PrimTy, wordPrimTy, intPrimTy] (word16X8PrimTy) primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#") [] [word32X4PrimTy, wordPrimTy, intPrimTy] (word32X4PrimTy) primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#") [] [word64X2PrimTy, wordPrimTy, intPrimTy] (word64X2PrimTy) primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#") [] [word8X32PrimTy, wordPrimTy, intPrimTy] (word8X32PrimTy) primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#") [] [word16X16PrimTy, wordPrimTy, intPrimTy] (word16X16PrimTy) primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#") [] [word32X8PrimTy, wordPrimTy, intPrimTy] (word32X8PrimTy) primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#") [] [word64X4PrimTy, wordPrimTy, intPrimTy] (word64X4PrimTy) primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#") [] [word8X64PrimTy, wordPrimTy, intPrimTy] (word8X64PrimTy) primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#") [] [word16X32PrimTy, wordPrimTy, intPrimTy] (word16X32PrimTy) primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#") [] [word32X16PrimTy, wordPrimTy, intPrimTy] (word32X16PrimTy) primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#") [] [word64X8PrimTy, wordPrimTy, intPrimTy] (word64X8PrimTy) primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#") [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy) primOpInfo (VecInsertOp FloatVec 2 W64) = mkGenPrimOp (fsLit "insertDoubleX2#") [] [doubleX2PrimTy, doublePrimTy, intPrimTy] (doubleX2PrimTy) primOpInfo (VecInsertOp FloatVec 8 W32) = mkGenPrimOp (fsLit "insertFloatX8#") [] [floatX8PrimTy, floatPrimTy, intPrimTy] (floatX8PrimTy) primOpInfo (VecInsertOp FloatVec 4 W64) = mkGenPrimOp (fsLit "insertDoubleX4#") [] [doubleX4PrimTy, doublePrimTy, intPrimTy] (doubleX4PrimTy) primOpInfo (VecInsertOp FloatVec 16 W32) = mkGenPrimOp (fsLit "insertFloatX16#") [] [floatX16PrimTy, floatPrimTy, intPrimTy] (floatX16PrimTy) primOpInfo (VecInsertOp FloatVec 8 W64) = mkGenPrimOp (fsLit "insertDoubleX8#") [] [doubleX8PrimTy, doublePrimTy, intPrimTy] (doubleX8PrimTy) primOpInfo (VecAddOp IntVec 16 W8) = mkDyadic (fsLit "plusInt8X16#") int8X16PrimTy primOpInfo (VecAddOp IntVec 8 W16) = mkDyadic (fsLit "plusInt16X8#") int16X8PrimTy primOpInfo (VecAddOp IntVec 4 W32) = mkDyadic (fsLit "plusInt32X4#") int32X4PrimTy primOpInfo (VecAddOp IntVec 2 W64) = mkDyadic (fsLit "plusInt64X2#") int64X2PrimTy primOpInfo (VecAddOp IntVec 32 W8) = mkDyadic (fsLit "plusInt8X32#") int8X32PrimTy primOpInfo (VecAddOp IntVec 16 W16) = mkDyadic (fsLit "plusInt16X16#") int16X16PrimTy primOpInfo (VecAddOp IntVec 8 W32) = mkDyadic (fsLit "plusInt32X8#") int32X8PrimTy primOpInfo (VecAddOp IntVec 4 W64) = mkDyadic (fsLit "plusInt64X4#") int64X4PrimTy primOpInfo (VecAddOp IntVec 64 W8) = mkDyadic (fsLit "plusInt8X64#") int8X64PrimTy primOpInfo (VecAddOp IntVec 32 W16) = mkDyadic (fsLit "plusInt16X32#") int16X32PrimTy primOpInfo (VecAddOp IntVec 16 W32) = mkDyadic (fsLit "plusInt32X16#") int32X16PrimTy primOpInfo (VecAddOp IntVec 8 W64) = mkDyadic (fsLit "plusInt64X8#") int64X8PrimTy primOpInfo (VecAddOp WordVec 16 W8) = mkDyadic (fsLit "plusWord8X16#") word8X16PrimTy primOpInfo (VecAddOp WordVec 8 W16) = mkDyadic (fsLit "plusWord16X8#") word16X8PrimTy primOpInfo (VecAddOp WordVec 4 W32) = mkDyadic (fsLit "plusWord32X4#") word32X4PrimTy primOpInfo (VecAddOp WordVec 2 W64) = mkDyadic (fsLit "plusWord64X2#") word64X2PrimTy primOpInfo (VecAddOp WordVec 32 W8) = mkDyadic (fsLit "plusWord8X32#") word8X32PrimTy primOpInfo (VecAddOp WordVec 16 W16) = mkDyadic (fsLit "plusWord16X16#") word16X16PrimTy primOpInfo (VecAddOp WordVec 8 W32) = mkDyadic (fsLit "plusWord32X8#") word32X8PrimTy primOpInfo (VecAddOp WordVec 4 W64) = mkDyadic (fsLit "plusWord64X4#") word64X4PrimTy primOpInfo (VecAddOp WordVec 64 W8) = mkDyadic (fsLit "plusWord8X64#") word8X64PrimTy primOpInfo (VecAddOp WordVec 32 W16) = mkDyadic (fsLit "plusWord16X32#") word16X32PrimTy primOpInfo (VecAddOp WordVec 16 W32) = mkDyadic (fsLit "plusWord32X16#") word32X16PrimTy primOpInfo (VecAddOp WordVec 8 W64) = mkDyadic (fsLit "plusWord64X8#") word64X8PrimTy primOpInfo (VecAddOp FloatVec 4 W32) = mkDyadic (fsLit "plusFloatX4#") floatX4PrimTy primOpInfo (VecAddOp FloatVec 2 W64) = mkDyadic (fsLit "plusDoubleX2#") doubleX2PrimTy primOpInfo (VecAddOp FloatVec 8 W32) = mkDyadic (fsLit "plusFloatX8#") floatX8PrimTy primOpInfo (VecAddOp FloatVec 4 W64) = mkDyadic (fsLit "plusDoubleX4#") doubleX4PrimTy primOpInfo (VecAddOp FloatVec 16 W32) = mkDyadic (fsLit "plusFloatX16#") floatX16PrimTy primOpInfo (VecAddOp FloatVec 8 W64) = mkDyadic (fsLit "plusDoubleX8#") doubleX8PrimTy primOpInfo (VecSubOp IntVec 16 W8) = mkDyadic (fsLit "minusInt8X16#") int8X16PrimTy primOpInfo (VecSubOp IntVec 8 W16) = mkDyadic (fsLit "minusInt16X8#") int16X8PrimTy primOpInfo (VecSubOp IntVec 4 W32) = mkDyadic (fsLit "minusInt32X4#") int32X4PrimTy primOpInfo (VecSubOp IntVec 2 W64) = mkDyadic (fsLit "minusInt64X2#") int64X2PrimTy primOpInfo (VecSubOp IntVec 32 W8) = mkDyadic (fsLit "minusInt8X32#") int8X32PrimTy primOpInfo (VecSubOp IntVec 16 W16) = mkDyadic (fsLit "minusInt16X16#") int16X16PrimTy primOpInfo (VecSubOp IntVec 8 W32) = mkDyadic (fsLit "minusInt32X8#") int32X8PrimTy primOpInfo (VecSubOp IntVec 4 W64) = mkDyadic (fsLit "minusInt64X4#") int64X4PrimTy primOpInfo (VecSubOp IntVec 64 W8) = mkDyadic (fsLit "minusInt8X64#") int8X64PrimTy primOpInfo (VecSubOp IntVec 32 W16) = mkDyadic (fsLit "minusInt16X32#") int16X32PrimTy primOpInfo (VecSubOp IntVec 16 W32) = mkDyadic (fsLit "minusInt32X16#") int32X16PrimTy primOpInfo (VecSubOp IntVec 8 W64) = mkDyadic (fsLit "minusInt64X8#") int64X8PrimTy primOpInfo (VecSubOp WordVec 16 W8) = mkDyadic (fsLit "minusWord8X16#") word8X16PrimTy primOpInfo (VecSubOp WordVec 8 W16) = mkDyadic (fsLit "minusWord16X8#") word16X8PrimTy primOpInfo (VecSubOp WordVec 4 W32) = mkDyadic (fsLit "minusWord32X4#") word32X4PrimTy primOpInfo (VecSubOp WordVec 2 W64) = mkDyadic (fsLit "minusWord64X2#") word64X2PrimTy primOpInfo (VecSubOp WordVec 32 W8) = mkDyadic (fsLit "minusWord8X32#") word8X32PrimTy primOpInfo (VecSubOp WordVec 16 W16) = mkDyadic (fsLit "minusWord16X16#") word16X16PrimTy primOpInfo (VecSubOp WordVec 8 W32) = mkDyadic (fsLit "minusWord32X8#") word32X8PrimTy primOpInfo (VecSubOp WordVec 4 W64) = mkDyadic (fsLit "minusWord64X4#") word64X4PrimTy primOpInfo (VecSubOp WordVec 64 W8) = mkDyadic (fsLit "minusWord8X64#") word8X64PrimTy primOpInfo (VecSubOp WordVec 32 W16) = mkDyadic (fsLit "minusWord16X32#") word16X32PrimTy primOpInfo (VecSubOp WordVec 16 W32) = mkDyadic (fsLit "minusWord32X16#") word32X16PrimTy primOpInfo (VecSubOp WordVec 8 W64) = mkDyadic (fsLit "minusWord64X8#") word64X8PrimTy primOpInfo (VecSubOp FloatVec 4 W32) = mkDyadic (fsLit "minusFloatX4#") floatX4PrimTy primOpInfo (VecSubOp FloatVec 2 W64) = mkDyadic (fsLit "minusDoubleX2#") doubleX2PrimTy primOpInfo (VecSubOp FloatVec 8 W32) = mkDyadic (fsLit "minusFloatX8#") floatX8PrimTy primOpInfo (VecSubOp FloatVec 4 W64) = mkDyadic (fsLit "minusDoubleX4#") doubleX4PrimTy primOpInfo (VecSubOp FloatVec 16 W32) = mkDyadic (fsLit "minusFloatX16#") floatX16PrimTy primOpInfo (VecSubOp FloatVec 8 W64) = mkDyadic (fsLit "minusDoubleX8#") doubleX8PrimTy primOpInfo (VecMulOp IntVec 16 W8) = mkDyadic (fsLit "timesInt8X16#") int8X16PrimTy primOpInfo (VecMulOp IntVec 8 W16) = mkDyadic (fsLit "timesInt16X8#") int16X8PrimTy primOpInfo (VecMulOp IntVec 4 W32) = mkDyadic (fsLit "timesInt32X4#") int32X4PrimTy primOpInfo (VecMulOp IntVec 2 W64) = mkDyadic (fsLit "timesInt64X2#") int64X2PrimTy primOpInfo (VecMulOp IntVec 32 W8) = mkDyadic (fsLit "timesInt8X32#") int8X32PrimTy primOpInfo (VecMulOp IntVec 16 W16) = mkDyadic (fsLit "timesInt16X16#") int16X16PrimTy primOpInfo (VecMulOp IntVec 8 W32) = mkDyadic (fsLit "timesInt32X8#") int32X8PrimTy primOpInfo (VecMulOp IntVec 4 W64) = mkDyadic (fsLit "timesInt64X4#") int64X4PrimTy primOpInfo (VecMulOp IntVec 64 W8) = mkDyadic (fsLit "timesInt8X64#") int8X64PrimTy primOpInfo (VecMulOp IntVec 32 W16) = mkDyadic (fsLit "timesInt16X32#") int16X32PrimTy primOpInfo (VecMulOp IntVec 16 W32) = mkDyadic (fsLit "timesInt32X16#") int32X16PrimTy primOpInfo (VecMulOp IntVec 8 W64) = mkDyadic (fsLit "timesInt64X8#") int64X8PrimTy primOpInfo (VecMulOp WordVec 16 W8) = mkDyadic (fsLit "timesWord8X16#") word8X16PrimTy primOpInfo (VecMulOp WordVec 8 W16) = mkDyadic (fsLit "timesWord16X8#") word16X8PrimTy primOpInfo (VecMulOp WordVec 4 W32) = mkDyadic (fsLit "timesWord32X4#") word32X4PrimTy primOpInfo (VecMulOp WordVec 2 W64) = mkDyadic (fsLit "timesWord64X2#") word64X2PrimTy primOpInfo (VecMulOp WordVec 32 W8) = mkDyadic (fsLit "timesWord8X32#") word8X32PrimTy primOpInfo (VecMulOp WordVec 16 W16) = mkDyadic (fsLit "timesWord16X16#") word16X16PrimTy primOpInfo (VecMulOp WordVec 8 W32) = mkDyadic (fsLit "timesWord32X8#") word32X8PrimTy primOpInfo (VecMulOp WordVec 4 W64) = mkDyadic (fsLit "timesWord64X4#") word64X4PrimTy primOpInfo (VecMulOp WordVec 64 W8) = mkDyadic (fsLit "timesWord8X64#") word8X64PrimTy primOpInfo (VecMulOp WordVec 32 W16) = mkDyadic (fsLit "timesWord16X32#") word16X32PrimTy primOpInfo (VecMulOp WordVec 16 W32) = mkDyadic (fsLit "timesWord32X16#") word32X16PrimTy primOpInfo (VecMulOp WordVec 8 W64) = mkDyadic (fsLit "timesWord64X8#") word64X8PrimTy primOpInfo (VecMulOp FloatVec 4 W32) = mkDyadic (fsLit "timesFloatX4#") floatX4PrimTy primOpInfo (VecMulOp FloatVec 2 W64) = mkDyadic (fsLit "timesDoubleX2#") doubleX2PrimTy primOpInfo (VecMulOp FloatVec 8 W32) = mkDyadic (fsLit "timesFloatX8#") floatX8PrimTy primOpInfo (VecMulOp FloatVec 4 W64) = mkDyadic (fsLit "timesDoubleX4#") doubleX4PrimTy primOpInfo (VecMulOp FloatVec 16 W32) = mkDyadic (fsLit "timesFloatX16#") floatX16PrimTy primOpInfo (VecMulOp FloatVec 8 W64) = mkDyadic (fsLit "timesDoubleX8#") doubleX8PrimTy primOpInfo (VecDivOp FloatVec 4 W32) = mkDyadic (fsLit "divideFloatX4#") floatX4PrimTy primOpInfo (VecDivOp FloatVec 2 W64) = mkDyadic (fsLit "divideDoubleX2#") doubleX2PrimTy primOpInfo (VecDivOp FloatVec 8 W32) = mkDyadic (fsLit "divideFloatX8#") floatX8PrimTy primOpInfo (VecDivOp FloatVec 4 W64) = mkDyadic (fsLit "divideDoubleX4#") doubleX4PrimTy primOpInfo (VecDivOp FloatVec 16 W32) = mkDyadic (fsLit "divideFloatX16#") floatX16PrimTy primOpInfo (VecDivOp FloatVec 8 W64) = mkDyadic (fsLit "divideDoubleX8#") doubleX8PrimTy primOpInfo (VecQuotOp IntVec 16 W8) = mkDyadic (fsLit "quotInt8X16#") int8X16PrimTy primOpInfo (VecQuotOp IntVec 8 W16) = mkDyadic (fsLit "quotInt16X8#") int16X8PrimTy primOpInfo (VecQuotOp IntVec 4 W32) = mkDyadic (fsLit "quotInt32X4#") int32X4PrimTy primOpInfo (VecQuotOp IntVec 2 W64) = mkDyadic (fsLit "quotInt64X2#") int64X2PrimTy primOpInfo (VecQuotOp IntVec 32 W8) = mkDyadic (fsLit "quotInt8X32#") int8X32PrimTy primOpInfo (VecQuotOp IntVec 16 W16) = mkDyadic (fsLit "quotInt16X16#") int16X16PrimTy primOpInfo (VecQuotOp IntVec 8 W32) = mkDyadic (fsLit "quotInt32X8#") int32X8PrimTy primOpInfo (VecQuotOp IntVec 4 W64) = mkDyadic (fsLit "quotInt64X4#") int64X4PrimTy primOpInfo (VecQuotOp IntVec 64 W8) = mkDyadic (fsLit "quotInt8X64#") int8X64PrimTy primOpInfo (VecQuotOp IntVec 32 W16) = mkDyadic (fsLit "quotInt16X32#") int16X32PrimTy primOpInfo (VecQuotOp IntVec 16 W32) = mkDyadic (fsLit "quotInt32X16#") int32X16PrimTy primOpInfo (VecQuotOp IntVec 8 W64) = mkDyadic (fsLit "quotInt64X8#") int64X8PrimTy primOpInfo (VecQuotOp WordVec 16 W8) = mkDyadic (fsLit "quotWord8X16#") word8X16PrimTy primOpInfo (VecQuotOp WordVec 8 W16) = mkDyadic (fsLit "quotWord16X8#") word16X8PrimTy primOpInfo (VecQuotOp WordVec 4 W32) = mkDyadic (fsLit "quotWord32X4#") word32X4PrimTy primOpInfo (VecQuotOp WordVec 2 W64) = mkDyadic (fsLit "quotWord64X2#") word64X2PrimTy primOpInfo (VecQuotOp WordVec 32 W8) = mkDyadic (fsLit "quotWord8X32#") word8X32PrimTy primOpInfo (VecQuotOp WordVec 16 W16) = mkDyadic (fsLit "quotWord16X16#") word16X16PrimTy primOpInfo (VecQuotOp WordVec 8 W32) = mkDyadic (fsLit "quotWord32X8#") word32X8PrimTy primOpInfo (VecQuotOp WordVec 4 W64) = mkDyadic (fsLit "quotWord64X4#") word64X4PrimTy primOpInfo (VecQuotOp WordVec 64 W8) = mkDyadic (fsLit "quotWord8X64#") word8X64PrimTy primOpInfo (VecQuotOp WordVec 32 W16) = mkDyadic (fsLit "quotWord16X32#") word16X32PrimTy primOpInfo (VecQuotOp WordVec 16 W32) = mkDyadic (fsLit "quotWord32X16#") word32X16PrimTy primOpInfo (VecQuotOp WordVec 8 W64) = mkDyadic (fsLit "quotWord64X8#") word64X8PrimTy primOpInfo (VecRemOp IntVec 16 W8) = mkDyadic (fsLit "remInt8X16#") int8X16PrimTy primOpInfo (VecRemOp IntVec 8 W16) = mkDyadic (fsLit "remInt16X8#") int16X8PrimTy primOpInfo (VecRemOp IntVec 4 W32) = mkDyadic (fsLit "remInt32X4#") int32X4PrimTy primOpInfo (VecRemOp IntVec 2 W64) = mkDyadic (fsLit "remInt64X2#") int64X2PrimTy primOpInfo (VecRemOp IntVec 32 W8) = mkDyadic (fsLit "remInt8X32#") int8X32PrimTy primOpInfo (VecRemOp IntVec 16 W16) = mkDyadic (fsLit "remInt16X16#") int16X16PrimTy primOpInfo (VecRemOp IntVec 8 W32) = mkDyadic (fsLit "remInt32X8#") int32X8PrimTy primOpInfo (VecRemOp IntVec 4 W64) = mkDyadic (fsLit "remInt64X4#") int64X4PrimTy primOpInfo (VecRemOp IntVec 64 W8) = mkDyadic (fsLit "remInt8X64#") int8X64PrimTy primOpInfo (VecRemOp IntVec 32 W16) = mkDyadic (fsLit "remInt16X32#") int16X32PrimTy primOpInfo (VecRemOp IntVec 16 W32) = mkDyadic (fsLit "remInt32X16#") int32X16PrimTy primOpInfo (VecRemOp IntVec 8 W64) = mkDyadic (fsLit "remInt64X8#") int64X8PrimTy primOpInfo (VecRemOp WordVec 16 W8) = mkDyadic (fsLit "remWord8X16#") word8X16PrimTy primOpInfo (VecRemOp WordVec 8 W16) = mkDyadic (fsLit "remWord16X8#") word16X8PrimTy primOpInfo (VecRemOp WordVec 4 W32) = mkDyadic (fsLit "remWord32X4#") word32X4PrimTy primOpInfo (VecRemOp WordVec 2 W64) = mkDyadic (fsLit "remWord64X2#") word64X2PrimTy primOpInfo (VecRemOp WordVec 32 W8) = mkDyadic (fsLit "remWord8X32#") word8X32PrimTy primOpInfo (VecRemOp WordVec 16 W16) = mkDyadic (fsLit "remWord16X16#") word16X16PrimTy primOpInfo (VecRemOp WordVec 8 W32) = mkDyadic (fsLit "remWord32X8#") word32X8PrimTy primOpInfo (VecRemOp WordVec 4 W64) = mkDyadic (fsLit "remWord64X4#") word64X4PrimTy primOpInfo (VecRemOp WordVec 64 W8) = mkDyadic (fsLit "remWord8X64#") word8X64PrimTy primOpInfo (VecRemOp WordVec 32 W16) = mkDyadic (fsLit "remWord16X32#") word16X32PrimTy primOpInfo (VecRemOp WordVec 16 W32) = mkDyadic (fsLit "remWord32X16#") word32X16PrimTy primOpInfo (VecRemOp WordVec 8 W64) = mkDyadic (fsLit "remWord64X8#") word64X8PrimTy primOpInfo (VecNegOp IntVec 16 W8) = mkMonadic (fsLit "negateInt8X16#") int8X16PrimTy primOpInfo (VecNegOp IntVec 8 W16) = mkMonadic (fsLit "negateInt16X8#") int16X8PrimTy primOpInfo (VecNegOp IntVec 4 W32) = mkMonadic (fsLit "negateInt32X4#") int32X4PrimTy primOpInfo (VecNegOp IntVec 2 W64) = mkMonadic (fsLit "negateInt64X2#") int64X2PrimTy primOpInfo (VecNegOp IntVec 32 W8) = mkMonadic (fsLit "negateInt8X32#") int8X32PrimTy primOpInfo (VecNegOp IntVec 16 W16) = mkMonadic (fsLit "negateInt16X16#") int16X16PrimTy primOpInfo (VecNegOp IntVec 8 W32) = mkMonadic (fsLit "negateInt32X8#") int32X8PrimTy primOpInfo (VecNegOp IntVec 4 W64) = mkMonadic (fsLit "negateInt64X4#") int64X4PrimTy primOpInfo (VecNegOp IntVec 64 W8) = mkMonadic (fsLit "negateInt8X64#") int8X64PrimTy primOpInfo (VecNegOp IntVec 32 W16) = mkMonadic (fsLit "negateInt16X32#") int16X32PrimTy primOpInfo (VecNegOp IntVec 16 W32) = mkMonadic (fsLit "negateInt32X16#") int32X16PrimTy primOpInfo (VecNegOp IntVec 8 W64) = mkMonadic (fsLit "negateInt64X8#") int64X8PrimTy primOpInfo (VecNegOp FloatVec 4 W32) = mkMonadic (fsLit "negateFloatX4#") floatX4PrimTy primOpInfo (VecNegOp FloatVec 2 W64) = mkMonadic (fsLit "negateDoubleX2#") doubleX2PrimTy primOpInfo (VecNegOp FloatVec 8 W32) = mkMonadic (fsLit "negateFloatX8#") floatX8PrimTy primOpInfo (VecNegOp FloatVec 4 W64) = mkMonadic (fsLit "negateDoubleX4#") doubleX4PrimTy primOpInfo (VecNegOp FloatVec 16 W32) = mkMonadic (fsLit "negateFloatX16#") floatX16PrimTy primOpInfo (VecNegOp FloatVec 8 W64) = mkMonadic (fsLit "negateDoubleX8#") doubleX8PrimTy primOpInfo (VecIndexByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16Array#") [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy) primOpInfo (VecIndexByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8Array#") [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy) primOpInfo (VecIndexByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4Array#") [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy) primOpInfo (VecIndexByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2Array#") [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy) primOpInfo (VecIndexByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32Array#") [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy) primOpInfo (VecIndexByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16Array#") [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy) primOpInfo (VecIndexByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8Array#") [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy) primOpInfo (VecIndexByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4Array#") [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy) primOpInfo (VecIndexByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64Array#") [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy) primOpInfo (VecIndexByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32Array#") [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy) primOpInfo (VecIndexByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16Array#") [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy) primOpInfo (VecIndexByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8Array#") [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy) primOpInfo (VecIndexByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16Array#") [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy) primOpInfo (VecIndexByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8Array#") [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy) primOpInfo (VecIndexByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4Array#") [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy) primOpInfo (VecIndexByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2Array#") [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy) primOpInfo (VecIndexByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32Array#") [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy) primOpInfo (VecIndexByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16Array#") [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy) primOpInfo (VecIndexByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8Array#") [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy) primOpInfo (VecIndexByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4Array#") [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy) primOpInfo (VecIndexByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64Array#") [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy) primOpInfo (VecIndexByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32Array#") [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy) primOpInfo (VecIndexByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16Array#") [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy) primOpInfo (VecIndexByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8Array#") [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy) primOpInfo (VecIndexByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4Array#") [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy) primOpInfo (VecIndexByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2Array#") [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy) primOpInfo (VecIndexByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8Array#") [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy) primOpInfo (VecIndexByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4Array#") [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy) primOpInfo (VecIndexByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16Array#") [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy) primOpInfo (VecIndexByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8Array#") [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy) primOpInfo (VecReadByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) primOpInfo (VecReadByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) primOpInfo (VecReadByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) primOpInfo (VecReadByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) primOpInfo (VecReadByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) primOpInfo (VecReadByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) primOpInfo (VecReadByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) primOpInfo (VecReadByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) primOpInfo (VecReadByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) primOpInfo (VecReadByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) primOpInfo (VecReadByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) primOpInfo (VecReadByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) primOpInfo (VecReadByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) primOpInfo (VecReadByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) primOpInfo (VecReadByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) primOpInfo (VecReadByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) primOpInfo (VecReadByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) primOpInfo (VecReadByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) primOpInfo (VecReadByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) primOpInfo (VecReadByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) primOpInfo (VecReadByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) primOpInfo (VecReadByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) primOpInfo (VecReadByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) primOpInfo (VecReadByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) primOpInfo (VecReadByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) primOpInfo (VecReadByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) primOpInfo (VecReadByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) primOpInfo (VecReadByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) primOpInfo (VecReadByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) primOpInfo (VecReadByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) primOpInfo (VecWriteByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecIndexOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16OffAddr#") [] [addrPrimTy, intPrimTy] (int8X16PrimTy) primOpInfo (VecIndexOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8OffAddr#") [] [addrPrimTy, intPrimTy] (int16X8PrimTy) primOpInfo (VecIndexOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4OffAddr#") [] [addrPrimTy, intPrimTy] (int32X4PrimTy) primOpInfo (VecIndexOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2OffAddr#") [] [addrPrimTy, intPrimTy] (int64X2PrimTy) primOpInfo (VecIndexOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32OffAddr#") [] [addrPrimTy, intPrimTy] (int8X32PrimTy) primOpInfo (VecIndexOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16OffAddr#") [] [addrPrimTy, intPrimTy] (int16X16PrimTy) primOpInfo (VecIndexOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8OffAddr#") [] [addrPrimTy, intPrimTy] (int32X8PrimTy) primOpInfo (VecIndexOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4OffAddr#") [] [addrPrimTy, intPrimTy] (int64X4PrimTy) primOpInfo (VecIndexOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64OffAddr#") [] [addrPrimTy, intPrimTy] (int8X64PrimTy) primOpInfo (VecIndexOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32OffAddr#") [] [addrPrimTy, intPrimTy] (int16X32PrimTy) primOpInfo (VecIndexOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16OffAddr#") [] [addrPrimTy, intPrimTy] (int32X16PrimTy) primOpInfo (VecIndexOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8OffAddr#") [] [addrPrimTy, intPrimTy] (int64X8PrimTy) primOpInfo (VecIndexOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16OffAddr#") [] [addrPrimTy, intPrimTy] (word8X16PrimTy) primOpInfo (VecIndexOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8OffAddr#") [] [addrPrimTy, intPrimTy] (word16X8PrimTy) primOpInfo (VecIndexOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4OffAddr#") [] [addrPrimTy, intPrimTy] (word32X4PrimTy) primOpInfo (VecIndexOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2OffAddr#") [] [addrPrimTy, intPrimTy] (word64X2PrimTy) primOpInfo (VecIndexOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32OffAddr#") [] [addrPrimTy, intPrimTy] (word8X32PrimTy) primOpInfo (VecIndexOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16OffAddr#") [] [addrPrimTy, intPrimTy] (word16X16PrimTy) primOpInfo (VecIndexOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8OffAddr#") [] [addrPrimTy, intPrimTy] (word32X8PrimTy) primOpInfo (VecIndexOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4OffAddr#") [] [addrPrimTy, intPrimTy] (word64X4PrimTy) primOpInfo (VecIndexOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64OffAddr#") [] [addrPrimTy, intPrimTy] (word8X64PrimTy) primOpInfo (VecIndexOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32OffAddr#") [] [addrPrimTy, intPrimTy] (word16X32PrimTy) primOpInfo (VecIndexOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16OffAddr#") [] [addrPrimTy, intPrimTy] (word32X16PrimTy) primOpInfo (VecIndexOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8OffAddr#") [] [addrPrimTy, intPrimTy] (word64X8PrimTy) primOpInfo (VecIndexOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4OffAddr#") [] [addrPrimTy, intPrimTy] (floatX4PrimTy) primOpInfo (VecIndexOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2OffAddr#") [] [addrPrimTy, intPrimTy] (doubleX2PrimTy) primOpInfo (VecIndexOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8OffAddr#") [] [addrPrimTy, intPrimTy] (floatX8PrimTy) primOpInfo (VecIndexOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4OffAddr#") [] [addrPrimTy, intPrimTy] (doubleX4PrimTy) primOpInfo (VecIndexOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16OffAddr#") [] [addrPrimTy, intPrimTy] (floatX16PrimTy) primOpInfo (VecIndexOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8OffAddr#") [] [addrPrimTy, intPrimTy] (doubleX8PrimTy) primOpInfo (VecReadOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) primOpInfo (VecReadOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) primOpInfo (VecReadOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) primOpInfo (VecReadOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) primOpInfo (VecReadOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) primOpInfo (VecReadOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) primOpInfo (VecReadOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) primOpInfo (VecReadOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) primOpInfo (VecReadOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) primOpInfo (VecReadOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) primOpInfo (VecReadOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) primOpInfo (VecReadOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) primOpInfo (VecReadOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) primOpInfo (VecReadOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) primOpInfo (VecReadOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) primOpInfo (VecReadOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) primOpInfo (VecReadOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) primOpInfo (VecReadOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) primOpInfo (VecReadOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) primOpInfo (VecReadOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) primOpInfo (VecReadOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) primOpInfo (VecReadOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) primOpInfo (VecReadOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) primOpInfo (VecReadOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) primOpInfo (VecReadOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) primOpInfo (VecReadOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) primOpInfo (VecReadOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) primOpInfo (VecReadOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) primOpInfo (VecReadOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) primOpInfo (VecReadOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) primOpInfo (VecWriteOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X16#") [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy) primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X8#") [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy) primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X4#") [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy) primOpInfo (VecIndexScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X2#") [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy) primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X32#") [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy) primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X16#") [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy) primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X8#") [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy) primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X4#") [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy) primOpInfo (VecIndexScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X64#") [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy) primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X32#") [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy) primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X16#") [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy) primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X8#") [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy) primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X16#") [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy) primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X8#") [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy) primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X4#") [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy) primOpInfo (VecIndexScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X2#") [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy) primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X32#") [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy) primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X16#") [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy) primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X8#") [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy) primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X4#") [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy) primOpInfo (VecIndexScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X64#") [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy) primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X32#") [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy) primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X16#") [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy) primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X8#") [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy) primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX4#") [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy) primOpInfo (VecIndexScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX2#") [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy) primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX8#") [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy) primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX4#") [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy) primOpInfo (VecIndexScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX16#") [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy) primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX8#") [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy) primOpInfo (VecReadScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) primOpInfo (VecReadScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) primOpInfo (VecReadScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) primOpInfo (VecReadScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) primOpInfo (VecReadScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) primOpInfo (VecReadScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) primOpInfo (VecReadScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) primOpInfo (VecReadScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) primOpInfo (VecReadScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) primOpInfo (VecReadScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) primOpInfo (VecReadScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) primOpInfo (VecReadScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) primOpInfo (VecReadScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) primOpInfo (VecReadScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) primOpInfo (VecReadScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) primOpInfo (VecReadScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) primOpInfo (VecReadScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) primOpInfo (VecReadScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) primOpInfo (VecReadScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) primOpInfo (VecReadScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) primOpInfo (VecReadScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) primOpInfo (VecReadScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) primOpInfo (VecReadScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) primOpInfo (VecReadScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) primOpInfo (VecReadScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) primOpInfo (VecReadScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X16#") [] [addrPrimTy, intPrimTy] (int8X16PrimTy) primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X8#") [] [addrPrimTy, intPrimTy] (int16X8PrimTy) primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X4#") [] [addrPrimTy, intPrimTy] (int32X4PrimTy) primOpInfo (VecIndexScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X2#") [] [addrPrimTy, intPrimTy] (int64X2PrimTy) primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X32#") [] [addrPrimTy, intPrimTy] (int8X32PrimTy) primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X16#") [] [addrPrimTy, intPrimTy] (int16X16PrimTy) primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X8#") [] [addrPrimTy, intPrimTy] (int32X8PrimTy) primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X4#") [] [addrPrimTy, intPrimTy] (int64X4PrimTy) primOpInfo (VecIndexScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X64#") [] [addrPrimTy, intPrimTy] (int8X64PrimTy) primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X32#") [] [addrPrimTy, intPrimTy] (int16X32PrimTy) primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X16#") [] [addrPrimTy, intPrimTy] (int32X16PrimTy) primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X8#") [] [addrPrimTy, intPrimTy] (int64X8PrimTy) primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X16#") [] [addrPrimTy, intPrimTy] (word8X16PrimTy) primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X8#") [] [addrPrimTy, intPrimTy] (word16X8PrimTy) primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X4#") [] [addrPrimTy, intPrimTy] (word32X4PrimTy) primOpInfo (VecIndexScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X2#") [] [addrPrimTy, intPrimTy] (word64X2PrimTy) primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X32#") [] [addrPrimTy, intPrimTy] (word8X32PrimTy) primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X16#") [] [addrPrimTy, intPrimTy] (word16X16PrimTy) primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X8#") [] [addrPrimTy, intPrimTy] (word32X8PrimTy) primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X4#") [] [addrPrimTy, intPrimTy] (word64X4PrimTy) primOpInfo (VecIndexScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X64#") [] [addrPrimTy, intPrimTy] (word8X64PrimTy) primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X32#") [] [addrPrimTy, intPrimTy] (word16X32PrimTy) primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X16#") [] [addrPrimTy, intPrimTy] (word32X16PrimTy) primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X8#") [] [addrPrimTy, intPrimTy] (word64X8PrimTy) primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX4#") [] [addrPrimTy, intPrimTy] (floatX4PrimTy) primOpInfo (VecIndexScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX2#") [] [addrPrimTy, intPrimTy] (doubleX2PrimTy) primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX8#") [] [addrPrimTy, intPrimTy] (floatX8PrimTy) primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX4#") [] [addrPrimTy, intPrimTy] (doubleX4PrimTy) primOpInfo (VecIndexScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX16#") [] [addrPrimTy, intPrimTy] (floatX16PrimTy) primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX8#") [] [addrPrimTy, intPrimTy] (doubleX8PrimTy) primOpInfo (VecReadScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy])) primOpInfo (VecReadScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy])) primOpInfo (VecReadScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy])) primOpInfo (VecReadScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy])) primOpInfo (VecReadScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy])) primOpInfo (VecReadScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy])) primOpInfo (VecReadScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy])) primOpInfo (VecReadScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy])) primOpInfo (VecReadScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy])) primOpInfo (VecReadScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy])) primOpInfo (VecReadScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy])) primOpInfo (VecReadScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy])) primOpInfo (VecReadScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy])) primOpInfo (VecReadScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy])) primOpInfo (VecReadScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy])) primOpInfo (VecReadScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy])) primOpInfo (VecReadScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy])) primOpInfo (VecReadScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy])) primOpInfo (VecReadScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy])) primOpInfo (VecReadScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy])) primOpInfo (VecReadScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy])) primOpInfo (VecReadScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy])) primOpInfo (VecReadScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy])) primOpInfo (VecReadScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy])) primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy])) primOpInfo (VecReadScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy])) primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy])) primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy])) primOpInfo (VecReadScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy])) primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy])) primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX4#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX2#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX8#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX4#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX16#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX8#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchByteArrayOp3 = mkGenPrimOp (fsLit "prefetchByteArray3#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchMutableByteArrayOp3 = mkGenPrimOp (fsLit "prefetchMutableByteArray3#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchAddrOp3 = mkGenPrimOp (fsLit "prefetchAddr3#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchValueOp3 = mkGenPrimOp (fsLit "prefetchValue3#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchByteArrayOp2 = mkGenPrimOp (fsLit "prefetchByteArray2#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchMutableByteArrayOp2 = mkGenPrimOp (fsLit "prefetchMutableByteArray2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchAddrOp2 = mkGenPrimOp (fsLit "prefetchAddr2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchValueOp2 = mkGenPrimOp (fsLit "prefetchValue2#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchByteArrayOp1 = mkGenPrimOp (fsLit "prefetchByteArray1#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchMutableByteArrayOp1 = mkGenPrimOp (fsLit "prefetchMutableByteArray1#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchAddrOp1 = mkGenPrimOp (fsLit "prefetchAddr1#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchValueOp1 = mkGenPrimOp (fsLit "prefetchValue1#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchByteArrayOp0 = mkGenPrimOp (fsLit "prefetchByteArray0#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchMutableByteArrayOp0 = mkGenPrimOp (fsLit "prefetchMutableByteArray0#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchAddrOp0 = mkGenPrimOp (fsLit "prefetchAddr0#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo PrefetchValueOp0 = mkGenPrimOp (fsLit "prefetchValue0#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl0000644000000000000000000000342013713636035026064 0ustar0000000000000000primOpStrictness CatchOp = \ _arity -> mkClosedStrictSig [ lazyApply1Dmd , lazyApply2Dmd , topDmd] topRes primOpStrictness RaiseOp = \ _arity -> mkClosedStrictSig [topDmd] botRes primOpStrictness RaiseIOOp = \ _arity -> mkClosedStrictSig [topDmd, topDmd] botRes primOpStrictness MaskAsyncExceptionsOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes primOpStrictness MaskUninterruptibleOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes primOpStrictness UnmaskAsyncExceptionsOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes primOpStrictness AtomicallyOp = \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes primOpStrictness RetryOp = \ _arity -> mkClosedStrictSig [topDmd] botRes primOpStrictness CatchRetryOp = \ _arity -> mkClosedStrictSig [ lazyApply1Dmd , lazyApply1Dmd , topDmd ] topRes primOpStrictness CatchSTMOp = \ _arity -> mkClosedStrictSig [ lazyApply1Dmd , lazyApply2Dmd , topDmd ] topRes primOpStrictness DataToTagOp = \ _arity -> mkClosedStrictSig [evalDmd] topRes primOpStrictness PrefetchValueOp3 = \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes primOpStrictness PrefetchValueOp2 = \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes primOpStrictness PrefetchValueOp1 = \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes primOpStrictness PrefetchValueOp0 = \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes primOpStrictness _ = \ arity -> mkClosedStrictSig (replicate arity topDmd) topRes ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/primop-tag.hs-incl0000644000000000000000000014104713713636035024446 0ustar0000000000000000maxPrimOpTag :: Int maxPrimOpTag = 1203 primOpTag :: PrimOp -> Int primOpTag CharGtOp = 1 primOpTag CharGeOp = 2 primOpTag CharEqOp = 3 primOpTag CharNeOp = 4 primOpTag CharLtOp = 5 primOpTag CharLeOp = 6 primOpTag OrdOp = 7 primOpTag IntAddOp = 8 primOpTag IntSubOp = 9 primOpTag IntMulOp = 10 primOpTag IntMulMayOfloOp = 11 primOpTag IntQuotOp = 12 primOpTag IntRemOp = 13 primOpTag IntQuotRemOp = 14 primOpTag AndIOp = 15 primOpTag OrIOp = 16 primOpTag XorIOp = 17 primOpTag NotIOp = 18 primOpTag IntNegOp = 19 primOpTag IntAddCOp = 20 primOpTag IntSubCOp = 21 primOpTag IntGtOp = 22 primOpTag IntGeOp = 23 primOpTag IntEqOp = 24 primOpTag IntNeOp = 25 primOpTag IntLtOp = 26 primOpTag IntLeOp = 27 primOpTag ChrOp = 28 primOpTag Int2WordOp = 29 primOpTag Int2FloatOp = 30 primOpTag Int2DoubleOp = 31 primOpTag Word2FloatOp = 32 primOpTag Word2DoubleOp = 33 primOpTag ISllOp = 34 primOpTag ISraOp = 35 primOpTag ISrlOp = 36 primOpTag Int8Extend = 37 primOpTag Int8Narrow = 38 primOpTag Int8NegOp = 39 primOpTag Int8AddOp = 40 primOpTag Int8SubOp = 41 primOpTag Int8MulOp = 42 primOpTag Int8QuotOp = 43 primOpTag Int8RemOp = 44 primOpTag Int8QuotRemOp = 45 primOpTag Int8EqOp = 46 primOpTag Int8GeOp = 47 primOpTag Int8GtOp = 48 primOpTag Int8LeOp = 49 primOpTag Int8LtOp = 50 primOpTag Int8NeOp = 51 primOpTag Word8Extend = 52 primOpTag Word8Narrow = 53 primOpTag Word8NotOp = 54 primOpTag Word8AddOp = 55 primOpTag Word8SubOp = 56 primOpTag Word8MulOp = 57 primOpTag Word8QuotOp = 58 primOpTag Word8RemOp = 59 primOpTag Word8QuotRemOp = 60 primOpTag Word8EqOp = 61 primOpTag Word8GeOp = 62 primOpTag Word8GtOp = 63 primOpTag Word8LeOp = 64 primOpTag Word8LtOp = 65 primOpTag Word8NeOp = 66 primOpTag Int16Extend = 67 primOpTag Int16Narrow = 68 primOpTag Int16NegOp = 69 primOpTag Int16AddOp = 70 primOpTag Int16SubOp = 71 primOpTag Int16MulOp = 72 primOpTag Int16QuotOp = 73 primOpTag Int16RemOp = 74 primOpTag Int16QuotRemOp = 75 primOpTag Int16EqOp = 76 primOpTag Int16GeOp = 77 primOpTag Int16GtOp = 78 primOpTag Int16LeOp = 79 primOpTag Int16LtOp = 80 primOpTag Int16NeOp = 81 primOpTag Word16Extend = 82 primOpTag Word16Narrow = 83 primOpTag Word16NotOp = 84 primOpTag Word16AddOp = 85 primOpTag Word16SubOp = 86 primOpTag Word16MulOp = 87 primOpTag Word16QuotOp = 88 primOpTag Word16RemOp = 89 primOpTag Word16QuotRemOp = 90 primOpTag Word16EqOp = 91 primOpTag Word16GeOp = 92 primOpTag Word16GtOp = 93 primOpTag Word16LeOp = 94 primOpTag Word16LtOp = 95 primOpTag Word16NeOp = 96 primOpTag WordAddOp = 97 primOpTag WordAddCOp = 98 primOpTag WordSubCOp = 99 primOpTag WordAdd2Op = 100 primOpTag WordSubOp = 101 primOpTag WordMulOp = 102 primOpTag WordMul2Op = 103 primOpTag WordQuotOp = 104 primOpTag WordRemOp = 105 primOpTag WordQuotRemOp = 106 primOpTag WordQuotRem2Op = 107 primOpTag AndOp = 108 primOpTag OrOp = 109 primOpTag XorOp = 110 primOpTag NotOp = 111 primOpTag SllOp = 112 primOpTag SrlOp = 113 primOpTag Word2IntOp = 114 primOpTag WordGtOp = 115 primOpTag WordGeOp = 116 primOpTag WordEqOp = 117 primOpTag WordNeOp = 118 primOpTag WordLtOp = 119 primOpTag WordLeOp = 120 primOpTag PopCnt8Op = 121 primOpTag PopCnt16Op = 122 primOpTag PopCnt32Op = 123 primOpTag PopCnt64Op = 124 primOpTag PopCntOp = 125 primOpTag Pdep8Op = 126 primOpTag Pdep16Op = 127 primOpTag Pdep32Op = 128 primOpTag Pdep64Op = 129 primOpTag PdepOp = 130 primOpTag Pext8Op = 131 primOpTag Pext16Op = 132 primOpTag Pext32Op = 133 primOpTag Pext64Op = 134 primOpTag PextOp = 135 primOpTag Clz8Op = 136 primOpTag Clz16Op = 137 primOpTag Clz32Op = 138 primOpTag Clz64Op = 139 primOpTag ClzOp = 140 primOpTag Ctz8Op = 141 primOpTag Ctz16Op = 142 primOpTag Ctz32Op = 143 primOpTag Ctz64Op = 144 primOpTag CtzOp = 145 primOpTag BSwap16Op = 146 primOpTag BSwap32Op = 147 primOpTag BSwap64Op = 148 primOpTag BSwapOp = 149 primOpTag BRev8Op = 150 primOpTag BRev16Op = 151 primOpTag BRev32Op = 152 primOpTag BRev64Op = 153 primOpTag BRevOp = 154 primOpTag Narrow8IntOp = 155 primOpTag Narrow16IntOp = 156 primOpTag Narrow32IntOp = 157 primOpTag Narrow8WordOp = 158 primOpTag Narrow16WordOp = 159 primOpTag Narrow32WordOp = 160 primOpTag DoubleGtOp = 161 primOpTag DoubleGeOp = 162 primOpTag DoubleEqOp = 163 primOpTag DoubleNeOp = 164 primOpTag DoubleLtOp = 165 primOpTag DoubleLeOp = 166 primOpTag DoubleAddOp = 167 primOpTag DoubleSubOp = 168 primOpTag DoubleMulOp = 169 primOpTag DoubleDivOp = 170 primOpTag DoubleNegOp = 171 primOpTag DoubleFabsOp = 172 primOpTag Double2IntOp = 173 primOpTag Double2FloatOp = 174 primOpTag DoubleExpOp = 175 primOpTag DoubleExpM1Op = 176 primOpTag DoubleLogOp = 177 primOpTag DoubleLog1POp = 178 primOpTag DoubleSqrtOp = 179 primOpTag DoubleSinOp = 180 primOpTag DoubleCosOp = 181 primOpTag DoubleTanOp = 182 primOpTag DoubleAsinOp = 183 primOpTag DoubleAcosOp = 184 primOpTag DoubleAtanOp = 185 primOpTag DoubleSinhOp = 186 primOpTag DoubleCoshOp = 187 primOpTag DoubleTanhOp = 188 primOpTag DoubleAsinhOp = 189 primOpTag DoubleAcoshOp = 190 primOpTag DoubleAtanhOp = 191 primOpTag DoublePowerOp = 192 primOpTag DoubleDecode_2IntOp = 193 primOpTag DoubleDecode_Int64Op = 194 primOpTag FloatGtOp = 195 primOpTag FloatGeOp = 196 primOpTag FloatEqOp = 197 primOpTag FloatNeOp = 198 primOpTag FloatLtOp = 199 primOpTag FloatLeOp = 200 primOpTag FloatAddOp = 201 primOpTag FloatSubOp = 202 primOpTag FloatMulOp = 203 primOpTag FloatDivOp = 204 primOpTag FloatNegOp = 205 primOpTag FloatFabsOp = 206 primOpTag Float2IntOp = 207 primOpTag FloatExpOp = 208 primOpTag FloatExpM1Op = 209 primOpTag FloatLogOp = 210 primOpTag FloatLog1POp = 211 primOpTag FloatSqrtOp = 212 primOpTag FloatSinOp = 213 primOpTag FloatCosOp = 214 primOpTag FloatTanOp = 215 primOpTag FloatAsinOp = 216 primOpTag FloatAcosOp = 217 primOpTag FloatAtanOp = 218 primOpTag FloatSinhOp = 219 primOpTag FloatCoshOp = 220 primOpTag FloatTanhOp = 221 primOpTag FloatAsinhOp = 222 primOpTag FloatAcoshOp = 223 primOpTag FloatAtanhOp = 224 primOpTag FloatPowerOp = 225 primOpTag Float2DoubleOp = 226 primOpTag FloatDecode_IntOp = 227 primOpTag NewArrayOp = 228 primOpTag SameMutableArrayOp = 229 primOpTag ReadArrayOp = 230 primOpTag WriteArrayOp = 231 primOpTag SizeofArrayOp = 232 primOpTag SizeofMutableArrayOp = 233 primOpTag IndexArrayOp = 234 primOpTag UnsafeFreezeArrayOp = 235 primOpTag UnsafeThawArrayOp = 236 primOpTag CopyArrayOp = 237 primOpTag CopyMutableArrayOp = 238 primOpTag CloneArrayOp = 239 primOpTag CloneMutableArrayOp = 240 primOpTag FreezeArrayOp = 241 primOpTag ThawArrayOp = 242 primOpTag CasArrayOp = 243 primOpTag NewSmallArrayOp = 244 primOpTag SameSmallMutableArrayOp = 245 primOpTag ShrinkSmallMutableArrayOp_Char = 246 primOpTag ReadSmallArrayOp = 247 primOpTag WriteSmallArrayOp = 248 primOpTag SizeofSmallArrayOp = 249 primOpTag SizeofSmallMutableArrayOp = 250 primOpTag GetSizeofSmallMutableArrayOp = 251 primOpTag IndexSmallArrayOp = 252 primOpTag UnsafeFreezeSmallArrayOp = 253 primOpTag UnsafeThawSmallArrayOp = 254 primOpTag CopySmallArrayOp = 255 primOpTag CopySmallMutableArrayOp = 256 primOpTag CloneSmallArrayOp = 257 primOpTag CloneSmallMutableArrayOp = 258 primOpTag FreezeSmallArrayOp = 259 primOpTag ThawSmallArrayOp = 260 primOpTag CasSmallArrayOp = 261 primOpTag NewByteArrayOp_Char = 262 primOpTag NewPinnedByteArrayOp_Char = 263 primOpTag NewAlignedPinnedByteArrayOp_Char = 264 primOpTag MutableByteArrayIsPinnedOp = 265 primOpTag ByteArrayIsPinnedOp = 266 primOpTag ByteArrayContents_Char = 267 primOpTag SameMutableByteArrayOp = 268 primOpTag ShrinkMutableByteArrayOp_Char = 269 primOpTag ResizeMutableByteArrayOp_Char = 270 primOpTag UnsafeFreezeByteArrayOp = 271 primOpTag SizeofByteArrayOp = 272 primOpTag SizeofMutableByteArrayOp = 273 primOpTag GetSizeofMutableByteArrayOp = 274 primOpTag IndexByteArrayOp_Char = 275 primOpTag IndexByteArrayOp_WideChar = 276 primOpTag IndexByteArrayOp_Int = 277 primOpTag IndexByteArrayOp_Word = 278 primOpTag IndexByteArrayOp_Addr = 279 primOpTag IndexByteArrayOp_Float = 280 primOpTag IndexByteArrayOp_Double = 281 primOpTag IndexByteArrayOp_StablePtr = 282 primOpTag IndexByteArrayOp_Int8 = 283 primOpTag IndexByteArrayOp_Int16 = 284 primOpTag IndexByteArrayOp_Int32 = 285 primOpTag IndexByteArrayOp_Int64 = 286 primOpTag IndexByteArrayOp_Word8 = 287 primOpTag IndexByteArrayOp_Word16 = 288 primOpTag IndexByteArrayOp_Word32 = 289 primOpTag IndexByteArrayOp_Word64 = 290 primOpTag IndexByteArrayOp_Word8AsChar = 291 primOpTag IndexByteArrayOp_Word8AsWideChar = 292 primOpTag IndexByteArrayOp_Word8AsAddr = 293 primOpTag IndexByteArrayOp_Word8AsFloat = 294 primOpTag IndexByteArrayOp_Word8AsDouble = 295 primOpTag IndexByteArrayOp_Word8AsStablePtr = 296 primOpTag IndexByteArrayOp_Word8AsInt16 = 297 primOpTag IndexByteArrayOp_Word8AsInt32 = 298 primOpTag IndexByteArrayOp_Word8AsInt64 = 299 primOpTag IndexByteArrayOp_Word8AsInt = 300 primOpTag IndexByteArrayOp_Word8AsWord16 = 301 primOpTag IndexByteArrayOp_Word8AsWord32 = 302 primOpTag IndexByteArrayOp_Word8AsWord64 = 303 primOpTag IndexByteArrayOp_Word8AsWord = 304 primOpTag ReadByteArrayOp_Char = 305 primOpTag ReadByteArrayOp_WideChar = 306 primOpTag ReadByteArrayOp_Int = 307 primOpTag ReadByteArrayOp_Word = 308 primOpTag ReadByteArrayOp_Addr = 309 primOpTag ReadByteArrayOp_Float = 310 primOpTag ReadByteArrayOp_Double = 311 primOpTag ReadByteArrayOp_StablePtr = 312 primOpTag ReadByteArrayOp_Int8 = 313 primOpTag ReadByteArrayOp_Int16 = 314 primOpTag ReadByteArrayOp_Int32 = 315 primOpTag ReadByteArrayOp_Int64 = 316 primOpTag ReadByteArrayOp_Word8 = 317 primOpTag ReadByteArrayOp_Word16 = 318 primOpTag ReadByteArrayOp_Word32 = 319 primOpTag ReadByteArrayOp_Word64 = 320 primOpTag ReadByteArrayOp_Word8AsChar = 321 primOpTag ReadByteArrayOp_Word8AsWideChar = 322 primOpTag ReadByteArrayOp_Word8AsAddr = 323 primOpTag ReadByteArrayOp_Word8AsFloat = 324 primOpTag ReadByteArrayOp_Word8AsDouble = 325 primOpTag ReadByteArrayOp_Word8AsStablePtr = 326 primOpTag ReadByteArrayOp_Word8AsInt16 = 327 primOpTag ReadByteArrayOp_Word8AsInt32 = 328 primOpTag ReadByteArrayOp_Word8AsInt64 = 329 primOpTag ReadByteArrayOp_Word8AsInt = 330 primOpTag ReadByteArrayOp_Word8AsWord16 = 331 primOpTag ReadByteArrayOp_Word8AsWord32 = 332 primOpTag ReadByteArrayOp_Word8AsWord64 = 333 primOpTag ReadByteArrayOp_Word8AsWord = 334 primOpTag WriteByteArrayOp_Char = 335 primOpTag WriteByteArrayOp_WideChar = 336 primOpTag WriteByteArrayOp_Int = 337 primOpTag WriteByteArrayOp_Word = 338 primOpTag WriteByteArrayOp_Addr = 339 primOpTag WriteByteArrayOp_Float = 340 primOpTag WriteByteArrayOp_Double = 341 primOpTag WriteByteArrayOp_StablePtr = 342 primOpTag WriteByteArrayOp_Int8 = 343 primOpTag WriteByteArrayOp_Int16 = 344 primOpTag WriteByteArrayOp_Int32 = 345 primOpTag WriteByteArrayOp_Int64 = 346 primOpTag WriteByteArrayOp_Word8 = 347 primOpTag WriteByteArrayOp_Word16 = 348 primOpTag WriteByteArrayOp_Word32 = 349 primOpTag WriteByteArrayOp_Word64 = 350 primOpTag WriteByteArrayOp_Word8AsChar = 351 primOpTag WriteByteArrayOp_Word8AsWideChar = 352 primOpTag WriteByteArrayOp_Word8AsAddr = 353 primOpTag WriteByteArrayOp_Word8AsFloat = 354 primOpTag WriteByteArrayOp_Word8AsDouble = 355 primOpTag WriteByteArrayOp_Word8AsStablePtr = 356 primOpTag WriteByteArrayOp_Word8AsInt16 = 357 primOpTag WriteByteArrayOp_Word8AsInt32 = 358 primOpTag WriteByteArrayOp_Word8AsInt64 = 359 primOpTag WriteByteArrayOp_Word8AsInt = 360 primOpTag WriteByteArrayOp_Word8AsWord16 = 361 primOpTag WriteByteArrayOp_Word8AsWord32 = 362 primOpTag WriteByteArrayOp_Word8AsWord64 = 363 primOpTag WriteByteArrayOp_Word8AsWord = 364 primOpTag CompareByteArraysOp = 365 primOpTag CopyByteArrayOp = 366 primOpTag CopyMutableByteArrayOp = 367 primOpTag CopyByteArrayToAddrOp = 368 primOpTag CopyMutableByteArrayToAddrOp = 369 primOpTag CopyAddrToByteArrayOp = 370 primOpTag SetByteArrayOp = 371 primOpTag AtomicReadByteArrayOp_Int = 372 primOpTag AtomicWriteByteArrayOp_Int = 373 primOpTag CasByteArrayOp_Int = 374 primOpTag FetchAddByteArrayOp_Int = 375 primOpTag FetchSubByteArrayOp_Int = 376 primOpTag FetchAndByteArrayOp_Int = 377 primOpTag FetchNandByteArrayOp_Int = 378 primOpTag FetchOrByteArrayOp_Int = 379 primOpTag FetchXorByteArrayOp_Int = 380 primOpTag NewArrayArrayOp = 381 primOpTag SameMutableArrayArrayOp = 382 primOpTag UnsafeFreezeArrayArrayOp = 383 primOpTag SizeofArrayArrayOp = 384 primOpTag SizeofMutableArrayArrayOp = 385 primOpTag IndexArrayArrayOp_ByteArray = 386 primOpTag IndexArrayArrayOp_ArrayArray = 387 primOpTag ReadArrayArrayOp_ByteArray = 388 primOpTag ReadArrayArrayOp_MutableByteArray = 389 primOpTag ReadArrayArrayOp_ArrayArray = 390 primOpTag ReadArrayArrayOp_MutableArrayArray = 391 primOpTag WriteArrayArrayOp_ByteArray = 392 primOpTag WriteArrayArrayOp_MutableByteArray = 393 primOpTag WriteArrayArrayOp_ArrayArray = 394 primOpTag WriteArrayArrayOp_MutableArrayArray = 395 primOpTag CopyArrayArrayOp = 396 primOpTag CopyMutableArrayArrayOp = 397 primOpTag AddrAddOp = 398 primOpTag AddrSubOp = 399 primOpTag AddrRemOp = 400 primOpTag Addr2IntOp = 401 primOpTag Int2AddrOp = 402 primOpTag AddrGtOp = 403 primOpTag AddrGeOp = 404 primOpTag AddrEqOp = 405 primOpTag AddrNeOp = 406 primOpTag AddrLtOp = 407 primOpTag AddrLeOp = 408 primOpTag IndexOffAddrOp_Char = 409 primOpTag IndexOffAddrOp_WideChar = 410 primOpTag IndexOffAddrOp_Int = 411 primOpTag IndexOffAddrOp_Word = 412 primOpTag IndexOffAddrOp_Addr = 413 primOpTag IndexOffAddrOp_Float = 414 primOpTag IndexOffAddrOp_Double = 415 primOpTag IndexOffAddrOp_StablePtr = 416 primOpTag IndexOffAddrOp_Int8 = 417 primOpTag IndexOffAddrOp_Int16 = 418 primOpTag IndexOffAddrOp_Int32 = 419 primOpTag IndexOffAddrOp_Int64 = 420 primOpTag IndexOffAddrOp_Word8 = 421 primOpTag IndexOffAddrOp_Word16 = 422 primOpTag IndexOffAddrOp_Word32 = 423 primOpTag IndexOffAddrOp_Word64 = 424 primOpTag ReadOffAddrOp_Char = 425 primOpTag ReadOffAddrOp_WideChar = 426 primOpTag ReadOffAddrOp_Int = 427 primOpTag ReadOffAddrOp_Word = 428 primOpTag ReadOffAddrOp_Addr = 429 primOpTag ReadOffAddrOp_Float = 430 primOpTag ReadOffAddrOp_Double = 431 primOpTag ReadOffAddrOp_StablePtr = 432 primOpTag ReadOffAddrOp_Int8 = 433 primOpTag ReadOffAddrOp_Int16 = 434 primOpTag ReadOffAddrOp_Int32 = 435 primOpTag ReadOffAddrOp_Int64 = 436 primOpTag ReadOffAddrOp_Word8 = 437 primOpTag ReadOffAddrOp_Word16 = 438 primOpTag ReadOffAddrOp_Word32 = 439 primOpTag ReadOffAddrOp_Word64 = 440 primOpTag WriteOffAddrOp_Char = 441 primOpTag WriteOffAddrOp_WideChar = 442 primOpTag WriteOffAddrOp_Int = 443 primOpTag WriteOffAddrOp_Word = 444 primOpTag WriteOffAddrOp_Addr = 445 primOpTag WriteOffAddrOp_Float = 446 primOpTag WriteOffAddrOp_Double = 447 primOpTag WriteOffAddrOp_StablePtr = 448 primOpTag WriteOffAddrOp_Int8 = 449 primOpTag WriteOffAddrOp_Int16 = 450 primOpTag WriteOffAddrOp_Int32 = 451 primOpTag WriteOffAddrOp_Int64 = 452 primOpTag WriteOffAddrOp_Word8 = 453 primOpTag WriteOffAddrOp_Word16 = 454 primOpTag WriteOffAddrOp_Word32 = 455 primOpTag WriteOffAddrOp_Word64 = 456 primOpTag NewMutVarOp = 457 primOpTag ReadMutVarOp = 458 primOpTag WriteMutVarOp = 459 primOpTag SameMutVarOp = 460 primOpTag AtomicModifyMutVar2Op = 461 primOpTag AtomicModifyMutVar_Op = 462 primOpTag CasMutVarOp = 463 primOpTag CatchOp = 464 primOpTag RaiseOp = 465 primOpTag RaiseIOOp = 466 primOpTag MaskAsyncExceptionsOp = 467 primOpTag MaskUninterruptibleOp = 468 primOpTag UnmaskAsyncExceptionsOp = 469 primOpTag MaskStatus = 470 primOpTag AtomicallyOp = 471 primOpTag RetryOp = 472 primOpTag CatchRetryOp = 473 primOpTag CatchSTMOp = 474 primOpTag NewTVarOp = 475 primOpTag ReadTVarOp = 476 primOpTag ReadTVarIOOp = 477 primOpTag WriteTVarOp = 478 primOpTag SameTVarOp = 479 primOpTag NewMVarOp = 480 primOpTag TakeMVarOp = 481 primOpTag TryTakeMVarOp = 482 primOpTag PutMVarOp = 483 primOpTag TryPutMVarOp = 484 primOpTag ReadMVarOp = 485 primOpTag TryReadMVarOp = 486 primOpTag SameMVarOp = 487 primOpTag IsEmptyMVarOp = 488 primOpTag DelayOp = 489 primOpTag WaitReadOp = 490 primOpTag WaitWriteOp = 491 primOpTag ForkOp = 492 primOpTag ForkOnOp = 493 primOpTag KillThreadOp = 494 primOpTag YieldOp = 495 primOpTag MyThreadIdOp = 496 primOpTag LabelThreadOp = 497 primOpTag IsCurrentThreadBoundOp = 498 primOpTag NoDuplicateOp = 499 primOpTag ThreadStatusOp = 500 primOpTag MkWeakOp = 501 primOpTag MkWeakNoFinalizerOp = 502 primOpTag AddCFinalizerToWeakOp = 503 primOpTag DeRefWeakOp = 504 primOpTag FinalizeWeakOp = 505 primOpTag TouchOp = 506 primOpTag MakeStablePtrOp = 507 primOpTag DeRefStablePtrOp = 508 primOpTag EqStablePtrOp = 509 primOpTag MakeStableNameOp = 510 primOpTag EqStableNameOp = 511 primOpTag StableNameToIntOp = 512 primOpTag CompactNewOp = 513 primOpTag CompactResizeOp = 514 primOpTag CompactContainsOp = 515 primOpTag CompactContainsAnyOp = 516 primOpTag CompactGetFirstBlockOp = 517 primOpTag CompactGetNextBlockOp = 518 primOpTag CompactAllocateBlockOp = 519 primOpTag CompactFixupPointersOp = 520 primOpTag CompactAdd = 521 primOpTag CompactAddWithSharing = 522 primOpTag CompactSize = 523 primOpTag ReallyUnsafePtrEqualityOp = 524 primOpTag ParOp = 525 primOpTag SparkOp = 526 primOpTag SeqOp = 527 primOpTag GetSparkOp = 528 primOpTag NumSparks = 529 primOpTag DataToTagOp = 530 primOpTag TagToEnumOp = 531 primOpTag AddrToAnyOp = 532 primOpTag AnyToAddrOp = 533 primOpTag MkApUpd0_Op = 534 primOpTag NewBCOOp = 535 primOpTag UnpackClosureOp = 536 primOpTag ClosureSizeOp = 537 primOpTag GetApStackValOp = 538 primOpTag GetCCSOfOp = 539 primOpTag GetCurrentCCSOp = 540 primOpTag ClearCCSOp = 541 primOpTag TraceEventOp = 542 primOpTag TraceEventBinaryOp = 543 primOpTag TraceMarkerOp = 544 primOpTag SetThreadAllocationCounter = 545 primOpTag (VecBroadcastOp IntVec 16 W8) = 546 primOpTag (VecBroadcastOp IntVec 8 W16) = 547 primOpTag (VecBroadcastOp IntVec 4 W32) = 548 primOpTag (VecBroadcastOp IntVec 2 W64) = 549 primOpTag (VecBroadcastOp IntVec 32 W8) = 550 primOpTag (VecBroadcastOp IntVec 16 W16) = 551 primOpTag (VecBroadcastOp IntVec 8 W32) = 552 primOpTag (VecBroadcastOp IntVec 4 W64) = 553 primOpTag (VecBroadcastOp IntVec 64 W8) = 554 primOpTag (VecBroadcastOp IntVec 32 W16) = 555 primOpTag (VecBroadcastOp IntVec 16 W32) = 556 primOpTag (VecBroadcastOp IntVec 8 W64) = 557 primOpTag (VecBroadcastOp WordVec 16 W8) = 558 primOpTag (VecBroadcastOp WordVec 8 W16) = 559 primOpTag (VecBroadcastOp WordVec 4 W32) = 560 primOpTag (VecBroadcastOp WordVec 2 W64) = 561 primOpTag (VecBroadcastOp WordVec 32 W8) = 562 primOpTag (VecBroadcastOp WordVec 16 W16) = 563 primOpTag (VecBroadcastOp WordVec 8 W32) = 564 primOpTag (VecBroadcastOp WordVec 4 W64) = 565 primOpTag (VecBroadcastOp WordVec 64 W8) = 566 primOpTag (VecBroadcastOp WordVec 32 W16) = 567 primOpTag (VecBroadcastOp WordVec 16 W32) = 568 primOpTag (VecBroadcastOp WordVec 8 W64) = 569 primOpTag (VecBroadcastOp FloatVec 4 W32) = 570 primOpTag (VecBroadcastOp FloatVec 2 W64) = 571 primOpTag (VecBroadcastOp FloatVec 8 W32) = 572 primOpTag (VecBroadcastOp FloatVec 4 W64) = 573 primOpTag (VecBroadcastOp FloatVec 16 W32) = 574 primOpTag (VecBroadcastOp FloatVec 8 W64) = 575 primOpTag (VecPackOp IntVec 16 W8) = 576 primOpTag (VecPackOp IntVec 8 W16) = 577 primOpTag (VecPackOp IntVec 4 W32) = 578 primOpTag (VecPackOp IntVec 2 W64) = 579 primOpTag (VecPackOp IntVec 32 W8) = 580 primOpTag (VecPackOp IntVec 16 W16) = 581 primOpTag (VecPackOp IntVec 8 W32) = 582 primOpTag (VecPackOp IntVec 4 W64) = 583 primOpTag (VecPackOp IntVec 64 W8) = 584 primOpTag (VecPackOp IntVec 32 W16) = 585 primOpTag (VecPackOp IntVec 16 W32) = 586 primOpTag (VecPackOp IntVec 8 W64) = 587 primOpTag (VecPackOp WordVec 16 W8) = 588 primOpTag (VecPackOp WordVec 8 W16) = 589 primOpTag (VecPackOp WordVec 4 W32) = 590 primOpTag (VecPackOp WordVec 2 W64) = 591 primOpTag (VecPackOp WordVec 32 W8) = 592 primOpTag (VecPackOp WordVec 16 W16) = 593 primOpTag (VecPackOp WordVec 8 W32) = 594 primOpTag (VecPackOp WordVec 4 W64) = 595 primOpTag (VecPackOp WordVec 64 W8) = 596 primOpTag (VecPackOp WordVec 32 W16) = 597 primOpTag (VecPackOp WordVec 16 W32) = 598 primOpTag (VecPackOp WordVec 8 W64) = 599 primOpTag (VecPackOp FloatVec 4 W32) = 600 primOpTag (VecPackOp FloatVec 2 W64) = 601 primOpTag (VecPackOp FloatVec 8 W32) = 602 primOpTag (VecPackOp FloatVec 4 W64) = 603 primOpTag (VecPackOp FloatVec 16 W32) = 604 primOpTag (VecPackOp FloatVec 8 W64) = 605 primOpTag (VecUnpackOp IntVec 16 W8) = 606 primOpTag (VecUnpackOp IntVec 8 W16) = 607 primOpTag (VecUnpackOp IntVec 4 W32) = 608 primOpTag (VecUnpackOp IntVec 2 W64) = 609 primOpTag (VecUnpackOp IntVec 32 W8) = 610 primOpTag (VecUnpackOp IntVec 16 W16) = 611 primOpTag (VecUnpackOp IntVec 8 W32) = 612 primOpTag (VecUnpackOp IntVec 4 W64) = 613 primOpTag (VecUnpackOp IntVec 64 W8) = 614 primOpTag (VecUnpackOp IntVec 32 W16) = 615 primOpTag (VecUnpackOp IntVec 16 W32) = 616 primOpTag (VecUnpackOp IntVec 8 W64) = 617 primOpTag (VecUnpackOp WordVec 16 W8) = 618 primOpTag (VecUnpackOp WordVec 8 W16) = 619 primOpTag (VecUnpackOp WordVec 4 W32) = 620 primOpTag (VecUnpackOp WordVec 2 W64) = 621 primOpTag (VecUnpackOp WordVec 32 W8) = 622 primOpTag (VecUnpackOp WordVec 16 W16) = 623 primOpTag (VecUnpackOp WordVec 8 W32) = 624 primOpTag (VecUnpackOp WordVec 4 W64) = 625 primOpTag (VecUnpackOp WordVec 64 W8) = 626 primOpTag (VecUnpackOp WordVec 32 W16) = 627 primOpTag (VecUnpackOp WordVec 16 W32) = 628 primOpTag (VecUnpackOp WordVec 8 W64) = 629 primOpTag (VecUnpackOp FloatVec 4 W32) = 630 primOpTag (VecUnpackOp FloatVec 2 W64) = 631 primOpTag (VecUnpackOp FloatVec 8 W32) = 632 primOpTag (VecUnpackOp FloatVec 4 W64) = 633 primOpTag (VecUnpackOp FloatVec 16 W32) = 634 primOpTag (VecUnpackOp FloatVec 8 W64) = 635 primOpTag (VecInsertOp IntVec 16 W8) = 636 primOpTag (VecInsertOp IntVec 8 W16) = 637 primOpTag (VecInsertOp IntVec 4 W32) = 638 primOpTag (VecInsertOp IntVec 2 W64) = 639 primOpTag (VecInsertOp IntVec 32 W8) = 640 primOpTag (VecInsertOp IntVec 16 W16) = 641 primOpTag (VecInsertOp IntVec 8 W32) = 642 primOpTag (VecInsertOp IntVec 4 W64) = 643 primOpTag (VecInsertOp IntVec 64 W8) = 644 primOpTag (VecInsertOp IntVec 32 W16) = 645 primOpTag (VecInsertOp IntVec 16 W32) = 646 primOpTag (VecInsertOp IntVec 8 W64) = 647 primOpTag (VecInsertOp WordVec 16 W8) = 648 primOpTag (VecInsertOp WordVec 8 W16) = 649 primOpTag (VecInsertOp WordVec 4 W32) = 650 primOpTag (VecInsertOp WordVec 2 W64) = 651 primOpTag (VecInsertOp WordVec 32 W8) = 652 primOpTag (VecInsertOp WordVec 16 W16) = 653 primOpTag (VecInsertOp WordVec 8 W32) = 654 primOpTag (VecInsertOp WordVec 4 W64) = 655 primOpTag (VecInsertOp WordVec 64 W8) = 656 primOpTag (VecInsertOp WordVec 32 W16) = 657 primOpTag (VecInsertOp WordVec 16 W32) = 658 primOpTag (VecInsertOp WordVec 8 W64) = 659 primOpTag (VecInsertOp FloatVec 4 W32) = 660 primOpTag (VecInsertOp FloatVec 2 W64) = 661 primOpTag (VecInsertOp FloatVec 8 W32) = 662 primOpTag (VecInsertOp FloatVec 4 W64) = 663 primOpTag (VecInsertOp FloatVec 16 W32) = 664 primOpTag (VecInsertOp FloatVec 8 W64) = 665 primOpTag (VecAddOp IntVec 16 W8) = 666 primOpTag (VecAddOp IntVec 8 W16) = 667 primOpTag (VecAddOp IntVec 4 W32) = 668 primOpTag (VecAddOp IntVec 2 W64) = 669 primOpTag (VecAddOp IntVec 32 W8) = 670 primOpTag (VecAddOp IntVec 16 W16) = 671 primOpTag (VecAddOp IntVec 8 W32) = 672 primOpTag (VecAddOp IntVec 4 W64) = 673 primOpTag (VecAddOp IntVec 64 W8) = 674 primOpTag (VecAddOp IntVec 32 W16) = 675 primOpTag (VecAddOp IntVec 16 W32) = 676 primOpTag (VecAddOp IntVec 8 W64) = 677 primOpTag (VecAddOp WordVec 16 W8) = 678 primOpTag (VecAddOp WordVec 8 W16) = 679 primOpTag (VecAddOp WordVec 4 W32) = 680 primOpTag (VecAddOp WordVec 2 W64) = 681 primOpTag (VecAddOp WordVec 32 W8) = 682 primOpTag (VecAddOp WordVec 16 W16) = 683 primOpTag (VecAddOp WordVec 8 W32) = 684 primOpTag (VecAddOp WordVec 4 W64) = 685 primOpTag (VecAddOp WordVec 64 W8) = 686 primOpTag (VecAddOp WordVec 32 W16) = 687 primOpTag (VecAddOp WordVec 16 W32) = 688 primOpTag (VecAddOp WordVec 8 W64) = 689 primOpTag (VecAddOp FloatVec 4 W32) = 690 primOpTag (VecAddOp FloatVec 2 W64) = 691 primOpTag (VecAddOp FloatVec 8 W32) = 692 primOpTag (VecAddOp FloatVec 4 W64) = 693 primOpTag (VecAddOp FloatVec 16 W32) = 694 primOpTag (VecAddOp FloatVec 8 W64) = 695 primOpTag (VecSubOp IntVec 16 W8) = 696 primOpTag (VecSubOp IntVec 8 W16) = 697 primOpTag (VecSubOp IntVec 4 W32) = 698 primOpTag (VecSubOp IntVec 2 W64) = 699 primOpTag (VecSubOp IntVec 32 W8) = 700 primOpTag (VecSubOp IntVec 16 W16) = 701 primOpTag (VecSubOp IntVec 8 W32) = 702 primOpTag (VecSubOp IntVec 4 W64) = 703 primOpTag (VecSubOp IntVec 64 W8) = 704 primOpTag (VecSubOp IntVec 32 W16) = 705 primOpTag (VecSubOp IntVec 16 W32) = 706 primOpTag (VecSubOp IntVec 8 W64) = 707 primOpTag (VecSubOp WordVec 16 W8) = 708 primOpTag (VecSubOp WordVec 8 W16) = 709 primOpTag (VecSubOp WordVec 4 W32) = 710 primOpTag (VecSubOp WordVec 2 W64) = 711 primOpTag (VecSubOp WordVec 32 W8) = 712 primOpTag (VecSubOp WordVec 16 W16) = 713 primOpTag (VecSubOp WordVec 8 W32) = 714 primOpTag (VecSubOp WordVec 4 W64) = 715 primOpTag (VecSubOp WordVec 64 W8) = 716 primOpTag (VecSubOp WordVec 32 W16) = 717 primOpTag (VecSubOp WordVec 16 W32) = 718 primOpTag (VecSubOp WordVec 8 W64) = 719 primOpTag (VecSubOp FloatVec 4 W32) = 720 primOpTag (VecSubOp FloatVec 2 W64) = 721 primOpTag (VecSubOp FloatVec 8 W32) = 722 primOpTag (VecSubOp FloatVec 4 W64) = 723 primOpTag (VecSubOp FloatVec 16 W32) = 724 primOpTag (VecSubOp FloatVec 8 W64) = 725 primOpTag (VecMulOp IntVec 16 W8) = 726 primOpTag (VecMulOp IntVec 8 W16) = 727 primOpTag (VecMulOp IntVec 4 W32) = 728 primOpTag (VecMulOp IntVec 2 W64) = 729 primOpTag (VecMulOp IntVec 32 W8) = 730 primOpTag (VecMulOp IntVec 16 W16) = 731 primOpTag (VecMulOp IntVec 8 W32) = 732 primOpTag (VecMulOp IntVec 4 W64) = 733 primOpTag (VecMulOp IntVec 64 W8) = 734 primOpTag (VecMulOp IntVec 32 W16) = 735 primOpTag (VecMulOp IntVec 16 W32) = 736 primOpTag (VecMulOp IntVec 8 W64) = 737 primOpTag (VecMulOp WordVec 16 W8) = 738 primOpTag (VecMulOp WordVec 8 W16) = 739 primOpTag (VecMulOp WordVec 4 W32) = 740 primOpTag (VecMulOp WordVec 2 W64) = 741 primOpTag (VecMulOp WordVec 32 W8) = 742 primOpTag (VecMulOp WordVec 16 W16) = 743 primOpTag (VecMulOp WordVec 8 W32) = 744 primOpTag (VecMulOp WordVec 4 W64) = 745 primOpTag (VecMulOp WordVec 64 W8) = 746 primOpTag (VecMulOp WordVec 32 W16) = 747 primOpTag (VecMulOp WordVec 16 W32) = 748 primOpTag (VecMulOp WordVec 8 W64) = 749 primOpTag (VecMulOp FloatVec 4 W32) = 750 primOpTag (VecMulOp FloatVec 2 W64) = 751 primOpTag (VecMulOp FloatVec 8 W32) = 752 primOpTag (VecMulOp FloatVec 4 W64) = 753 primOpTag (VecMulOp FloatVec 16 W32) = 754 primOpTag (VecMulOp FloatVec 8 W64) = 755 primOpTag (VecDivOp FloatVec 4 W32) = 756 primOpTag (VecDivOp FloatVec 2 W64) = 757 primOpTag (VecDivOp FloatVec 8 W32) = 758 primOpTag (VecDivOp FloatVec 4 W64) = 759 primOpTag (VecDivOp FloatVec 16 W32) = 760 primOpTag (VecDivOp FloatVec 8 W64) = 761 primOpTag (VecQuotOp IntVec 16 W8) = 762 primOpTag (VecQuotOp IntVec 8 W16) = 763 primOpTag (VecQuotOp IntVec 4 W32) = 764 primOpTag (VecQuotOp IntVec 2 W64) = 765 primOpTag (VecQuotOp IntVec 32 W8) = 766 primOpTag (VecQuotOp IntVec 16 W16) = 767 primOpTag (VecQuotOp IntVec 8 W32) = 768 primOpTag (VecQuotOp IntVec 4 W64) = 769 primOpTag (VecQuotOp IntVec 64 W8) = 770 primOpTag (VecQuotOp IntVec 32 W16) = 771 primOpTag (VecQuotOp IntVec 16 W32) = 772 primOpTag (VecQuotOp IntVec 8 W64) = 773 primOpTag (VecQuotOp WordVec 16 W8) = 774 primOpTag (VecQuotOp WordVec 8 W16) = 775 primOpTag (VecQuotOp WordVec 4 W32) = 776 primOpTag (VecQuotOp WordVec 2 W64) = 777 primOpTag (VecQuotOp WordVec 32 W8) = 778 primOpTag (VecQuotOp WordVec 16 W16) = 779 primOpTag (VecQuotOp WordVec 8 W32) = 780 primOpTag (VecQuotOp WordVec 4 W64) = 781 primOpTag (VecQuotOp WordVec 64 W8) = 782 primOpTag (VecQuotOp WordVec 32 W16) = 783 primOpTag (VecQuotOp WordVec 16 W32) = 784 primOpTag (VecQuotOp WordVec 8 W64) = 785 primOpTag (VecRemOp IntVec 16 W8) = 786 primOpTag (VecRemOp IntVec 8 W16) = 787 primOpTag (VecRemOp IntVec 4 W32) = 788 primOpTag (VecRemOp IntVec 2 W64) = 789 primOpTag (VecRemOp IntVec 32 W8) = 790 primOpTag (VecRemOp IntVec 16 W16) = 791 primOpTag (VecRemOp IntVec 8 W32) = 792 primOpTag (VecRemOp IntVec 4 W64) = 793 primOpTag (VecRemOp IntVec 64 W8) = 794 primOpTag (VecRemOp IntVec 32 W16) = 795 primOpTag (VecRemOp IntVec 16 W32) = 796 primOpTag (VecRemOp IntVec 8 W64) = 797 primOpTag (VecRemOp WordVec 16 W8) = 798 primOpTag (VecRemOp WordVec 8 W16) = 799 primOpTag (VecRemOp WordVec 4 W32) = 800 primOpTag (VecRemOp WordVec 2 W64) = 801 primOpTag (VecRemOp WordVec 32 W8) = 802 primOpTag (VecRemOp WordVec 16 W16) = 803 primOpTag (VecRemOp WordVec 8 W32) = 804 primOpTag (VecRemOp WordVec 4 W64) = 805 primOpTag (VecRemOp WordVec 64 W8) = 806 primOpTag (VecRemOp WordVec 32 W16) = 807 primOpTag (VecRemOp WordVec 16 W32) = 808 primOpTag (VecRemOp WordVec 8 W64) = 809 primOpTag (VecNegOp IntVec 16 W8) = 810 primOpTag (VecNegOp IntVec 8 W16) = 811 primOpTag (VecNegOp IntVec 4 W32) = 812 primOpTag (VecNegOp IntVec 2 W64) = 813 primOpTag (VecNegOp IntVec 32 W8) = 814 primOpTag (VecNegOp IntVec 16 W16) = 815 primOpTag (VecNegOp IntVec 8 W32) = 816 primOpTag (VecNegOp IntVec 4 W64) = 817 primOpTag (VecNegOp IntVec 64 W8) = 818 primOpTag (VecNegOp IntVec 32 W16) = 819 primOpTag (VecNegOp IntVec 16 W32) = 820 primOpTag (VecNegOp IntVec 8 W64) = 821 primOpTag (VecNegOp FloatVec 4 W32) = 822 primOpTag (VecNegOp FloatVec 2 W64) = 823 primOpTag (VecNegOp FloatVec 8 W32) = 824 primOpTag (VecNegOp FloatVec 4 W64) = 825 primOpTag (VecNegOp FloatVec 16 W32) = 826 primOpTag (VecNegOp FloatVec 8 W64) = 827 primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 828 primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 829 primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 830 primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 831 primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 832 primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 833 primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 834 primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 835 primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 836 primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 837 primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 838 primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 839 primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 840 primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 841 primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 842 primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 843 primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 844 primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 845 primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 846 primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 847 primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 848 primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 849 primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 850 primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 851 primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 852 primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 853 primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 854 primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 855 primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 856 primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 857 primOpTag (VecReadByteArrayOp IntVec 16 W8) = 858 primOpTag (VecReadByteArrayOp IntVec 8 W16) = 859 primOpTag (VecReadByteArrayOp IntVec 4 W32) = 860 primOpTag (VecReadByteArrayOp IntVec 2 W64) = 861 primOpTag (VecReadByteArrayOp IntVec 32 W8) = 862 primOpTag (VecReadByteArrayOp IntVec 16 W16) = 863 primOpTag (VecReadByteArrayOp IntVec 8 W32) = 864 primOpTag (VecReadByteArrayOp IntVec 4 W64) = 865 primOpTag (VecReadByteArrayOp IntVec 64 W8) = 866 primOpTag (VecReadByteArrayOp IntVec 32 W16) = 867 primOpTag (VecReadByteArrayOp IntVec 16 W32) = 868 primOpTag (VecReadByteArrayOp IntVec 8 W64) = 869 primOpTag (VecReadByteArrayOp WordVec 16 W8) = 870 primOpTag (VecReadByteArrayOp WordVec 8 W16) = 871 primOpTag (VecReadByteArrayOp WordVec 4 W32) = 872 primOpTag (VecReadByteArrayOp WordVec 2 W64) = 873 primOpTag (VecReadByteArrayOp WordVec 32 W8) = 874 primOpTag (VecReadByteArrayOp WordVec 16 W16) = 875 primOpTag (VecReadByteArrayOp WordVec 8 W32) = 876 primOpTag (VecReadByteArrayOp WordVec 4 W64) = 877 primOpTag (VecReadByteArrayOp WordVec 64 W8) = 878 primOpTag (VecReadByteArrayOp WordVec 32 W16) = 879 primOpTag (VecReadByteArrayOp WordVec 16 W32) = 880 primOpTag (VecReadByteArrayOp WordVec 8 W64) = 881 primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 882 primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 883 primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 884 primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 885 primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 886 primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 887 primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 888 primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 889 primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 890 primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 891 primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 892 primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 893 primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 894 primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 895 primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 896 primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 897 primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 898 primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 899 primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 900 primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 901 primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 902 primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 903 primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 904 primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 905 primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 906 primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 907 primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 908 primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 909 primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 910 primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 911 primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 912 primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 913 primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 914 primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 915 primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 916 primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 917 primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 918 primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 919 primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 920 primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 921 primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 922 primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 923 primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 924 primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 925 primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 926 primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 927 primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 928 primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 929 primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 930 primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 931 primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 932 primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 933 primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 934 primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 935 primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 936 primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 937 primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 938 primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 939 primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 940 primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 941 primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 942 primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 943 primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 944 primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 945 primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 946 primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 947 primOpTag (VecReadOffAddrOp IntVec 16 W8) = 948 primOpTag (VecReadOffAddrOp IntVec 8 W16) = 949 primOpTag (VecReadOffAddrOp IntVec 4 W32) = 950 primOpTag (VecReadOffAddrOp IntVec 2 W64) = 951 primOpTag (VecReadOffAddrOp IntVec 32 W8) = 952 primOpTag (VecReadOffAddrOp IntVec 16 W16) = 953 primOpTag (VecReadOffAddrOp IntVec 8 W32) = 954 primOpTag (VecReadOffAddrOp IntVec 4 W64) = 955 primOpTag (VecReadOffAddrOp IntVec 64 W8) = 956 primOpTag (VecReadOffAddrOp IntVec 32 W16) = 957 primOpTag (VecReadOffAddrOp IntVec 16 W32) = 958 primOpTag (VecReadOffAddrOp IntVec 8 W64) = 959 primOpTag (VecReadOffAddrOp WordVec 16 W8) = 960 primOpTag (VecReadOffAddrOp WordVec 8 W16) = 961 primOpTag (VecReadOffAddrOp WordVec 4 W32) = 962 primOpTag (VecReadOffAddrOp WordVec 2 W64) = 963 primOpTag (VecReadOffAddrOp WordVec 32 W8) = 964 primOpTag (VecReadOffAddrOp WordVec 16 W16) = 965 primOpTag (VecReadOffAddrOp WordVec 8 W32) = 966 primOpTag (VecReadOffAddrOp WordVec 4 W64) = 967 primOpTag (VecReadOffAddrOp WordVec 64 W8) = 968 primOpTag (VecReadOffAddrOp WordVec 32 W16) = 969 primOpTag (VecReadOffAddrOp WordVec 16 W32) = 970 primOpTag (VecReadOffAddrOp WordVec 8 W64) = 971 primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 972 primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 973 primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 974 primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 975 primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 976 primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 977 primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 978 primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 979 primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 980 primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 981 primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 982 primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 983 primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 984 primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 985 primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 986 primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 987 primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 988 primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 989 primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 990 primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 991 primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 992 primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 993 primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 994 primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 995 primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 996 primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 997 primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 998 primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 999 primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1000 primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1001 primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1002 primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1003 primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1004 primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1005 primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1006 primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1007 primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1008 primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1009 primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1010 primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1011 primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1012 primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1013 primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1014 primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1015 primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1016 primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1017 primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1018 primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1019 primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1020 primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1021 primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1022 primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1023 primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1024 primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1025 primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1026 primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1027 primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1028 primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1029 primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1030 primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1031 primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1032 primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1033 primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1034 primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1035 primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1036 primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1037 primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1038 primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1039 primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1040 primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1041 primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1042 primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1043 primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1044 primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1045 primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1046 primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1047 primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1048 primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1049 primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1050 primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1051 primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1052 primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1053 primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1054 primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1055 primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1056 primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1057 primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1058 primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1059 primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1060 primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1061 primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1062 primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1063 primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1064 primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1065 primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1066 primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1067 primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1068 primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1069 primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1070 primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1071 primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1072 primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1073 primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1074 primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1075 primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1076 primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1077 primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1078 primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1079 primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1080 primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1081 primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1082 primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1083 primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1084 primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1085 primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1086 primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1087 primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1088 primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1089 primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1090 primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1091 primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1092 primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1093 primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1094 primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1095 primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1096 primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1097 primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1098 primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1099 primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1100 primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1101 primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1102 primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1103 primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1104 primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1105 primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1106 primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1107 primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1108 primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1109 primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1110 primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1111 primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1112 primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1113 primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1114 primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1115 primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1116 primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1117 primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1118 primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1119 primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1120 primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1121 primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1122 primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1123 primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1124 primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1125 primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1126 primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1127 primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1128 primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1129 primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1130 primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1131 primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1132 primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1133 primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1134 primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1135 primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1136 primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1137 primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1138 primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1139 primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1140 primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1141 primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1142 primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1143 primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1144 primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1145 primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1146 primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1147 primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1148 primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1149 primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1150 primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1151 primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1152 primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1153 primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1154 primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1155 primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1156 primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1157 primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1158 primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1159 primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1160 primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1161 primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1162 primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1163 primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1164 primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1165 primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1166 primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1167 primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1168 primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1169 primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1170 primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1171 primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1172 primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1173 primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1174 primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1175 primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1176 primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1177 primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1178 primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1179 primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1180 primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1181 primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1182 primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1183 primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1184 primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1185 primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1186 primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1187 primOpTag PrefetchByteArrayOp3 = 1188 primOpTag PrefetchMutableByteArrayOp3 = 1189 primOpTag PrefetchAddrOp3 = 1190 primOpTag PrefetchValueOp3 = 1191 primOpTag PrefetchByteArrayOp2 = 1192 primOpTag PrefetchMutableByteArrayOp2 = 1193 primOpTag PrefetchAddrOp2 = 1194 primOpTag PrefetchValueOp2 = 1195 primOpTag PrefetchByteArrayOp1 = 1196 primOpTag PrefetchMutableByteArrayOp1 = 1197 primOpTag PrefetchAddrOp1 = 1198 primOpTag PrefetchValueOp1 = 1199 primOpTag PrefetchByteArrayOp0 = 1200 primOpTag PrefetchMutableByteArrayOp0 = 1201 primOpTag PrefetchAddrOp0 = 1202 primOpTag PrefetchValueOp0 = 1203 ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/primop-vector-tycons.hs-incl0000644000000000000000000000131013713636035026476 0ustar0000000000000000 , int8X16PrimTyCon , int16X8PrimTyCon , int32X4PrimTyCon , int64X2PrimTyCon , int8X32PrimTyCon , int16X16PrimTyCon , int32X8PrimTyCon , int64X4PrimTyCon , int8X64PrimTyCon , int16X32PrimTyCon , int32X16PrimTyCon , int64X8PrimTyCon , word8X16PrimTyCon , word16X8PrimTyCon , word32X4PrimTyCon , word64X2PrimTyCon , word8X32PrimTyCon , word16X16PrimTyCon , word32X8PrimTyCon , word64X4PrimTyCon , word8X64PrimTyCon , word16X32PrimTyCon , word32X16PrimTyCon , word64X8PrimTyCon , floatX4PrimTyCon , doubleX2PrimTyCon , floatX8PrimTyCon , doubleX4PrimTyCon , floatX16PrimTyCon , doubleX8PrimTyCon ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/primop-vector-tys-exports.hs-incl0000644000000000000000000000237213713636035027511 0ustar0000000000000000 int8X16PrimTy, int8X16PrimTyCon, int16X8PrimTy, int16X8PrimTyCon, int32X4PrimTy, int32X4PrimTyCon, int64X2PrimTy, int64X2PrimTyCon, int8X32PrimTy, int8X32PrimTyCon, int16X16PrimTy, int16X16PrimTyCon, int32X8PrimTy, int32X8PrimTyCon, int64X4PrimTy, int64X4PrimTyCon, int8X64PrimTy, int8X64PrimTyCon, int16X32PrimTy, int16X32PrimTyCon, int32X16PrimTy, int32X16PrimTyCon, int64X8PrimTy, int64X8PrimTyCon, word8X16PrimTy, word8X16PrimTyCon, word16X8PrimTy, word16X8PrimTyCon, word32X4PrimTy, word32X4PrimTyCon, word64X2PrimTy, word64X2PrimTyCon, word8X32PrimTy, word8X32PrimTyCon, word16X16PrimTy, word16X16PrimTyCon, word32X8PrimTy, word32X8PrimTyCon, word64X4PrimTy, word64X4PrimTyCon, word8X64PrimTy, word8X64PrimTyCon, word16X32PrimTy, word16X32PrimTyCon, word32X16PrimTy, word32X16PrimTyCon, word64X8PrimTy, word64X8PrimTyCon, floatX4PrimTy, floatX4PrimTyCon, doubleX2PrimTy, doubleX2PrimTyCon, floatX8PrimTy, floatX8PrimTyCon, doubleX4PrimTy, doubleX4PrimTyCon, floatX16PrimTy, floatX16PrimTyCon, doubleX8PrimTy, doubleX8PrimTyCon, ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl0000644000000000000000000002115613713636035026010 0ustar0000000000000000int8X16PrimTyConName :: Name int8X16PrimTyConName = mkPrimTc (fsLit "Int8X16#") int8X16PrimTyConKey int8X16PrimTyCon int8X16PrimTy :: Type int8X16PrimTy = mkTyConTy int8X16PrimTyCon int8X16PrimTyCon :: TyCon int8X16PrimTyCon = pcPrimTyCon0 int8X16PrimTyConName (VecRep 16 Int8ElemRep) int16X8PrimTyConName :: Name int16X8PrimTyConName = mkPrimTc (fsLit "Int16X8#") int16X8PrimTyConKey int16X8PrimTyCon int16X8PrimTy :: Type int16X8PrimTy = mkTyConTy int16X8PrimTyCon int16X8PrimTyCon :: TyCon int16X8PrimTyCon = pcPrimTyCon0 int16X8PrimTyConName (VecRep 8 Int16ElemRep) int32X4PrimTyConName :: Name int32X4PrimTyConName = mkPrimTc (fsLit "Int32X4#") int32X4PrimTyConKey int32X4PrimTyCon int32X4PrimTy :: Type int32X4PrimTy = mkTyConTy int32X4PrimTyCon int32X4PrimTyCon :: TyCon int32X4PrimTyCon = pcPrimTyCon0 int32X4PrimTyConName (VecRep 4 Int32ElemRep) int64X2PrimTyConName :: Name int64X2PrimTyConName = mkPrimTc (fsLit "Int64X2#") int64X2PrimTyConKey int64X2PrimTyCon int64X2PrimTy :: Type int64X2PrimTy = mkTyConTy int64X2PrimTyCon int64X2PrimTyCon :: TyCon int64X2PrimTyCon = pcPrimTyCon0 int64X2PrimTyConName (VecRep 2 Int64ElemRep) int8X32PrimTyConName :: Name int8X32PrimTyConName = mkPrimTc (fsLit "Int8X32#") int8X32PrimTyConKey int8X32PrimTyCon int8X32PrimTy :: Type int8X32PrimTy = mkTyConTy int8X32PrimTyCon int8X32PrimTyCon :: TyCon int8X32PrimTyCon = pcPrimTyCon0 int8X32PrimTyConName (VecRep 32 Int8ElemRep) int16X16PrimTyConName :: Name int16X16PrimTyConName = mkPrimTc (fsLit "Int16X16#") int16X16PrimTyConKey int16X16PrimTyCon int16X16PrimTy :: Type int16X16PrimTy = mkTyConTy int16X16PrimTyCon int16X16PrimTyCon :: TyCon int16X16PrimTyCon = pcPrimTyCon0 int16X16PrimTyConName (VecRep 16 Int16ElemRep) int32X8PrimTyConName :: Name int32X8PrimTyConName = mkPrimTc (fsLit "Int32X8#") int32X8PrimTyConKey int32X8PrimTyCon int32X8PrimTy :: Type int32X8PrimTy = mkTyConTy int32X8PrimTyCon int32X8PrimTyCon :: TyCon int32X8PrimTyCon = pcPrimTyCon0 int32X8PrimTyConName (VecRep 8 Int32ElemRep) int64X4PrimTyConName :: Name int64X4PrimTyConName = mkPrimTc (fsLit "Int64X4#") int64X4PrimTyConKey int64X4PrimTyCon int64X4PrimTy :: Type int64X4PrimTy = mkTyConTy int64X4PrimTyCon int64X4PrimTyCon :: TyCon int64X4PrimTyCon = pcPrimTyCon0 int64X4PrimTyConName (VecRep 4 Int64ElemRep) int8X64PrimTyConName :: Name int8X64PrimTyConName = mkPrimTc (fsLit "Int8X64#") int8X64PrimTyConKey int8X64PrimTyCon int8X64PrimTy :: Type int8X64PrimTy = mkTyConTy int8X64PrimTyCon int8X64PrimTyCon :: TyCon int8X64PrimTyCon = pcPrimTyCon0 int8X64PrimTyConName (VecRep 64 Int8ElemRep) int16X32PrimTyConName :: Name int16X32PrimTyConName = mkPrimTc (fsLit "Int16X32#") int16X32PrimTyConKey int16X32PrimTyCon int16X32PrimTy :: Type int16X32PrimTy = mkTyConTy int16X32PrimTyCon int16X32PrimTyCon :: TyCon int16X32PrimTyCon = pcPrimTyCon0 int16X32PrimTyConName (VecRep 32 Int16ElemRep) int32X16PrimTyConName :: Name int32X16PrimTyConName = mkPrimTc (fsLit "Int32X16#") int32X16PrimTyConKey int32X16PrimTyCon int32X16PrimTy :: Type int32X16PrimTy = mkTyConTy int32X16PrimTyCon int32X16PrimTyCon :: TyCon int32X16PrimTyCon = pcPrimTyCon0 int32X16PrimTyConName (VecRep 16 Int32ElemRep) int64X8PrimTyConName :: Name int64X8PrimTyConName = mkPrimTc (fsLit "Int64X8#") int64X8PrimTyConKey int64X8PrimTyCon int64X8PrimTy :: Type int64X8PrimTy = mkTyConTy int64X8PrimTyCon int64X8PrimTyCon :: TyCon int64X8PrimTyCon = pcPrimTyCon0 int64X8PrimTyConName (VecRep 8 Int64ElemRep) word8X16PrimTyConName :: Name word8X16PrimTyConName = mkPrimTc (fsLit "Word8X16#") word8X16PrimTyConKey word8X16PrimTyCon word8X16PrimTy :: Type word8X16PrimTy = mkTyConTy word8X16PrimTyCon word8X16PrimTyCon :: TyCon word8X16PrimTyCon = pcPrimTyCon0 word8X16PrimTyConName (VecRep 16 Word8ElemRep) word16X8PrimTyConName :: Name word16X8PrimTyConName = mkPrimTc (fsLit "Word16X8#") word16X8PrimTyConKey word16X8PrimTyCon word16X8PrimTy :: Type word16X8PrimTy = mkTyConTy word16X8PrimTyCon word16X8PrimTyCon :: TyCon word16X8PrimTyCon = pcPrimTyCon0 word16X8PrimTyConName (VecRep 8 Word16ElemRep) word32X4PrimTyConName :: Name word32X4PrimTyConName = mkPrimTc (fsLit "Word32X4#") word32X4PrimTyConKey word32X4PrimTyCon word32X4PrimTy :: Type word32X4PrimTy = mkTyConTy word32X4PrimTyCon word32X4PrimTyCon :: TyCon word32X4PrimTyCon = pcPrimTyCon0 word32X4PrimTyConName (VecRep 4 Word32ElemRep) word64X2PrimTyConName :: Name word64X2PrimTyConName = mkPrimTc (fsLit "Word64X2#") word64X2PrimTyConKey word64X2PrimTyCon word64X2PrimTy :: Type word64X2PrimTy = mkTyConTy word64X2PrimTyCon word64X2PrimTyCon :: TyCon word64X2PrimTyCon = pcPrimTyCon0 word64X2PrimTyConName (VecRep 2 Word64ElemRep) word8X32PrimTyConName :: Name word8X32PrimTyConName = mkPrimTc (fsLit "Word8X32#") word8X32PrimTyConKey word8X32PrimTyCon word8X32PrimTy :: Type word8X32PrimTy = mkTyConTy word8X32PrimTyCon word8X32PrimTyCon :: TyCon word8X32PrimTyCon = pcPrimTyCon0 word8X32PrimTyConName (VecRep 32 Word8ElemRep) word16X16PrimTyConName :: Name word16X16PrimTyConName = mkPrimTc (fsLit "Word16X16#") word16X16PrimTyConKey word16X16PrimTyCon word16X16PrimTy :: Type word16X16PrimTy = mkTyConTy word16X16PrimTyCon word16X16PrimTyCon :: TyCon word16X16PrimTyCon = pcPrimTyCon0 word16X16PrimTyConName (VecRep 16 Word16ElemRep) word32X8PrimTyConName :: Name word32X8PrimTyConName = mkPrimTc (fsLit "Word32X8#") word32X8PrimTyConKey word32X8PrimTyCon word32X8PrimTy :: Type word32X8PrimTy = mkTyConTy word32X8PrimTyCon word32X8PrimTyCon :: TyCon word32X8PrimTyCon = pcPrimTyCon0 word32X8PrimTyConName (VecRep 8 Word32ElemRep) word64X4PrimTyConName :: Name word64X4PrimTyConName = mkPrimTc (fsLit "Word64X4#") word64X4PrimTyConKey word64X4PrimTyCon word64X4PrimTy :: Type word64X4PrimTy = mkTyConTy word64X4PrimTyCon word64X4PrimTyCon :: TyCon word64X4PrimTyCon = pcPrimTyCon0 word64X4PrimTyConName (VecRep 4 Word64ElemRep) word8X64PrimTyConName :: Name word8X64PrimTyConName = mkPrimTc (fsLit "Word8X64#") word8X64PrimTyConKey word8X64PrimTyCon word8X64PrimTy :: Type word8X64PrimTy = mkTyConTy word8X64PrimTyCon word8X64PrimTyCon :: TyCon word8X64PrimTyCon = pcPrimTyCon0 word8X64PrimTyConName (VecRep 64 Word8ElemRep) word16X32PrimTyConName :: Name word16X32PrimTyConName = mkPrimTc (fsLit "Word16X32#") word16X32PrimTyConKey word16X32PrimTyCon word16X32PrimTy :: Type word16X32PrimTy = mkTyConTy word16X32PrimTyCon word16X32PrimTyCon :: TyCon word16X32PrimTyCon = pcPrimTyCon0 word16X32PrimTyConName (VecRep 32 Word16ElemRep) word32X16PrimTyConName :: Name word32X16PrimTyConName = mkPrimTc (fsLit "Word32X16#") word32X16PrimTyConKey word32X16PrimTyCon word32X16PrimTy :: Type word32X16PrimTy = mkTyConTy word32X16PrimTyCon word32X16PrimTyCon :: TyCon word32X16PrimTyCon = pcPrimTyCon0 word32X16PrimTyConName (VecRep 16 Word32ElemRep) word64X8PrimTyConName :: Name word64X8PrimTyConName = mkPrimTc (fsLit "Word64X8#") word64X8PrimTyConKey word64X8PrimTyCon word64X8PrimTy :: Type word64X8PrimTy = mkTyConTy word64X8PrimTyCon word64X8PrimTyCon :: TyCon word64X8PrimTyCon = pcPrimTyCon0 word64X8PrimTyConName (VecRep 8 Word64ElemRep) floatX4PrimTyConName :: Name floatX4PrimTyConName = mkPrimTc (fsLit "FloatX4#") floatX4PrimTyConKey floatX4PrimTyCon floatX4PrimTy :: Type floatX4PrimTy = mkTyConTy floatX4PrimTyCon floatX4PrimTyCon :: TyCon floatX4PrimTyCon = pcPrimTyCon0 floatX4PrimTyConName (VecRep 4 FloatElemRep) doubleX2PrimTyConName :: Name doubleX2PrimTyConName = mkPrimTc (fsLit "DoubleX2#") doubleX2PrimTyConKey doubleX2PrimTyCon doubleX2PrimTy :: Type doubleX2PrimTy = mkTyConTy doubleX2PrimTyCon doubleX2PrimTyCon :: TyCon doubleX2PrimTyCon = pcPrimTyCon0 doubleX2PrimTyConName (VecRep 2 DoubleElemRep) floatX8PrimTyConName :: Name floatX8PrimTyConName = mkPrimTc (fsLit "FloatX8#") floatX8PrimTyConKey floatX8PrimTyCon floatX8PrimTy :: Type floatX8PrimTy = mkTyConTy floatX8PrimTyCon floatX8PrimTyCon :: TyCon floatX8PrimTyCon = pcPrimTyCon0 floatX8PrimTyConName (VecRep 8 FloatElemRep) doubleX4PrimTyConName :: Name doubleX4PrimTyConName = mkPrimTc (fsLit "DoubleX4#") doubleX4PrimTyConKey doubleX4PrimTyCon doubleX4PrimTy :: Type doubleX4PrimTy = mkTyConTy doubleX4PrimTyCon doubleX4PrimTyCon :: TyCon doubleX4PrimTyCon = pcPrimTyCon0 doubleX4PrimTyConName (VecRep 4 DoubleElemRep) floatX16PrimTyConName :: Name floatX16PrimTyConName = mkPrimTc (fsLit "FloatX16#") floatX16PrimTyConKey floatX16PrimTyCon floatX16PrimTy :: Type floatX16PrimTy = mkTyConTy floatX16PrimTyCon floatX16PrimTyCon :: TyCon floatX16PrimTyCon = pcPrimTyCon0 floatX16PrimTyConName (VecRep 16 FloatElemRep) doubleX8PrimTyConName :: Name doubleX8PrimTyConName = mkPrimTc (fsLit "DoubleX8#") doubleX8PrimTyConKey doubleX8PrimTyCon doubleX8PrimTy :: Type doubleX8PrimTy = mkTyConTy doubleX8PrimTyCon doubleX8PrimTyCon :: TyCon doubleX8PrimTyCon = pcPrimTyCon0 doubleX8PrimTyConName (VecRep 8 DoubleElemRep) ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl0000644000000000000000000000446213713636035026663 0ustar0000000000000000int8X16PrimTyConKey :: Unique int8X16PrimTyConKey = mkPreludeTyConUnique 300 int16X8PrimTyConKey :: Unique int16X8PrimTyConKey = mkPreludeTyConUnique 301 int32X4PrimTyConKey :: Unique int32X4PrimTyConKey = mkPreludeTyConUnique 302 int64X2PrimTyConKey :: Unique int64X2PrimTyConKey = mkPreludeTyConUnique 303 int8X32PrimTyConKey :: Unique int8X32PrimTyConKey = mkPreludeTyConUnique 304 int16X16PrimTyConKey :: Unique int16X16PrimTyConKey = mkPreludeTyConUnique 305 int32X8PrimTyConKey :: Unique int32X8PrimTyConKey = mkPreludeTyConUnique 306 int64X4PrimTyConKey :: Unique int64X4PrimTyConKey = mkPreludeTyConUnique 307 int8X64PrimTyConKey :: Unique int8X64PrimTyConKey = mkPreludeTyConUnique 308 int16X32PrimTyConKey :: Unique int16X32PrimTyConKey = mkPreludeTyConUnique 309 int32X16PrimTyConKey :: Unique int32X16PrimTyConKey = mkPreludeTyConUnique 310 int64X8PrimTyConKey :: Unique int64X8PrimTyConKey = mkPreludeTyConUnique 311 word8X16PrimTyConKey :: Unique word8X16PrimTyConKey = mkPreludeTyConUnique 312 word16X8PrimTyConKey :: Unique word16X8PrimTyConKey = mkPreludeTyConUnique 313 word32X4PrimTyConKey :: Unique word32X4PrimTyConKey = mkPreludeTyConUnique 314 word64X2PrimTyConKey :: Unique word64X2PrimTyConKey = mkPreludeTyConUnique 315 word8X32PrimTyConKey :: Unique word8X32PrimTyConKey = mkPreludeTyConUnique 316 word16X16PrimTyConKey :: Unique word16X16PrimTyConKey = mkPreludeTyConUnique 317 word32X8PrimTyConKey :: Unique word32X8PrimTyConKey = mkPreludeTyConUnique 318 word64X4PrimTyConKey :: Unique word64X4PrimTyConKey = mkPreludeTyConUnique 319 word8X64PrimTyConKey :: Unique word8X64PrimTyConKey = mkPreludeTyConUnique 320 word16X32PrimTyConKey :: Unique word16X32PrimTyConKey = mkPreludeTyConUnique 321 word32X16PrimTyConKey :: Unique word32X16PrimTyConKey = mkPreludeTyConUnique 322 word64X8PrimTyConKey :: Unique word64X8PrimTyConKey = mkPreludeTyConUnique 323 floatX4PrimTyConKey :: Unique floatX4PrimTyConKey = mkPreludeTyConUnique 324 doubleX2PrimTyConKey :: Unique doubleX2PrimTyConKey = mkPreludeTyConUnique 325 floatX8PrimTyConKey :: Unique floatX8PrimTyConKey = mkPreludeTyConUnique 326 doubleX4PrimTyConKey :: Unique doubleX4PrimTyConKey = mkPreludeTyConUnique 327 floatX16PrimTyConKey :: Unique floatX16PrimTyConKey = mkPreludeTyConUnique 328 doubleX8PrimTyConKey :: Unique doubleX8PrimTyConKey = mkPreludeTyConUnique 329 ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/Parser.hs0000644000000000000000000523117113713636246022707 0ustar0000000000000000{-# OPTIONS_GHC -w #-} {-# OPTIONS -XMagicHash -XBangPatterns -XTypeSynonymInstances -XFlexibleInstances -cpp #-} #if __GLASGOW_HASKELL__ >= 710 {-# OPTIONS_GHC -XPartialTypeSignatures #-} #endif {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -- | This module provides the generated Happy parser for Haskell. It exports -- a number of parsers which may be used in any library that uses the GHC API. -- A common usage pattern is to initialize the parser state with a given string -- and then parse that string: -- -- @ -- runParser :: DynFlags -> String -> P a -> ParseResult a -- runParser flags str parser = unP parser parseState -- where -- filename = "\" -- location = mkRealSrcLoc (mkFastString filename) 1 1 -- buffer = stringToStringBuffer str -- parseState = mkPState flags buffer location -- @ module Parser (parseModule, parseSignature, parseImport, parseStatement, parseBackpack, parseDeclaration, parseExpression, parsePattern, parseTypeSignature, parseStmt, parseIdentifier, parseType, parseHeader) where -- base import Control.Monad ( unless, liftM, when, (<=<) ) import GHC.Exts import Data.Char import Data.Maybe ( maybeToList ) import Control.Monad ( mplus ) import Control.Applicative ((<$)) import qualified Prelude -- compiler/hsSyn import GHC.Hs -- compiler/main import DriverPhases ( HscSource(..) ) import HscTypes ( IsBootInterface, WarningTxt(..) ) import DynFlags import BkpSyn import PackageConfig -- compiler/utils import OrdList import BooleanFormula ( BooleanFormula(..), LBooleanFormula(..), mkTrue ) import FastString import Maybes ( isJust, orElse ) import Outputable -- compiler/basicTypes import RdrName import OccName ( varName, dataName, tcClsName, tvName, startsWithUnderscore ) import DataCon ( DataCon, dataConName ) import SrcLoc import Module import BasicTypes -- compiler/types import Type ( funTyCon ) import Class ( FunDep ) -- compiler/parser import RdrHsSyn import Lexer import HaddockUtils import ApiAnnotation -- compiler/typecheck import TcEvidence ( emptyTcEvBinds ) -- compiler/prelude import ForeignCall import TysPrim ( eqPrimTyCon ) import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, unboxedUnitTyCon, unboxedUnitDataCon, listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) -- compiler/utils import Util ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) import GhcPrelude import qualified Data.Array as Happy_Data_Array import qualified Data.Bits as Bits import qualified GHC.Exts as Happy_GHC_Exts import Control.Applicative(Applicative(..)) import Control.Monad (ap) -- parser produced by Happy Version 1.19.12 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 type HappyAny = Happy_GHC_Exts.Any #else type HappyAny = forall a . a #endif newtype HappyWrap16 = HappyWrap16 (Located RdrName) happyIn16 :: (Located RdrName) -> (HappyAbsSyn ) happyIn16 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap16 x) {-# INLINE happyIn16 #-} happyOut16 :: (HappyAbsSyn ) -> HappyWrap16 happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut16 #-} newtype HappyWrap17 = HappyWrap17 ([LHsUnit PackageName]) happyIn17 :: ([LHsUnit PackageName]) -> (HappyAbsSyn ) happyIn17 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap17 x) {-# INLINE happyIn17 #-} happyOut17 :: (HappyAbsSyn ) -> HappyWrap17 happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut17 #-} newtype HappyWrap18 = HappyWrap18 (OrdList (LHsUnit PackageName)) happyIn18 :: (OrdList (LHsUnit PackageName)) -> (HappyAbsSyn ) happyIn18 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap18 x) {-# INLINE happyIn18 #-} happyOut18 :: (HappyAbsSyn ) -> HappyWrap18 happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut18 #-} newtype HappyWrap19 = HappyWrap19 (LHsUnit PackageName) happyIn19 :: (LHsUnit PackageName) -> (HappyAbsSyn ) happyIn19 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap19 x) {-# INLINE happyIn19 #-} happyOut19 :: (HappyAbsSyn ) -> HappyWrap19 happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut19 #-} newtype HappyWrap20 = HappyWrap20 (LHsUnitId PackageName) happyIn20 :: (LHsUnitId PackageName) -> (HappyAbsSyn ) happyIn20 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap20 x) {-# INLINE happyIn20 #-} happyOut20 :: (HappyAbsSyn ) -> HappyWrap20 happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut20 #-} newtype HappyWrap21 = HappyWrap21 (OrdList (LHsModuleSubst PackageName)) happyIn21 :: (OrdList (LHsModuleSubst PackageName)) -> (HappyAbsSyn ) happyIn21 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap21 x) {-# INLINE happyIn21 #-} happyOut21 :: (HappyAbsSyn ) -> HappyWrap21 happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut21 #-} newtype HappyWrap22 = HappyWrap22 (LHsModuleSubst PackageName) happyIn22 :: (LHsModuleSubst PackageName) -> (HappyAbsSyn ) happyIn22 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap22 x) {-# INLINE happyIn22 #-} happyOut22 :: (HappyAbsSyn ) -> HappyWrap22 happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut22 #-} newtype HappyWrap23 = HappyWrap23 (LHsModuleId PackageName) happyIn23 :: (LHsModuleId PackageName) -> (HappyAbsSyn ) happyIn23 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap23 x) {-# INLINE happyIn23 #-} happyOut23 :: (HappyAbsSyn ) -> HappyWrap23 happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut23 #-} newtype HappyWrap24 = HappyWrap24 (Located PackageName) happyIn24 :: (Located PackageName) -> (HappyAbsSyn ) happyIn24 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap24 x) {-# INLINE happyIn24 #-} happyOut24 :: (HappyAbsSyn ) -> HappyWrap24 happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut24 #-} newtype HappyWrap25 = HappyWrap25 (Located FastString) happyIn25 :: (Located FastString) -> (HappyAbsSyn ) happyIn25 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap25 x) {-# INLINE happyIn25 #-} happyOut25 :: (HappyAbsSyn ) -> HappyWrap25 happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut25 #-} newtype HappyWrap26 = HappyWrap26 (Located FastString) happyIn26 :: (Located FastString) -> (HappyAbsSyn ) happyIn26 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap26 x) {-# INLINE happyIn26 #-} happyOut26 :: (HappyAbsSyn ) -> HappyWrap26 happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut26 #-} newtype HappyWrap27 = HappyWrap27 (Maybe [LRenaming]) happyIn27 :: (Maybe [LRenaming]) -> (HappyAbsSyn ) happyIn27 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap27 x) {-# INLINE happyIn27 #-} happyOut27 :: (HappyAbsSyn ) -> HappyWrap27 happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut27 #-} newtype HappyWrap28 = HappyWrap28 (OrdList LRenaming) happyIn28 :: (OrdList LRenaming) -> (HappyAbsSyn ) happyIn28 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap28 x) {-# INLINE happyIn28 #-} happyOut28 :: (HappyAbsSyn ) -> HappyWrap28 happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut28 #-} newtype HappyWrap29 = HappyWrap29 (LRenaming) happyIn29 :: (LRenaming) -> (HappyAbsSyn ) happyIn29 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap29 x) {-# INLINE happyIn29 #-} happyOut29 :: (HappyAbsSyn ) -> HappyWrap29 happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut29 #-} newtype HappyWrap30 = HappyWrap30 (OrdList (LHsUnitDecl PackageName)) happyIn30 :: (OrdList (LHsUnitDecl PackageName)) -> (HappyAbsSyn ) happyIn30 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap30 x) {-# INLINE happyIn30 #-} happyOut30 :: (HappyAbsSyn ) -> HappyWrap30 happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut30 #-} newtype HappyWrap31 = HappyWrap31 (OrdList (LHsUnitDecl PackageName)) happyIn31 :: (OrdList (LHsUnitDecl PackageName)) -> (HappyAbsSyn ) happyIn31 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap31 x) {-# INLINE happyIn31 #-} happyOut31 :: (HappyAbsSyn ) -> HappyWrap31 happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut31 #-} newtype HappyWrap32 = HappyWrap32 (LHsUnitDecl PackageName) happyIn32 :: (LHsUnitDecl PackageName) -> (HappyAbsSyn ) happyIn32 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap32 x) {-# INLINE happyIn32 #-} happyOut32 :: (HappyAbsSyn ) -> HappyWrap32 happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut32 #-} newtype HappyWrap33 = HappyWrap33 (Located (HsModule GhcPs)) happyIn33 :: (Located (HsModule GhcPs)) -> (HappyAbsSyn ) happyIn33 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap33 x) {-# INLINE happyIn33 #-} happyOut33 :: (HappyAbsSyn ) -> HappyWrap33 happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut33 #-} newtype HappyWrap34 = HappyWrap34 (Located (HsModule GhcPs)) happyIn34 :: (Located (HsModule GhcPs)) -> (HappyAbsSyn ) happyIn34 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap34 x) {-# INLINE happyIn34 #-} happyOut34 :: (HappyAbsSyn ) -> HappyWrap34 happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut34 #-} newtype HappyWrap35 = HappyWrap35 (Maybe LHsDocString) happyIn35 :: (Maybe LHsDocString) -> (HappyAbsSyn ) happyIn35 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap35 x) {-# INLINE happyIn35 #-} happyOut35 :: (HappyAbsSyn ) -> HappyWrap35 happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut35 #-} newtype HappyWrap36 = HappyWrap36 (()) happyIn36 :: (()) -> (HappyAbsSyn ) happyIn36 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap36 x) {-# INLINE happyIn36 #-} happyOut36 :: (HappyAbsSyn ) -> HappyWrap36 happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut36 #-} newtype HappyWrap37 = HappyWrap37 (()) happyIn37 :: (()) -> (HappyAbsSyn ) happyIn37 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap37 x) {-# INLINE happyIn37 #-} happyOut37 :: (HappyAbsSyn ) -> HappyWrap37 happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut37 #-} newtype HappyWrap38 = HappyWrap38 (Maybe (Located WarningTxt)) happyIn38 :: (Maybe (Located WarningTxt)) -> (HappyAbsSyn ) happyIn38 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap38 x) {-# INLINE happyIn38 #-} happyOut38 :: (HappyAbsSyn ) -> HappyWrap38 happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut38 #-} newtype HappyWrap39 = HappyWrap39 (([AddAnn] ,([LImportDecl GhcPs], [LHsDecl GhcPs]))) happyIn39 :: (([AddAnn] ,([LImportDecl GhcPs], [LHsDecl GhcPs]))) -> (HappyAbsSyn ) happyIn39 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap39 x) {-# INLINE happyIn39 #-} happyOut39 :: (HappyAbsSyn ) -> HappyWrap39 happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut39 #-} newtype HappyWrap40 = HappyWrap40 (([AddAnn] ,([LImportDecl GhcPs], [LHsDecl GhcPs]))) happyIn40 :: (([AddAnn] ,([LImportDecl GhcPs], [LHsDecl GhcPs]))) -> (HappyAbsSyn ) happyIn40 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap40 x) {-# INLINE happyIn40 #-} happyOut40 :: (HappyAbsSyn ) -> HappyWrap40 happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut40 #-} newtype HappyWrap41 = HappyWrap41 (([AddAnn] ,([LImportDecl GhcPs], [LHsDecl GhcPs]))) happyIn41 :: (([AddAnn] ,([LImportDecl GhcPs], [LHsDecl GhcPs]))) -> (HappyAbsSyn ) happyIn41 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap41 x) {-# INLINE happyIn41 #-} happyOut41 :: (HappyAbsSyn ) -> HappyWrap41 happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut41 #-} newtype HappyWrap42 = HappyWrap42 (([LImportDecl GhcPs], [LHsDecl GhcPs])) happyIn42 :: (([LImportDecl GhcPs], [LHsDecl GhcPs])) -> (HappyAbsSyn ) happyIn42 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap42 x) {-# INLINE happyIn42 #-} happyOut42 :: (HappyAbsSyn ) -> HappyWrap42 happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut42 #-} newtype HappyWrap43 = HappyWrap43 (Located (HsModule GhcPs)) happyIn43 :: (Located (HsModule GhcPs)) -> (HappyAbsSyn ) happyIn43 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap43 x) {-# INLINE happyIn43 #-} happyOut43 :: (HappyAbsSyn ) -> HappyWrap43 happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut43 #-} newtype HappyWrap44 = HappyWrap44 ([LImportDecl GhcPs]) happyIn44 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) happyIn44 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap44 x) {-# INLINE happyIn44 #-} happyOut44 :: (HappyAbsSyn ) -> HappyWrap44 happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut44 #-} newtype HappyWrap45 = HappyWrap45 ([LImportDecl GhcPs]) happyIn45 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) happyIn45 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap45 x) {-# INLINE happyIn45 #-} happyOut45 :: (HappyAbsSyn ) -> HappyWrap45 happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut45 #-} newtype HappyWrap46 = HappyWrap46 ([LImportDecl GhcPs]) happyIn46 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) happyIn46 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap46 x) {-# INLINE happyIn46 #-} happyOut46 :: (HappyAbsSyn ) -> HappyWrap46 happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut46 #-} newtype HappyWrap47 = HappyWrap47 ([LImportDecl GhcPs]) happyIn47 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) happyIn47 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap47 x) {-# INLINE happyIn47 #-} happyOut47 :: (HappyAbsSyn ) -> HappyWrap47 happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut47 #-} newtype HappyWrap48 = HappyWrap48 ((Maybe (Located [LIE GhcPs]))) happyIn48 :: ((Maybe (Located [LIE GhcPs]))) -> (HappyAbsSyn ) happyIn48 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap48 x) {-# INLINE happyIn48 #-} happyOut48 :: (HappyAbsSyn ) -> HappyWrap48 happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut48 #-} newtype HappyWrap49 = HappyWrap49 (OrdList (LIE GhcPs)) happyIn49 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) happyIn49 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap49 x) {-# INLINE happyIn49 #-} happyOut49 :: (HappyAbsSyn ) -> HappyWrap49 happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut49 #-} newtype HappyWrap50 = HappyWrap50 (OrdList (LIE GhcPs)) happyIn50 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) happyIn50 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap50 x) {-# INLINE happyIn50 #-} happyOut50 :: (HappyAbsSyn ) -> HappyWrap50 happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut50 #-} newtype HappyWrap51 = HappyWrap51 (OrdList (LIE GhcPs)) happyIn51 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) happyIn51 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap51 x) {-# INLINE happyIn51 #-} happyOut51 :: (HappyAbsSyn ) -> HappyWrap51 happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut51 #-} newtype HappyWrap52 = HappyWrap52 (OrdList (LIE GhcPs)) happyIn52 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) happyIn52 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap52 x) {-# INLINE happyIn52 #-} happyOut52 :: (HappyAbsSyn ) -> HappyWrap52 happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut52 #-} newtype HappyWrap53 = HappyWrap53 (OrdList (LIE GhcPs)) happyIn53 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) happyIn53 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap53 x) {-# INLINE happyIn53 #-} happyOut53 :: (HappyAbsSyn ) -> HappyWrap53 happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut53 #-} newtype HappyWrap54 = HappyWrap54 (Located ([AddAnn],ImpExpSubSpec)) happyIn54 :: (Located ([AddAnn],ImpExpSubSpec)) -> (HappyAbsSyn ) happyIn54 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap54 x) {-# INLINE happyIn54 #-} happyOut54 :: (HappyAbsSyn ) -> HappyWrap54 happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut54 #-} newtype HappyWrap55 = HappyWrap55 (([AddAnn], [Located ImpExpQcSpec])) happyIn55 :: (([AddAnn], [Located ImpExpQcSpec])) -> (HappyAbsSyn ) happyIn55 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap55 x) {-# INLINE happyIn55 #-} happyOut55 :: (HappyAbsSyn ) -> HappyWrap55 happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut55 #-} newtype HappyWrap56 = HappyWrap56 (([AddAnn], [Located ImpExpQcSpec])) happyIn56 :: (([AddAnn], [Located ImpExpQcSpec])) -> (HappyAbsSyn ) happyIn56 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap56 x) {-# INLINE happyIn56 #-} happyOut56 :: (HappyAbsSyn ) -> HappyWrap56 happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut56 #-} newtype HappyWrap57 = HappyWrap57 (Located ([AddAnn], Located ImpExpQcSpec)) happyIn57 :: (Located ([AddAnn], Located ImpExpQcSpec)) -> (HappyAbsSyn ) happyIn57 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap57 x) {-# INLINE happyIn57 #-} happyOut57 :: (HappyAbsSyn ) -> HappyWrap57 happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut57 #-} newtype HappyWrap58 = HappyWrap58 (Located ImpExpQcSpec) happyIn58 :: (Located ImpExpQcSpec) -> (HappyAbsSyn ) happyIn58 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap58 x) {-# INLINE happyIn58 #-} happyOut58 :: (HappyAbsSyn ) -> HappyWrap58 happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut58 #-} newtype HappyWrap59 = HappyWrap59 (Located RdrName) happyIn59 :: (Located RdrName) -> (HappyAbsSyn ) happyIn59 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap59 x) {-# INLINE happyIn59 #-} happyOut59 :: (HappyAbsSyn ) -> HappyWrap59 happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut59 #-} newtype HappyWrap60 = HappyWrap60 ([AddAnn]) happyIn60 :: ([AddAnn]) -> (HappyAbsSyn ) happyIn60 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap60 x) {-# INLINE happyIn60 #-} happyOut60 :: (HappyAbsSyn ) -> HappyWrap60 happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut60 #-} newtype HappyWrap61 = HappyWrap61 ([AddAnn]) happyIn61 :: ([AddAnn]) -> (HappyAbsSyn ) happyIn61 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap61 x) {-# INLINE happyIn61 #-} happyOut61 :: (HappyAbsSyn ) -> HappyWrap61 happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut61 #-} newtype HappyWrap62 = HappyWrap62 ([LImportDecl GhcPs]) happyIn62 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) happyIn62 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap62 x) {-# INLINE happyIn62 #-} happyOut62 :: (HappyAbsSyn ) -> HappyWrap62 happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut62 #-} newtype HappyWrap63 = HappyWrap63 ([LImportDecl GhcPs]) happyIn63 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) happyIn63 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap63 x) {-# INLINE happyIn63 #-} happyOut63 :: (HappyAbsSyn ) -> HappyWrap63 happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut63 #-} newtype HappyWrap64 = HappyWrap64 (LImportDecl GhcPs) happyIn64 :: (LImportDecl GhcPs) -> (HappyAbsSyn ) happyIn64 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap64 x) {-# INLINE happyIn64 #-} happyOut64 :: (HappyAbsSyn ) -> HappyWrap64 happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut64 #-} newtype HappyWrap65 = HappyWrap65 ((([AddAnn],SourceText),IsBootInterface)) happyIn65 :: ((([AddAnn],SourceText),IsBootInterface)) -> (HappyAbsSyn ) happyIn65 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap65 x) {-# INLINE happyIn65 #-} happyOut65 :: (HappyAbsSyn ) -> HappyWrap65 happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut65 #-} newtype HappyWrap66 = HappyWrap66 (([AddAnn],Bool)) happyIn66 :: (([AddAnn],Bool)) -> (HappyAbsSyn ) happyIn66 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap66 x) {-# INLINE happyIn66 #-} happyOut66 :: (HappyAbsSyn ) -> HappyWrap66 happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut66 #-} newtype HappyWrap67 = HappyWrap67 (([AddAnn],Maybe StringLiteral)) happyIn67 :: (([AddAnn],Maybe StringLiteral)) -> (HappyAbsSyn ) happyIn67 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap67 x) {-# INLINE happyIn67 #-} happyOut67 :: (HappyAbsSyn ) -> HappyWrap67 happyOut67 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut67 #-} newtype HappyWrap68 = HappyWrap68 (Maybe (Located Token)) happyIn68 :: (Maybe (Located Token)) -> (HappyAbsSyn ) happyIn68 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap68 x) {-# INLINE happyIn68 #-} happyOut68 :: (HappyAbsSyn ) -> HappyWrap68 happyOut68 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut68 #-} newtype HappyWrap69 = HappyWrap69 (([AddAnn],Located (Maybe (Located ModuleName)))) happyIn69 :: (([AddAnn],Located (Maybe (Located ModuleName)))) -> (HappyAbsSyn ) happyIn69 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap69 x) {-# INLINE happyIn69 #-} happyOut69 :: (HappyAbsSyn ) -> HappyWrap69 happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut69 #-} newtype HappyWrap70 = HappyWrap70 (Located (Maybe (Bool, Located [LIE GhcPs]))) happyIn70 :: (Located (Maybe (Bool, Located [LIE GhcPs]))) -> (HappyAbsSyn ) happyIn70 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap70 x) {-# INLINE happyIn70 #-} happyOut70 :: (HappyAbsSyn ) -> HappyWrap70 happyOut70 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut70 #-} newtype HappyWrap71 = HappyWrap71 (Located (Bool, Located [LIE GhcPs])) happyIn71 :: (Located (Bool, Located [LIE GhcPs])) -> (HappyAbsSyn ) happyIn71 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap71 x) {-# INLINE happyIn71 #-} happyOut71 :: (HappyAbsSyn ) -> HappyWrap71 happyOut71 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut71 #-} newtype HappyWrap72 = HappyWrap72 (Located (SourceText,Int)) happyIn72 :: (Located (SourceText,Int)) -> (HappyAbsSyn ) happyIn72 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap72 x) {-# INLINE happyIn72 #-} happyOut72 :: (HappyAbsSyn ) -> HappyWrap72 happyOut72 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut72 #-} newtype HappyWrap73 = HappyWrap73 (Located FixityDirection) happyIn73 :: (Located FixityDirection) -> (HappyAbsSyn ) happyIn73 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap73 x) {-# INLINE happyIn73 #-} happyOut73 :: (HappyAbsSyn ) -> HappyWrap73 happyOut73 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut73 #-} newtype HappyWrap74 = HappyWrap74 (Located (OrdList (Located RdrName))) happyIn74 :: (Located (OrdList (Located RdrName))) -> (HappyAbsSyn ) happyIn74 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap74 x) {-# INLINE happyIn74 #-} happyOut74 :: (HappyAbsSyn ) -> HappyWrap74 happyOut74 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut74 #-} newtype HappyWrap75 = HappyWrap75 (OrdList (LHsDecl GhcPs)) happyIn75 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn ) happyIn75 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap75 x) {-# INLINE happyIn75 #-} happyOut75 :: (HappyAbsSyn ) -> HappyWrap75 happyOut75 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut75 #-} newtype HappyWrap76 = HappyWrap76 (OrdList (LHsDecl GhcPs)) happyIn76 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn ) happyIn76 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap76 x) {-# INLINE happyIn76 #-} happyOut76 :: (HappyAbsSyn ) -> HappyWrap76 happyOut76 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut76 #-} newtype HappyWrap77 = HappyWrap77 (LHsDecl GhcPs) happyIn77 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) happyIn77 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap77 x) {-# INLINE happyIn77 #-} happyOut77 :: (HappyAbsSyn ) -> HappyWrap77 happyOut77 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut77 #-} newtype HappyWrap78 = HappyWrap78 (LTyClDecl GhcPs) happyIn78 :: (LTyClDecl GhcPs) -> (HappyAbsSyn ) happyIn78 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap78 x) {-# INLINE happyIn78 #-} happyOut78 :: (HappyAbsSyn ) -> HappyWrap78 happyOut78 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut78 #-} newtype HappyWrap79 = HappyWrap79 (LTyClDecl GhcPs) happyIn79 :: (LTyClDecl GhcPs) -> (HappyAbsSyn ) happyIn79 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap79 x) {-# INLINE happyIn79 #-} happyOut79 :: (HappyAbsSyn ) -> HappyWrap79 happyOut79 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut79 #-} newtype HappyWrap80 = HappyWrap80 (LStandaloneKindSig GhcPs) happyIn80 :: (LStandaloneKindSig GhcPs) -> (HappyAbsSyn ) happyIn80 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap80 x) {-# INLINE happyIn80 #-} happyOut80 :: (HappyAbsSyn ) -> HappyWrap80 happyOut80 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut80 #-} newtype HappyWrap81 = HappyWrap81 (Located [Located RdrName]) happyIn81 :: (Located [Located RdrName]) -> (HappyAbsSyn ) happyIn81 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap81 x) {-# INLINE happyIn81 #-} happyOut81 :: (HappyAbsSyn ) -> HappyWrap81 happyOut81 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut81 #-} newtype HappyWrap82 = HappyWrap82 (LInstDecl GhcPs) happyIn82 :: (LInstDecl GhcPs) -> (HappyAbsSyn ) happyIn82 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap82 x) {-# INLINE happyIn82 #-} happyOut82 :: (HappyAbsSyn ) -> HappyWrap82 happyOut82 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut82 #-} newtype HappyWrap83 = HappyWrap83 (Maybe (Located OverlapMode)) happyIn83 :: (Maybe (Located OverlapMode)) -> (HappyAbsSyn ) happyIn83 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap83 x) {-# INLINE happyIn83 #-} happyOut83 :: (HappyAbsSyn ) -> HappyWrap83 happyOut83 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut83 #-} newtype HappyWrap84 = HappyWrap84 (LDerivStrategy GhcPs) happyIn84 :: (LDerivStrategy GhcPs) -> (HappyAbsSyn ) happyIn84 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap84 x) {-# INLINE happyIn84 #-} happyOut84 :: (HappyAbsSyn ) -> HappyWrap84 happyOut84 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut84 #-} newtype HappyWrap85 = HappyWrap85 (LDerivStrategy GhcPs) happyIn85 :: (LDerivStrategy GhcPs) -> (HappyAbsSyn ) happyIn85 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap85 x) {-# INLINE happyIn85 #-} happyOut85 :: (HappyAbsSyn ) -> HappyWrap85 happyOut85 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut85 #-} newtype HappyWrap86 = HappyWrap86 (Maybe (LDerivStrategy GhcPs)) happyIn86 :: (Maybe (LDerivStrategy GhcPs)) -> (HappyAbsSyn ) happyIn86 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap86 x) {-# INLINE happyIn86 #-} happyOut86 :: (HappyAbsSyn ) -> HappyWrap86 happyOut86 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut86 #-} newtype HappyWrap87 = HappyWrap87 (Located ([AddAnn], Maybe (LInjectivityAnn GhcPs))) happyIn87 :: (Located ([AddAnn], Maybe (LInjectivityAnn GhcPs))) -> (HappyAbsSyn ) happyIn87 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap87 x) {-# INLINE happyIn87 #-} happyOut87 :: (HappyAbsSyn ) -> HappyWrap87 happyOut87 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut87 #-} newtype HappyWrap88 = HappyWrap88 (LInjectivityAnn GhcPs) happyIn88 :: (LInjectivityAnn GhcPs) -> (HappyAbsSyn ) happyIn88 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap88 x) {-# INLINE happyIn88 #-} happyOut88 :: (HappyAbsSyn ) -> HappyWrap88 happyOut88 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut88 #-} newtype HappyWrap89 = HappyWrap89 (Located [Located RdrName]) happyIn89 :: (Located [Located RdrName]) -> (HappyAbsSyn ) happyIn89 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap89 x) {-# INLINE happyIn89 #-} happyOut89 :: (HappyAbsSyn ) -> HappyWrap89 happyOut89 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut89 #-} newtype HappyWrap90 = HappyWrap90 (Located ([AddAnn],FamilyInfo GhcPs)) happyIn90 :: (Located ([AddAnn],FamilyInfo GhcPs)) -> (HappyAbsSyn ) happyIn90 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap90 x) {-# INLINE happyIn90 #-} happyOut90 :: (HappyAbsSyn ) -> HappyWrap90 happyOut90 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut90 #-} newtype HappyWrap91 = HappyWrap91 (Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs])) happyIn91 :: (Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs])) -> (HappyAbsSyn ) happyIn91 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap91 x) {-# INLINE happyIn91 #-} happyOut91 :: (HappyAbsSyn ) -> HappyWrap91 happyOut91 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut91 #-} newtype HappyWrap92 = HappyWrap92 (Located [LTyFamInstEqn GhcPs]) happyIn92 :: (Located [LTyFamInstEqn GhcPs]) -> (HappyAbsSyn ) happyIn92 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap92 x) {-# INLINE happyIn92 #-} happyOut92 :: (HappyAbsSyn ) -> HappyWrap92 happyOut92 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut92 #-} newtype HappyWrap93 = HappyWrap93 (Located ([AddAnn],TyFamInstEqn GhcPs)) happyIn93 :: (Located ([AddAnn],TyFamInstEqn GhcPs)) -> (HappyAbsSyn ) happyIn93 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap93 x) {-# INLINE happyIn93 #-} happyOut93 :: (HappyAbsSyn ) -> HappyWrap93 happyOut93 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut93 #-} newtype HappyWrap94 = HappyWrap94 (LHsDecl GhcPs) happyIn94 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) happyIn94 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap94 x) {-# INLINE happyIn94 #-} happyOut94 :: (HappyAbsSyn ) -> HappyWrap94 happyOut94 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut94 #-} newtype HappyWrap95 = HappyWrap95 ([AddAnn]) happyIn95 :: ([AddAnn]) -> (HappyAbsSyn ) happyIn95 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap95 x) {-# INLINE happyIn95 #-} happyOut95 :: (HappyAbsSyn ) -> HappyWrap95 happyOut95 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut95 #-} newtype HappyWrap96 = HappyWrap96 ([AddAnn]) happyIn96 :: ([AddAnn]) -> (HappyAbsSyn ) happyIn96 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap96 x) {-# INLINE happyIn96 #-} happyOut96 :: (HappyAbsSyn ) -> HappyWrap96 happyOut96 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut96 #-} newtype HappyWrap97 = HappyWrap97 (LInstDecl GhcPs) happyIn97 :: (LInstDecl GhcPs) -> (HappyAbsSyn ) happyIn97 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap97 x) {-# INLINE happyIn97 #-} happyOut97 :: (HappyAbsSyn ) -> HappyWrap97 happyOut97 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut97 #-} newtype HappyWrap98 = HappyWrap98 (Located (AddAnn, NewOrData)) happyIn98 :: (Located (AddAnn, NewOrData)) -> (HappyAbsSyn ) happyIn98 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap98 x) {-# INLINE happyIn98 #-} happyOut98 :: (HappyAbsSyn ) -> HappyWrap98 happyOut98 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut98 #-} newtype HappyWrap99 = HappyWrap99 (Located ([AddAnn], Maybe (LHsKind GhcPs))) happyIn99 :: (Located ([AddAnn], Maybe (LHsKind GhcPs))) -> (HappyAbsSyn ) happyIn99 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap99 x) {-# INLINE happyIn99 #-} happyOut99 :: (HappyAbsSyn ) -> HappyWrap99 happyOut99 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut99 #-} newtype HappyWrap100 = HappyWrap100 (Located ([AddAnn], LFamilyResultSig GhcPs)) happyIn100 :: (Located ([AddAnn], LFamilyResultSig GhcPs)) -> (HappyAbsSyn ) happyIn100 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap100 x) {-# INLINE happyIn100 #-} happyOut100 :: (HappyAbsSyn ) -> HappyWrap100 happyOut100 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut100 #-} newtype HappyWrap101 = HappyWrap101 (Located ([AddAnn], LFamilyResultSig GhcPs)) happyIn101 :: (Located ([AddAnn], LFamilyResultSig GhcPs)) -> (HappyAbsSyn ) happyIn101 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap101 x) {-# INLINE happyIn101 #-} happyOut101 :: (HappyAbsSyn ) -> HappyWrap101 happyOut101 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut101 #-} newtype HappyWrap102 = HappyWrap102 (Located ([AddAnn], ( LFamilyResultSig GhcPs , Maybe (LInjectivityAnn GhcPs)))) happyIn102 :: (Located ([AddAnn], ( LFamilyResultSig GhcPs , Maybe (LInjectivityAnn GhcPs)))) -> (HappyAbsSyn ) happyIn102 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap102 x) {-# INLINE happyIn102 #-} happyOut102 :: (HappyAbsSyn ) -> HappyWrap102 happyOut102 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut102 #-} newtype HappyWrap103 = HappyWrap103 (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)) happyIn103 :: (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)) -> (HappyAbsSyn ) happyIn103 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap103 x) {-# INLINE happyIn103 #-} happyOut103 :: (HappyAbsSyn ) -> HappyWrap103 happyOut103 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut103 #-} newtype HappyWrap104 = HappyWrap104 (Located ([AddAnn],(Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs))) happyIn104 :: (Located ([AddAnn],(Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs))) -> (HappyAbsSyn ) happyIn104 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap104 x) {-# INLINE happyIn104 #-} happyOut104 :: (HappyAbsSyn ) -> HappyWrap104 happyOut104 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut104 #-} newtype HappyWrap105 = HappyWrap105 (Maybe (Located CType)) happyIn105 :: (Maybe (Located CType)) -> (HappyAbsSyn ) happyIn105 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap105 x) {-# INLINE happyIn105 #-} happyOut105 :: (HappyAbsSyn ) -> HappyWrap105 happyOut105 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut105 #-} newtype HappyWrap106 = HappyWrap106 (LDerivDecl GhcPs) happyIn106 :: (LDerivDecl GhcPs) -> (HappyAbsSyn ) happyIn106 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap106 x) {-# INLINE happyIn106 #-} happyOut106 :: (HappyAbsSyn ) -> HappyWrap106 happyOut106 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut106 #-} newtype HappyWrap107 = HappyWrap107 (LRoleAnnotDecl GhcPs) happyIn107 :: (LRoleAnnotDecl GhcPs) -> (HappyAbsSyn ) happyIn107 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap107 x) {-# INLINE happyIn107 #-} happyOut107 :: (HappyAbsSyn ) -> HappyWrap107 happyOut107 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut107 #-} newtype HappyWrap108 = HappyWrap108 (Located [Located (Maybe FastString)]) happyIn108 :: (Located [Located (Maybe FastString)]) -> (HappyAbsSyn ) happyIn108 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap108 x) {-# INLINE happyIn108 #-} happyOut108 :: (HappyAbsSyn ) -> HappyWrap108 happyOut108 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut108 #-} newtype HappyWrap109 = HappyWrap109 (Located [Located (Maybe FastString)]) happyIn109 :: (Located [Located (Maybe FastString)]) -> (HappyAbsSyn ) happyIn109 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap109 x) {-# INLINE happyIn109 #-} happyOut109 :: (HappyAbsSyn ) -> HappyWrap109 happyOut109 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut109 #-} newtype HappyWrap110 = HappyWrap110 (Located (Maybe FastString)) happyIn110 :: (Located (Maybe FastString)) -> (HappyAbsSyn ) happyIn110 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap110 x) {-# INLINE happyIn110 #-} happyOut110 :: (HappyAbsSyn ) -> HappyWrap110 happyOut110 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut110 #-} newtype HappyWrap111 = HappyWrap111 (LHsDecl GhcPs) happyIn111 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) happyIn111 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap111 x) {-# INLINE happyIn111 #-} happyOut111 :: (HappyAbsSyn ) -> HappyWrap111 happyOut111 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut111 #-} newtype HappyWrap112 = HappyWrap112 ((Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn])) happyIn112 :: ((Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn])) -> (HappyAbsSyn ) happyIn112 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap112 x) {-# INLINE happyIn112 #-} happyOut112 :: (HappyAbsSyn ) -> HappyWrap112 happyOut112 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut112 #-} newtype HappyWrap113 = HappyWrap113 ([Located RdrName]) happyIn113 :: ([Located RdrName]) -> (HappyAbsSyn ) happyIn113 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap113 x) {-# INLINE happyIn113 #-} happyOut113 :: (HappyAbsSyn ) -> HappyWrap113 happyOut113 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut113 #-} newtype HappyWrap114 = HappyWrap114 ([RecordPatSynField (Located RdrName)]) happyIn114 :: ([RecordPatSynField (Located RdrName)]) -> (HappyAbsSyn ) happyIn114 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap114 x) {-# INLINE happyIn114 #-} happyOut114 :: (HappyAbsSyn ) -> HappyWrap114 happyOut114 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut114 #-} newtype HappyWrap115 = HappyWrap115 (Located ([AddAnn] , Located (OrdList (LHsDecl GhcPs)))) happyIn115 :: (Located ([AddAnn] , Located (OrdList (LHsDecl GhcPs)))) -> (HappyAbsSyn ) happyIn115 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap115 x) {-# INLINE happyIn115 #-} happyOut115 :: (HappyAbsSyn ) -> HappyWrap115 happyOut115 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut115 #-} newtype HappyWrap116 = HappyWrap116 (LSig GhcPs) happyIn116 :: (LSig GhcPs) -> (HappyAbsSyn ) happyIn116 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap116 x) {-# INLINE happyIn116 #-} happyOut116 :: (HappyAbsSyn ) -> HappyWrap116 happyOut116 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut116 #-} newtype HappyWrap117 = HappyWrap117 (LHsDecl GhcPs) happyIn117 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) happyIn117 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap117 x) {-# INLINE happyIn117 #-} happyOut117 :: (HappyAbsSyn ) -> HappyWrap117 happyOut117 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut117 #-} newtype HappyWrap118 = HappyWrap118 (Located ([AddAnn],OrdList (LHsDecl GhcPs))) happyIn118 :: (Located ([AddAnn],OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) happyIn118 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap118 x) {-# INLINE happyIn118 #-} happyOut118 :: (HappyAbsSyn ) -> HappyWrap118 happyOut118 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut118 #-} newtype HappyWrap119 = HappyWrap119 (Located ([AddAnn] , OrdList (LHsDecl GhcPs))) happyIn119 :: (Located ([AddAnn] , OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) happyIn119 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap119 x) {-# INLINE happyIn119 #-} happyOut119 :: (HappyAbsSyn ) -> HappyWrap119 happyOut119 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut119 #-} newtype HappyWrap120 = HappyWrap120 (Located ([AddAnn] ,(OrdList (LHsDecl GhcPs)))) happyIn120 :: (Located ([AddAnn] ,(OrdList (LHsDecl GhcPs)))) -> (HappyAbsSyn ) happyIn120 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap120 x) {-# INLINE happyIn120 #-} happyOut120 :: (HappyAbsSyn ) -> HappyWrap120 happyOut120 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut120 #-} newtype HappyWrap121 = HappyWrap121 (Located (OrdList (LHsDecl GhcPs))) happyIn121 :: (Located (OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) happyIn121 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap121 x) {-# INLINE happyIn121 #-} happyOut121 :: (HappyAbsSyn ) -> HappyWrap121 happyOut121 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut121 #-} newtype HappyWrap122 = HappyWrap122 (Located ([AddAnn],OrdList (LHsDecl GhcPs))) happyIn122 :: (Located ([AddAnn],OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) happyIn122 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap122 x) {-# INLINE happyIn122 #-} happyOut122 :: (HappyAbsSyn ) -> HappyWrap122 happyOut122 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut122 #-} newtype HappyWrap123 = HappyWrap123 (Located ([AddAnn] , OrdList (LHsDecl GhcPs))) happyIn123 :: (Located ([AddAnn] , OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) happyIn123 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap123 x) {-# INLINE happyIn123 #-} happyOut123 :: (HappyAbsSyn ) -> HappyWrap123 happyOut123 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut123 #-} newtype HappyWrap124 = HappyWrap124 (Located ([AddAnn] , OrdList (LHsDecl GhcPs))) happyIn124 :: (Located ([AddAnn] , OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) happyIn124 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap124 x) {-# INLINE happyIn124 #-} happyOut124 :: (HappyAbsSyn ) -> HappyWrap124 happyOut124 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut124 #-} newtype HappyWrap125 = HappyWrap125 (Located ([AddAnn],OrdList (LHsDecl GhcPs))) happyIn125 :: (Located ([AddAnn],OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) happyIn125 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap125 x) {-# INLINE happyIn125 #-} happyOut125 :: (HappyAbsSyn ) -> HappyWrap125 happyOut125 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut125 #-} newtype HappyWrap126 = HappyWrap126 (Located ([AddAnn],Located (OrdList (LHsDecl GhcPs)))) happyIn126 :: (Located ([AddAnn],Located (OrdList (LHsDecl GhcPs)))) -> (HappyAbsSyn ) happyIn126 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap126 x) {-# INLINE happyIn126 #-} happyOut126 :: (HappyAbsSyn ) -> HappyWrap126 happyOut126 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut126 #-} newtype HappyWrap127 = HappyWrap127 (Located ([AddAnn],Located (HsLocalBinds GhcPs))) happyIn127 :: (Located ([AddAnn],Located (HsLocalBinds GhcPs))) -> (HappyAbsSyn ) happyIn127 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap127 x) {-# INLINE happyIn127 #-} happyOut127 :: (HappyAbsSyn ) -> HappyWrap127 happyOut127 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut127 #-} newtype HappyWrap128 = HappyWrap128 (Located ([AddAnn],Located (HsLocalBinds GhcPs))) happyIn128 :: (Located ([AddAnn],Located (HsLocalBinds GhcPs))) -> (HappyAbsSyn ) happyIn128 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap128 x) {-# INLINE happyIn128 #-} happyOut128 :: (HappyAbsSyn ) -> HappyWrap128 happyOut128 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut128 #-} newtype HappyWrap129 = HappyWrap129 (OrdList (LRuleDecl GhcPs)) happyIn129 :: (OrdList (LRuleDecl GhcPs)) -> (HappyAbsSyn ) happyIn129 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap129 x) {-# INLINE happyIn129 #-} happyOut129 :: (HappyAbsSyn ) -> HappyWrap129 happyOut129 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut129 #-} newtype HappyWrap130 = HappyWrap130 (LRuleDecl GhcPs) happyIn130 :: (LRuleDecl GhcPs) -> (HappyAbsSyn ) happyIn130 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap130 x) {-# INLINE happyIn130 #-} happyOut130 :: (HappyAbsSyn ) -> HappyWrap130 happyOut130 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut130 #-} newtype HappyWrap131 = HappyWrap131 (([AddAnn],Maybe Activation)) happyIn131 :: (([AddAnn],Maybe Activation)) -> (HappyAbsSyn ) happyIn131 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap131 x) {-# INLINE happyIn131 #-} happyOut131 :: (HappyAbsSyn ) -> HappyWrap131 happyOut131 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut131 #-} newtype HappyWrap132 = HappyWrap132 (([AddAnn] ,Activation)) happyIn132 :: (([AddAnn] ,Activation)) -> (HappyAbsSyn ) happyIn132 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap132 x) {-# INLINE happyIn132 #-} happyOut132 :: (HappyAbsSyn ) -> HappyWrap132 happyOut132 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut132 #-} newtype HappyWrap133 = HappyWrap133 (([AddAnn], Maybe [LHsTyVarBndr GhcPs], [LRuleBndr GhcPs])) happyIn133 :: (([AddAnn], Maybe [LHsTyVarBndr GhcPs], [LRuleBndr GhcPs])) -> (HappyAbsSyn ) happyIn133 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap133 x) {-# INLINE happyIn133 #-} happyOut133 :: (HappyAbsSyn ) -> HappyWrap133 happyOut133 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut133 #-} newtype HappyWrap134 = HappyWrap134 ([LRuleTyTmVar]) happyIn134 :: ([LRuleTyTmVar]) -> (HappyAbsSyn ) happyIn134 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap134 x) {-# INLINE happyIn134 #-} happyOut134 :: (HappyAbsSyn ) -> HappyWrap134 happyOut134 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut134 #-} newtype HappyWrap135 = HappyWrap135 (LRuleTyTmVar) happyIn135 :: (LRuleTyTmVar) -> (HappyAbsSyn ) happyIn135 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap135 x) {-# INLINE happyIn135 #-} happyOut135 :: (HappyAbsSyn ) -> HappyWrap135 happyOut135 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut135 #-} newtype HappyWrap136 = HappyWrap136 (OrdList (LWarnDecl GhcPs)) happyIn136 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) happyIn136 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap136 x) {-# INLINE happyIn136 #-} happyOut136 :: (HappyAbsSyn ) -> HappyWrap136 happyOut136 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut136 #-} newtype HappyWrap137 = HappyWrap137 (OrdList (LWarnDecl GhcPs)) happyIn137 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) happyIn137 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap137 x) {-# INLINE happyIn137 #-} happyOut137 :: (HappyAbsSyn ) -> HappyWrap137 happyOut137 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut137 #-} newtype HappyWrap138 = HappyWrap138 (OrdList (LWarnDecl GhcPs)) happyIn138 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) happyIn138 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap138 x) {-# INLINE happyIn138 #-} happyOut138 :: (HappyAbsSyn ) -> HappyWrap138 happyOut138 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut138 #-} newtype HappyWrap139 = HappyWrap139 (OrdList (LWarnDecl GhcPs)) happyIn139 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) happyIn139 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap139 x) {-# INLINE happyIn139 #-} happyOut139 :: (HappyAbsSyn ) -> HappyWrap139 happyOut139 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut139 #-} newtype HappyWrap140 = HappyWrap140 (Located ([AddAnn],[Located StringLiteral])) happyIn140 :: (Located ([AddAnn],[Located StringLiteral])) -> (HappyAbsSyn ) happyIn140 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap140 x) {-# INLINE happyIn140 #-} happyOut140 :: (HappyAbsSyn ) -> HappyWrap140 happyOut140 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut140 #-} newtype HappyWrap141 = HappyWrap141 (Located (OrdList (Located StringLiteral))) happyIn141 :: (Located (OrdList (Located StringLiteral))) -> (HappyAbsSyn ) happyIn141 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap141 x) {-# INLINE happyIn141 #-} happyOut141 :: (HappyAbsSyn ) -> HappyWrap141 happyOut141 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut141 #-} newtype HappyWrap142 = HappyWrap142 (LHsDecl GhcPs) happyIn142 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) happyIn142 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap142 x) {-# INLINE happyIn142 #-} happyOut142 :: (HappyAbsSyn ) -> HappyWrap142 happyOut142 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut142 #-} newtype HappyWrap143 = HappyWrap143 (Located ([AddAnn],HsDecl GhcPs)) happyIn143 :: (Located ([AddAnn],HsDecl GhcPs)) -> (HappyAbsSyn ) happyIn143 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap143 x) {-# INLINE happyIn143 #-} happyOut143 :: (HappyAbsSyn ) -> HappyWrap143 happyOut143 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut143 #-} newtype HappyWrap144 = HappyWrap144 (Located CCallConv) happyIn144 :: (Located CCallConv) -> (HappyAbsSyn ) happyIn144 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap144 x) {-# INLINE happyIn144 #-} happyOut144 :: (HappyAbsSyn ) -> HappyWrap144 happyOut144 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut144 #-} newtype HappyWrap145 = HappyWrap145 (Located Safety) happyIn145 :: (Located Safety) -> (HappyAbsSyn ) happyIn145 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap145 x) {-# INLINE happyIn145 #-} happyOut145 :: (HappyAbsSyn ) -> HappyWrap145 happyOut145 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut145 #-} newtype HappyWrap146 = HappyWrap146 (Located ([AddAnn] ,(Located StringLiteral, Located RdrName, LHsSigType GhcPs))) happyIn146 :: (Located ([AddAnn] ,(Located StringLiteral, Located RdrName, LHsSigType GhcPs))) -> (HappyAbsSyn ) happyIn146 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap146 x) {-# INLINE happyIn146 #-} happyOut146 :: (HappyAbsSyn ) -> HappyWrap146 happyOut146 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut146 #-} newtype HappyWrap147 = HappyWrap147 (([AddAnn], Maybe (LHsType GhcPs))) happyIn147 :: (([AddAnn], Maybe (LHsType GhcPs))) -> (HappyAbsSyn ) happyIn147 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap147 x) {-# INLINE happyIn147 #-} happyOut147 :: (HappyAbsSyn ) -> HappyWrap147 happyOut147 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut147 #-} newtype HappyWrap148 = HappyWrap148 (([AddAnn], Maybe (Located RdrName))) happyIn148 :: (([AddAnn], Maybe (Located RdrName))) -> (HappyAbsSyn ) happyIn148 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap148 x) {-# INLINE happyIn148 #-} happyOut148 :: (HappyAbsSyn ) -> HappyWrap148 happyOut148 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut148 #-} newtype HappyWrap149 = HappyWrap149 (LHsType GhcPs) happyIn149 :: (LHsType GhcPs) -> (HappyAbsSyn ) happyIn149 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap149 x) {-# INLINE happyIn149 #-} happyOut149 :: (HappyAbsSyn ) -> HappyWrap149 happyOut149 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut149 #-} newtype HappyWrap150 = HappyWrap150 (LHsType GhcPs) happyIn150 :: (LHsType GhcPs) -> (HappyAbsSyn ) happyIn150 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap150 x) {-# INLINE happyIn150 #-} happyOut150 :: (HappyAbsSyn ) -> HappyWrap150 happyOut150 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut150 #-} newtype HappyWrap151 = HappyWrap151 (Located [Located RdrName]) happyIn151 :: (Located [Located RdrName]) -> (HappyAbsSyn ) happyIn151 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap151 x) {-# INLINE happyIn151 #-} happyOut151 :: (HappyAbsSyn ) -> HappyWrap151 happyOut151 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut151 #-} newtype HappyWrap152 = HappyWrap152 ((OrdList (LHsSigType GhcPs))) happyIn152 :: ((OrdList (LHsSigType GhcPs))) -> (HappyAbsSyn ) happyIn152 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap152 x) {-# INLINE happyIn152 #-} happyOut152 :: (HappyAbsSyn ) -> HappyWrap152 happyOut152 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut152 #-} newtype HappyWrap153 = HappyWrap153 (Located ([AddAnn], SourceText, SrcUnpackedness)) happyIn153 :: (Located ([AddAnn], SourceText, SrcUnpackedness)) -> (HappyAbsSyn ) happyIn153 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap153 x) {-# INLINE happyIn153 #-} happyOut153 :: (HappyAbsSyn ) -> HappyWrap153 happyOut153 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut153 #-} newtype HappyWrap154 = HappyWrap154 ((AddAnn, ForallVisFlag)) happyIn154 :: ((AddAnn, ForallVisFlag)) -> (HappyAbsSyn ) happyIn154 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap154 x) {-# INLINE happyIn154 #-} happyOut154 :: (HappyAbsSyn ) -> HappyWrap154 happyOut154 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut154 #-} newtype HappyWrap155 = HappyWrap155 (LHsType GhcPs) happyIn155 :: (LHsType GhcPs) -> (HappyAbsSyn ) happyIn155 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap155 x) {-# INLINE happyIn155 #-} happyOut155 :: (HappyAbsSyn ) -> HappyWrap155 happyOut155 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut155 #-} newtype HappyWrap156 = HappyWrap156 (LHsType GhcPs) happyIn156 :: (LHsType GhcPs) -> (HappyAbsSyn ) happyIn156 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap156 x) {-# INLINE happyIn156 #-} happyOut156 :: (HappyAbsSyn ) -> HappyWrap156 happyOut156 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut156 #-} newtype HappyWrap157 = HappyWrap157 (LHsType GhcPs) happyIn157 :: (LHsType GhcPs) -> (HappyAbsSyn ) happyIn157 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap157 x) {-# INLINE happyIn157 #-} happyOut157 :: (HappyAbsSyn ) -> HappyWrap157 happyOut157 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut157 #-} newtype HappyWrap158 = HappyWrap158 (LHsType GhcPs) happyIn158 :: (LHsType GhcPs) -> (HappyAbsSyn ) happyIn158 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap158 x) {-# INLINE happyIn158 #-} happyOut158 :: (HappyAbsSyn ) -> HappyWrap158 happyOut158 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut158 #-} newtype HappyWrap159 = HappyWrap159 (LHsContext GhcPs) happyIn159 :: (LHsContext GhcPs) -> (HappyAbsSyn ) happyIn159 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap159 x) {-# INLINE happyIn159 #-} happyOut159 :: (HappyAbsSyn ) -> HappyWrap159 happyOut159 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut159 #-} newtype HappyWrap160 = HappyWrap160 (LHsContext GhcPs) happyIn160 :: (LHsContext GhcPs) -> (HappyAbsSyn ) happyIn160 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap160 x) {-# INLINE happyIn160 #-} happyOut160 :: (HappyAbsSyn ) -> HappyWrap160 happyOut160 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut160 #-} newtype HappyWrap161 = HappyWrap161 (LHsType GhcPs) happyIn161 :: (LHsType GhcPs) -> (HappyAbsSyn ) happyIn161 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap161 x) {-# INLINE happyIn161 #-} happyOut161 :: (HappyAbsSyn ) -> HappyWrap161 happyOut161 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut161 #-} newtype HappyWrap162 = HappyWrap162 (LHsType GhcPs) happyIn162 :: (LHsType GhcPs) -> (HappyAbsSyn ) happyIn162 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap162 x) {-# INLINE happyIn162 #-} happyOut162 :: (HappyAbsSyn ) -> HappyWrap162 happyOut162 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut162 #-} newtype HappyWrap163 = HappyWrap163 (LHsType GhcPs) happyIn163 :: (LHsType GhcPs) -> (HappyAbsSyn ) happyIn163 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap163 x) {-# INLINE happyIn163 #-} happyOut163 :: (HappyAbsSyn ) -> HappyWrap163 happyOut163 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut163 #-} newtype HappyWrap164 = HappyWrap164 (Located [Located TyEl]) happyIn164 :: (Located [Located TyEl]) -> (HappyAbsSyn ) happyIn164 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap164 x) {-# INLINE happyIn164 #-} happyOut164 :: (HappyAbsSyn ) -> HappyWrap164 happyOut164 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut164 #-} newtype HappyWrap165 = HappyWrap165 (Located TyEl) happyIn165 :: (Located TyEl) -> (HappyAbsSyn ) happyIn165 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap165 x) {-# INLINE happyIn165 #-} happyOut165 :: (HappyAbsSyn ) -> HappyWrap165 happyOut165 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut165 #-} newtype HappyWrap166 = HappyWrap166 (LHsType GhcPs) happyIn166 :: (LHsType GhcPs) -> (HappyAbsSyn ) happyIn166 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap166 x) {-# INLINE happyIn166 #-} happyOut166 :: (HappyAbsSyn ) -> HappyWrap166 happyOut166 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut166 #-} newtype HappyWrap167 = HappyWrap167 ([Located TyEl]) happyIn167 :: ([Located TyEl]) -> (HappyAbsSyn ) happyIn167 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap167 x) {-# INLINE happyIn167 #-} happyOut167 :: (HappyAbsSyn ) -> HappyWrap167 happyOut167 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut167 #-} newtype HappyWrap168 = HappyWrap168 (Located TyEl) happyIn168 :: (Located TyEl) -> (HappyAbsSyn ) happyIn168 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap168 x) {-# INLINE happyIn168 #-} happyOut168 :: (HappyAbsSyn ) -> HappyWrap168 happyOut168 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut168 #-} newtype HappyWrap169 = HappyWrap169 (LHsType GhcPs) happyIn169 :: (LHsType GhcPs) -> (HappyAbsSyn ) happyIn169 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap169 x) {-# INLINE happyIn169 #-} happyOut169 :: (HappyAbsSyn ) -> HappyWrap169 happyOut169 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut169 #-} newtype HappyWrap170 = HappyWrap170 (LHsSigType GhcPs) happyIn170 :: (LHsSigType GhcPs) -> (HappyAbsSyn ) happyIn170 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap170 x) {-# INLINE happyIn170 #-} happyOut170 :: (HappyAbsSyn ) -> HappyWrap170 happyOut170 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut170 #-} newtype HappyWrap171 = HappyWrap171 ([LHsSigType GhcPs]) happyIn171 :: ([LHsSigType GhcPs]) -> (HappyAbsSyn ) happyIn171 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap171 x) {-# INLINE happyIn171 #-} happyOut171 :: (HappyAbsSyn ) -> HappyWrap171 happyOut171 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut171 #-} newtype HappyWrap172 = HappyWrap172 ([LHsType GhcPs]) happyIn172 :: ([LHsType GhcPs]) -> (HappyAbsSyn ) happyIn172 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap172 x) {-# INLINE happyIn172 #-} happyOut172 :: (HappyAbsSyn ) -> HappyWrap172 happyOut172 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut172 #-} newtype HappyWrap173 = HappyWrap173 ([LHsType GhcPs]) happyIn173 :: ([LHsType GhcPs]) -> (HappyAbsSyn ) happyIn173 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap173 x) {-# INLINE happyIn173 #-} happyOut173 :: (HappyAbsSyn ) -> HappyWrap173 happyOut173 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut173 #-} newtype HappyWrap174 = HappyWrap174 ([LHsType GhcPs]) happyIn174 :: ([LHsType GhcPs]) -> (HappyAbsSyn ) happyIn174 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap174 x) {-# INLINE happyIn174 #-} happyOut174 :: (HappyAbsSyn ) -> HappyWrap174 happyOut174 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut174 #-} newtype HappyWrap175 = HappyWrap175 ([LHsTyVarBndr GhcPs]) happyIn175 :: ([LHsTyVarBndr GhcPs]) -> (HappyAbsSyn ) happyIn175 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap175 x) {-# INLINE happyIn175 #-} happyOut175 :: (HappyAbsSyn ) -> HappyWrap175 happyOut175 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut175 #-} newtype HappyWrap176 = HappyWrap176 (LHsTyVarBndr GhcPs) happyIn176 :: (LHsTyVarBndr GhcPs) -> (HappyAbsSyn ) happyIn176 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap176 x) {-# INLINE happyIn176 #-} happyOut176 :: (HappyAbsSyn ) -> HappyWrap176 happyOut176 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut176 #-} newtype HappyWrap177 = HappyWrap177 (Located ([AddAnn],[Located (FunDep (Located RdrName))])) happyIn177 :: (Located ([AddAnn],[Located (FunDep (Located RdrName))])) -> (HappyAbsSyn ) happyIn177 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap177 x) {-# INLINE happyIn177 #-} happyOut177 :: (HappyAbsSyn ) -> HappyWrap177 happyOut177 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut177 #-} newtype HappyWrap178 = HappyWrap178 (Located [Located (FunDep (Located RdrName))]) happyIn178 :: (Located [Located (FunDep (Located RdrName))]) -> (HappyAbsSyn ) happyIn178 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap178 x) {-# INLINE happyIn178 #-} happyOut178 :: (HappyAbsSyn ) -> HappyWrap178 happyOut178 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut178 #-} newtype HappyWrap179 = HappyWrap179 (Located (FunDep (Located RdrName))) happyIn179 :: (Located (FunDep (Located RdrName))) -> (HappyAbsSyn ) happyIn179 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap179 x) {-# INLINE happyIn179 #-} happyOut179 :: (HappyAbsSyn ) -> HappyWrap179 happyOut179 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut179 #-} newtype HappyWrap180 = HappyWrap180 (Located [Located RdrName]) happyIn180 :: (Located [Located RdrName]) -> (HappyAbsSyn ) happyIn180 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap180 x) {-# INLINE happyIn180 #-} happyOut180 :: (HappyAbsSyn ) -> HappyWrap180 happyOut180 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut180 #-} newtype HappyWrap181 = HappyWrap181 (LHsKind GhcPs) happyIn181 :: (LHsKind GhcPs) -> (HappyAbsSyn ) happyIn181 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap181 x) {-# INLINE happyIn181 #-} happyOut181 :: (HappyAbsSyn ) -> HappyWrap181 happyOut181 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut181 #-} newtype HappyWrap182 = HappyWrap182 (Located ([AddAnn] ,[LConDecl GhcPs])) happyIn182 :: (Located ([AddAnn] ,[LConDecl GhcPs])) -> (HappyAbsSyn ) happyIn182 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap182 x) {-# INLINE happyIn182 #-} happyOut182 :: (HappyAbsSyn ) -> HappyWrap182 happyOut182 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut182 #-} newtype HappyWrap183 = HappyWrap183 (Located [LConDecl GhcPs]) happyIn183 :: (Located [LConDecl GhcPs]) -> (HappyAbsSyn ) happyIn183 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap183 x) {-# INLINE happyIn183 #-} happyOut183 :: (HappyAbsSyn ) -> HappyWrap183 happyOut183 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut183 #-} newtype HappyWrap184 = HappyWrap184 (LConDecl GhcPs) happyIn184 :: (LConDecl GhcPs) -> (HappyAbsSyn ) happyIn184 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap184 x) {-# INLINE happyIn184 #-} happyOut184 :: (HappyAbsSyn ) -> HappyWrap184 happyOut184 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut184 #-} newtype HappyWrap185 = HappyWrap185 (LConDecl GhcPs) happyIn185 :: (LConDecl GhcPs) -> (HappyAbsSyn ) happyIn185 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap185 x) {-# INLINE happyIn185 #-} happyOut185 :: (HappyAbsSyn ) -> HappyWrap185 happyOut185 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut185 #-} newtype HappyWrap186 = HappyWrap186 (Located ([AddAnn],[LConDecl GhcPs])) happyIn186 :: (Located ([AddAnn],[LConDecl GhcPs])) -> (HappyAbsSyn ) happyIn186 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap186 x) {-# INLINE happyIn186 #-} happyOut186 :: (HappyAbsSyn ) -> HappyWrap186 happyOut186 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut186 #-} newtype HappyWrap187 = HappyWrap187 (Located [LConDecl GhcPs]) happyIn187 :: (Located [LConDecl GhcPs]) -> (HappyAbsSyn ) happyIn187 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap187 x) {-# INLINE happyIn187 #-} happyOut187 :: (HappyAbsSyn ) -> HappyWrap187 happyOut187 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut187 #-} newtype HappyWrap188 = HappyWrap188 (LConDecl GhcPs) happyIn188 :: (LConDecl GhcPs) -> (HappyAbsSyn ) happyIn188 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap188 x) {-# INLINE happyIn188 #-} happyOut188 :: (HappyAbsSyn ) -> HappyWrap188 happyOut188 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut188 #-} newtype HappyWrap189 = HappyWrap189 (Located ([AddAnn], Maybe [LHsTyVarBndr GhcPs])) happyIn189 :: (Located ([AddAnn], Maybe [LHsTyVarBndr GhcPs])) -> (HappyAbsSyn ) happyIn189 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap189 x) {-# INLINE happyIn189 #-} happyOut189 :: (HappyAbsSyn ) -> HappyWrap189 happyOut189 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut189 #-} newtype HappyWrap190 = HappyWrap190 (Located (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString)) happyIn190 :: (Located (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString)) -> (HappyAbsSyn ) happyIn190 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap190 x) {-# INLINE happyIn190 #-} happyOut190 :: (HappyAbsSyn ) -> HappyWrap190 happyOut190 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut190 #-} newtype HappyWrap191 = HappyWrap191 ([LConDeclField GhcPs]) happyIn191 :: ([LConDeclField GhcPs]) -> (HappyAbsSyn ) happyIn191 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap191 x) {-# INLINE happyIn191 #-} happyOut191 :: (HappyAbsSyn ) -> HappyWrap191 happyOut191 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut191 #-} newtype HappyWrap192 = HappyWrap192 ([LConDeclField GhcPs]) happyIn192 :: ([LConDeclField GhcPs]) -> (HappyAbsSyn ) happyIn192 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap192 x) {-# INLINE happyIn192 #-} happyOut192 :: (HappyAbsSyn ) -> HappyWrap192 happyOut192 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut192 #-} newtype HappyWrap193 = HappyWrap193 (LConDeclField GhcPs) happyIn193 :: (LConDeclField GhcPs) -> (HappyAbsSyn ) happyIn193 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap193 x) {-# INLINE happyIn193 #-} happyOut193 :: (HappyAbsSyn ) -> HappyWrap193 happyOut193 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut193 #-} newtype HappyWrap194 = HappyWrap194 (HsDeriving GhcPs) happyIn194 :: (HsDeriving GhcPs) -> (HappyAbsSyn ) happyIn194 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap194 x) {-# INLINE happyIn194 #-} happyOut194 :: (HappyAbsSyn ) -> HappyWrap194 happyOut194 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut194 #-} newtype HappyWrap195 = HappyWrap195 (HsDeriving GhcPs) happyIn195 :: (HsDeriving GhcPs) -> (HappyAbsSyn ) happyIn195 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap195 x) {-# INLINE happyIn195 #-} happyOut195 :: (HappyAbsSyn ) -> HappyWrap195 happyOut195 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut195 #-} newtype HappyWrap196 = HappyWrap196 (LHsDerivingClause GhcPs) happyIn196 :: (LHsDerivingClause GhcPs) -> (HappyAbsSyn ) happyIn196 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap196 x) {-# INLINE happyIn196 #-} happyOut196 :: (HappyAbsSyn ) -> HappyWrap196 happyOut196 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut196 #-} newtype HappyWrap197 = HappyWrap197 (Located [LHsSigType GhcPs]) happyIn197 :: (Located [LHsSigType GhcPs]) -> (HappyAbsSyn ) happyIn197 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap197 x) {-# INLINE happyIn197 #-} happyOut197 :: (HappyAbsSyn ) -> HappyWrap197 happyOut197 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut197 #-} newtype HappyWrap198 = HappyWrap198 (LHsDecl GhcPs) happyIn198 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) happyIn198 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap198 x) {-# INLINE happyIn198 #-} happyOut198 :: (HappyAbsSyn ) -> HappyWrap198 happyOut198 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut198 #-} newtype HappyWrap199 = HappyWrap199 (LDocDecl) happyIn199 :: (LDocDecl) -> (HappyAbsSyn ) happyIn199 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap199 x) {-# INLINE happyIn199 #-} happyOut199 :: (HappyAbsSyn ) -> HappyWrap199 happyOut199 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut199 #-} newtype HappyWrap200 = HappyWrap200 (LHsDecl GhcPs) happyIn200 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) happyIn200 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap200 x) {-# INLINE happyIn200 #-} happyOut200 :: (HappyAbsSyn ) -> HappyWrap200 happyOut200 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut200 #-} newtype HappyWrap201 = HappyWrap201 (LHsDecl GhcPs) happyIn201 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) happyIn201 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap201 x) {-# INLINE happyIn201 #-} happyOut201 :: (HappyAbsSyn ) -> HappyWrap201 happyOut201 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut201 #-} newtype HappyWrap202 = HappyWrap202 (Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs))) happyIn202 :: (Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs))) -> (HappyAbsSyn ) happyIn202 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap202 x) {-# INLINE happyIn202 #-} happyOut202 :: (HappyAbsSyn ) -> HappyWrap202 happyOut202 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut202 #-} newtype HappyWrap203 = HappyWrap203 (Located [LGRHS GhcPs (LHsExpr GhcPs)]) happyIn203 :: (Located [LGRHS GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) happyIn203 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap203 x) {-# INLINE happyIn203 #-} happyOut203 :: (HappyAbsSyn ) -> HappyWrap203 happyOut203 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut203 #-} newtype HappyWrap204 = HappyWrap204 (LGRHS GhcPs (LHsExpr GhcPs)) happyIn204 :: (LGRHS GhcPs (LHsExpr GhcPs)) -> (HappyAbsSyn ) happyIn204 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap204 x) {-# INLINE happyIn204 #-} happyOut204 :: (HappyAbsSyn ) -> HappyWrap204 happyOut204 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut204 #-} newtype HappyWrap205 = HappyWrap205 (LHsDecl GhcPs) happyIn205 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) happyIn205 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap205 x) {-# INLINE happyIn205 #-} happyOut205 :: (HappyAbsSyn ) -> HappyWrap205 happyOut205 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut205 #-} newtype HappyWrap206 = HappyWrap206 (([AddAnn],Maybe Activation)) happyIn206 :: (([AddAnn],Maybe Activation)) -> (HappyAbsSyn ) happyIn206 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap206 x) {-# INLINE happyIn206 #-} happyOut206 :: (HappyAbsSyn ) -> HappyWrap206 happyOut206 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut206 #-} newtype HappyWrap207 = HappyWrap207 (([AddAnn],Activation)) happyIn207 :: (([AddAnn],Activation)) -> (HappyAbsSyn ) happyIn207 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap207 x) {-# INLINE happyIn207 #-} happyOut207 :: (HappyAbsSyn ) -> HappyWrap207 happyOut207 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut207 #-} newtype HappyWrap208 = HappyWrap208 (Located (HsSplice GhcPs)) happyIn208 :: (Located (HsSplice GhcPs)) -> (HappyAbsSyn ) happyIn208 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap208 x) {-# INLINE happyIn208 #-} happyOut208 :: (HappyAbsSyn ) -> HappyWrap208 happyOut208 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut208 #-} newtype HappyWrap209 = HappyWrap209 (ECP) happyIn209 :: (ECP) -> (HappyAbsSyn ) happyIn209 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap209 x) {-# INLINE happyIn209 #-} happyOut209 :: (HappyAbsSyn ) -> HappyWrap209 happyOut209 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut209 #-} newtype HappyWrap210 = HappyWrap210 (ECP) happyIn210 :: (ECP) -> (HappyAbsSyn ) happyIn210 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap210 x) {-# INLINE happyIn210 #-} happyOut210 :: (HappyAbsSyn ) -> HappyWrap210 happyOut210 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut210 #-} newtype HappyWrap211 = HappyWrap211 (ECP) happyIn211 :: (ECP) -> (HappyAbsSyn ) happyIn211 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap211 x) {-# INLINE happyIn211 #-} happyOut211 :: (HappyAbsSyn ) -> HappyWrap211 happyOut211 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut211 #-} newtype HappyWrap212 = HappyWrap212 (ECP) happyIn212 :: (ECP) -> (HappyAbsSyn ) happyIn212 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap212 x) {-# INLINE happyIn212 #-} happyOut212 :: (HappyAbsSyn ) -> HappyWrap212 happyOut212 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut212 #-} newtype HappyWrap213 = HappyWrap213 (ECP) happyIn213 :: (ECP) -> (HappyAbsSyn ) happyIn213 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap213 x) {-# INLINE happyIn213 #-} happyOut213 :: (HappyAbsSyn ) -> HappyWrap213 happyOut213 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut213 #-} newtype HappyWrap214 = HappyWrap214 (([Located Token],Bool)) happyIn214 :: (([Located Token],Bool)) -> (HappyAbsSyn ) happyIn214 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap214 x) {-# INLINE happyIn214 #-} happyOut214 :: (HappyAbsSyn ) -> HappyWrap214 happyOut214 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut214 #-} newtype HappyWrap215 = HappyWrap215 (Located (([AddAnn],SourceText),StringLiteral)) happyIn215 :: (Located (([AddAnn],SourceText),StringLiteral)) -> (HappyAbsSyn ) happyIn215 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap215 x) {-# INLINE happyIn215 #-} happyOut215 :: (HappyAbsSyn ) -> HappyWrap215 happyOut215 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut215 #-} newtype HappyWrap216 = HappyWrap216 (Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))), ((SourceText,SourceText),(SourceText,SourceText)) )) happyIn216 :: (Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))), ((SourceText,SourceText),(SourceText,SourceText)) )) -> (HappyAbsSyn ) happyIn216 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap216 x) {-# INLINE happyIn216 #-} happyOut216 :: (HappyAbsSyn ) -> HappyWrap216 happyOut216 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut216 #-} newtype HappyWrap217 = HappyWrap217 (ECP) happyIn217 :: (ECP) -> (HappyAbsSyn ) happyIn217 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap217 x) {-# INLINE happyIn217 #-} happyOut217 :: (HappyAbsSyn ) -> HappyWrap217 happyOut217 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut217 #-} newtype HappyWrap218 = HappyWrap218 (ECP) happyIn218 :: (ECP) -> (HappyAbsSyn ) happyIn218 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap218 x) {-# INLINE happyIn218 #-} happyOut218 :: (HappyAbsSyn ) -> HappyWrap218 happyOut218 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut218 #-} newtype HappyWrap219 = HappyWrap219 (ECP) happyIn219 :: (ECP) -> (HappyAbsSyn ) happyIn219 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap219 x) {-# INLINE happyIn219 #-} happyOut219 :: (HappyAbsSyn ) -> HappyWrap219 happyOut219 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut219 #-} newtype HappyWrap220 = HappyWrap220 (ECP) happyIn220 :: (ECP) -> (HappyAbsSyn ) happyIn220 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap220 x) {-# INLINE happyIn220 #-} happyOut220 :: (HappyAbsSyn ) -> HappyWrap220 happyOut220 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut220 #-} newtype HappyWrap221 = HappyWrap221 (LHsExpr GhcPs) happyIn221 :: (LHsExpr GhcPs) -> (HappyAbsSyn ) happyIn221 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap221 x) {-# INLINE happyIn221 #-} happyOut221 :: (HappyAbsSyn ) -> HappyWrap221 happyOut221 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut221 #-} newtype HappyWrap222 = HappyWrap222 (Located (HsSplice GhcPs)) happyIn222 :: (Located (HsSplice GhcPs)) -> (HappyAbsSyn ) happyIn222 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap222 x) {-# INLINE happyIn222 #-} happyOut222 :: (HappyAbsSyn ) -> HappyWrap222 happyOut222 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut222 #-} newtype HappyWrap223 = HappyWrap223 (Located (HsSplice GhcPs)) happyIn223 :: (Located (HsSplice GhcPs)) -> (HappyAbsSyn ) happyIn223 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap223 x) {-# INLINE happyIn223 #-} happyOut223 :: (HappyAbsSyn ) -> HappyWrap223 happyOut223 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut223 #-} newtype HappyWrap224 = HappyWrap224 ([LHsCmdTop GhcPs]) happyIn224 :: ([LHsCmdTop GhcPs]) -> (HappyAbsSyn ) happyIn224 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap224 x) {-# INLINE happyIn224 #-} happyOut224 :: (HappyAbsSyn ) -> HappyWrap224 happyOut224 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut224 #-} newtype HappyWrap225 = HappyWrap225 (LHsCmdTop GhcPs) happyIn225 :: (LHsCmdTop GhcPs) -> (HappyAbsSyn ) happyIn225 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap225 x) {-# INLINE happyIn225 #-} happyOut225 :: (HappyAbsSyn ) -> HappyWrap225 happyOut225 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut225 #-} newtype HappyWrap226 = HappyWrap226 (([AddAnn],[LHsDecl GhcPs])) happyIn226 :: (([AddAnn],[LHsDecl GhcPs])) -> (HappyAbsSyn ) happyIn226 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap226 x) {-# INLINE happyIn226 #-} happyOut226 :: (HappyAbsSyn ) -> HappyWrap226 happyOut226 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut226 #-} newtype HappyWrap227 = HappyWrap227 ([LHsDecl GhcPs]) happyIn227 :: ([LHsDecl GhcPs]) -> (HappyAbsSyn ) happyIn227 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap227 x) {-# INLINE happyIn227 #-} happyOut227 :: (HappyAbsSyn ) -> HappyWrap227 happyOut227 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut227 #-} newtype HappyWrap228 = HappyWrap228 (ECP) happyIn228 :: (ECP) -> (HappyAbsSyn ) happyIn228 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap228 x) {-# INLINE happyIn228 #-} happyOut228 :: (HappyAbsSyn ) -> HappyWrap228 happyOut228 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut228 #-} newtype HappyWrap229 = HappyWrap229 (forall b. DisambECP b => PV ([AddAnn],SumOrTuple b)) happyIn229 :: (forall b. DisambECP b => PV ([AddAnn],SumOrTuple b)) -> (HappyAbsSyn ) happyIn229 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap229 x) {-# INLINE happyIn229 #-} happyOut229 :: (HappyAbsSyn ) -> HappyWrap229 happyOut229 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut229 #-} newtype HappyWrap230 = HappyWrap230 (forall b. DisambECP b => PV (SrcSpan,[Located (Maybe (Located b))])) happyIn230 :: (forall b. DisambECP b => PV (SrcSpan,[Located (Maybe (Located b))])) -> (HappyAbsSyn ) happyIn230 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap230 x) {-# INLINE happyIn230 #-} happyOut230 :: (HappyAbsSyn ) -> HappyWrap230 happyOut230 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut230 #-} newtype HappyWrap231 = HappyWrap231 (forall b. DisambECP b => PV [Located (Maybe (Located b))]) happyIn231 :: (forall b. DisambECP b => PV [Located (Maybe (Located b))]) -> (HappyAbsSyn ) happyIn231 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap231 x) {-# INLINE happyIn231 #-} happyOut231 :: (HappyAbsSyn ) -> HappyWrap231 happyOut231 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut231 #-} newtype HappyWrap232 = HappyWrap232 (forall b. DisambECP b => SrcSpan -> PV (Located b)) happyIn232 :: (forall b. DisambECP b => SrcSpan -> PV (Located b)) -> (HappyAbsSyn ) happyIn232 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap232 x) {-# INLINE happyIn232 #-} happyOut232 :: (HappyAbsSyn ) -> HappyWrap232 happyOut232 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut232 #-} newtype HappyWrap233 = HappyWrap233 (forall b. DisambECP b => PV [Located b]) happyIn233 :: (forall b. DisambECP b => PV [Located b]) -> (HappyAbsSyn ) happyIn233 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap233 x) {-# INLINE happyIn233 #-} happyOut233 :: (HappyAbsSyn ) -> HappyWrap233 happyOut233 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut233 #-} newtype HappyWrap234 = HappyWrap234 (Located [LStmt GhcPs (LHsExpr GhcPs)]) happyIn234 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) happyIn234 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap234 x) {-# INLINE happyIn234 #-} happyOut234 :: (HappyAbsSyn ) -> HappyWrap234 happyOut234 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut234 #-} newtype HappyWrap235 = HappyWrap235 (Located [[LStmt GhcPs (LHsExpr GhcPs)]]) happyIn235 :: (Located [[LStmt GhcPs (LHsExpr GhcPs)]]) -> (HappyAbsSyn ) happyIn235 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap235 x) {-# INLINE happyIn235 #-} happyOut235 :: (HappyAbsSyn ) -> HappyWrap235 happyOut235 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut235 #-} newtype HappyWrap236 = HappyWrap236 (Located [LStmt GhcPs (LHsExpr GhcPs)]) happyIn236 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) happyIn236 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap236 x) {-# INLINE happyIn236 #-} happyOut236 :: (HappyAbsSyn ) -> HappyWrap236 happyOut236 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut236 #-} newtype HappyWrap237 = HappyWrap237 (Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs))) happyIn237 :: (Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs))) -> (HappyAbsSyn ) happyIn237 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap237 x) {-# INLINE happyIn237 #-} happyOut237 :: (HappyAbsSyn ) -> HappyWrap237 happyOut237 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut237 #-} newtype HappyWrap238 = HappyWrap238 (Located [LStmt GhcPs (LHsExpr GhcPs)]) happyIn238 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) happyIn238 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap238 x) {-# INLINE happyIn238 #-} happyOut238 :: (HappyAbsSyn ) -> HappyWrap238 happyOut238 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut238 #-} newtype HappyWrap239 = HappyWrap239 (Located [LStmt GhcPs (LHsExpr GhcPs)]) happyIn239 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) happyIn239 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap239 x) {-# INLINE happyIn239 #-} happyOut239 :: (HappyAbsSyn ) -> HappyWrap239 happyOut239 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut239 #-} newtype HappyWrap240 = HappyWrap240 (forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)]))) happyIn240 :: (forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)]))) -> (HappyAbsSyn ) happyIn240 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap240 x) {-# INLINE happyIn240 #-} happyOut240 :: (HappyAbsSyn ) -> HappyWrap240 happyOut240 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut240 #-} newtype HappyWrap241 = HappyWrap241 (forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)]))) happyIn241 :: (forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)]))) -> (HappyAbsSyn ) happyIn241 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap241 x) {-# INLINE happyIn241 #-} happyOut241 :: (HappyAbsSyn ) -> HappyWrap241 happyOut241 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut241 #-} newtype HappyWrap242 = HappyWrap242 (forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)]))) happyIn242 :: (forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)]))) -> (HappyAbsSyn ) happyIn242 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap242 x) {-# INLINE happyIn242 #-} happyOut242 :: (HappyAbsSyn ) -> HappyWrap242 happyOut242 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut242 #-} newtype HappyWrap243 = HappyWrap243 (forall b. DisambECP b => PV (LMatch GhcPs (Located b))) happyIn243 :: (forall b. DisambECP b => PV (LMatch GhcPs (Located b))) -> (HappyAbsSyn ) happyIn243 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap243 x) {-# INLINE happyIn243 #-} happyOut243 :: (HappyAbsSyn ) -> HappyWrap243 happyOut243 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut243 #-} newtype HappyWrap244 = HappyWrap244 (forall b. DisambECP b => PV (Located ([AddAnn],GRHSs GhcPs (Located b)))) happyIn244 :: (forall b. DisambECP b => PV (Located ([AddAnn],GRHSs GhcPs (Located b)))) -> (HappyAbsSyn ) happyIn244 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap244 x) {-# INLINE happyIn244 #-} happyOut244 :: (HappyAbsSyn ) -> HappyWrap244 happyOut244 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut244 #-} newtype HappyWrap245 = HappyWrap245 (forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)])) happyIn245 :: (forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)])) -> (HappyAbsSyn ) happyIn245 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap245 x) {-# INLINE happyIn245 #-} happyOut245 :: (HappyAbsSyn ) -> HappyWrap245 happyOut245 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut245 #-} newtype HappyWrap246 = HappyWrap246 (forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)])) happyIn246 :: (forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)])) -> (HappyAbsSyn ) happyIn246 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap246 x) {-# INLINE happyIn246 #-} happyOut246 :: (HappyAbsSyn ) -> HappyWrap246 happyOut246 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut246 #-} newtype HappyWrap247 = HappyWrap247 (Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)])) happyIn247 :: (Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)])) -> (HappyAbsSyn ) happyIn247 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap247 x) {-# INLINE happyIn247 #-} happyOut247 :: (HappyAbsSyn ) -> HappyWrap247 happyOut247 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut247 #-} newtype HappyWrap248 = HappyWrap248 (forall b. DisambECP b => PV (LGRHS GhcPs (Located b))) happyIn248 :: (forall b. DisambECP b => PV (LGRHS GhcPs (Located b))) -> (HappyAbsSyn ) happyIn248 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap248 x) {-# INLINE happyIn248 #-} happyOut248 :: (HappyAbsSyn ) -> HappyWrap248 happyOut248 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut248 #-} newtype HappyWrap249 = HappyWrap249 (LPat GhcPs) happyIn249 :: (LPat GhcPs) -> (HappyAbsSyn ) happyIn249 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap249 x) {-# INLINE happyIn249 #-} happyOut249 :: (HappyAbsSyn ) -> HappyWrap249 happyOut249 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut249 #-} newtype HappyWrap250 = HappyWrap250 (LPat GhcPs) happyIn250 :: (LPat GhcPs) -> (HappyAbsSyn ) happyIn250 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap250 x) {-# INLINE happyIn250 #-} happyOut250 :: (HappyAbsSyn ) -> HappyWrap250 happyOut250 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut250 #-} newtype HappyWrap251 = HappyWrap251 (LPat GhcPs) happyIn251 :: (LPat GhcPs) -> (HappyAbsSyn ) happyIn251 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap251 x) {-# INLINE happyIn251 #-} happyOut251 :: (HappyAbsSyn ) -> HappyWrap251 happyOut251 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut251 #-} newtype HappyWrap252 = HappyWrap252 ([LPat GhcPs]) happyIn252 :: ([LPat GhcPs]) -> (HappyAbsSyn ) happyIn252 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap252 x) {-# INLINE happyIn252 #-} happyOut252 :: (HappyAbsSyn ) -> HappyWrap252 happyOut252 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut252 #-} newtype HappyWrap253 = HappyWrap253 (forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)]))) happyIn253 :: (forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)]))) -> (HappyAbsSyn ) happyIn253 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap253 x) {-# INLINE happyIn253 #-} happyOut253 :: (HappyAbsSyn ) -> HappyWrap253 happyOut253 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut253 #-} newtype HappyWrap254 = HappyWrap254 (forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)]))) happyIn254 :: (forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)]))) -> (HappyAbsSyn ) happyIn254 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap254 x) {-# INLINE happyIn254 #-} happyOut254 :: (HappyAbsSyn ) -> HappyWrap254 happyOut254 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut254 #-} newtype HappyWrap255 = HappyWrap255 (Maybe (LStmt GhcPs (LHsExpr GhcPs))) happyIn255 :: (Maybe (LStmt GhcPs (LHsExpr GhcPs))) -> (HappyAbsSyn ) happyIn255 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap255 x) {-# INLINE happyIn255 #-} happyOut255 :: (HappyAbsSyn ) -> HappyWrap255 happyOut255 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut255 #-} newtype HappyWrap256 = HappyWrap256 (LStmt GhcPs (LHsExpr GhcPs)) happyIn256 :: (LStmt GhcPs (LHsExpr GhcPs)) -> (HappyAbsSyn ) happyIn256 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap256 x) {-# INLINE happyIn256 #-} happyOut256 :: (HappyAbsSyn ) -> HappyWrap256 happyOut256 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut256 #-} newtype HappyWrap257 = HappyWrap257 (forall b. DisambECP b => PV (LStmt GhcPs (Located b))) happyIn257 :: (forall b. DisambECP b => PV (LStmt GhcPs (Located b))) -> (HappyAbsSyn ) happyIn257 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap257 x) {-# INLINE happyIn257 #-} happyOut257 :: (HappyAbsSyn ) -> HappyWrap257 happyOut257 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut257 #-} newtype HappyWrap258 = HappyWrap258 (forall b. DisambECP b => PV (LStmt GhcPs (Located b))) happyIn258 :: (forall b. DisambECP b => PV (LStmt GhcPs (Located b))) -> (HappyAbsSyn ) happyIn258 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap258 x) {-# INLINE happyIn258 #-} happyOut258 :: (HappyAbsSyn ) -> HappyWrap258 happyOut258 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut258 #-} newtype HappyWrap259 = HappyWrap259 (forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan))) happyIn259 :: (forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan))) -> (HappyAbsSyn ) happyIn259 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap259 x) {-# INLINE happyIn259 #-} happyOut259 :: (HappyAbsSyn ) -> HappyWrap259 happyOut259 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut259 #-} newtype HappyWrap260 = HappyWrap260 (forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan))) happyIn260 :: (forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan))) -> (HappyAbsSyn ) happyIn260 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap260 x) {-# INLINE happyIn260 #-} happyOut260 :: (HappyAbsSyn ) -> HappyWrap260 happyOut260 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut260 #-} newtype HappyWrap261 = HappyWrap261 (forall b. DisambECP b => PV (LHsRecField GhcPs (Located b))) happyIn261 :: (forall b. DisambECP b => PV (LHsRecField GhcPs (Located b))) -> (HappyAbsSyn ) happyIn261 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap261 x) {-# INLINE happyIn261 #-} happyOut261 :: (HappyAbsSyn ) -> HappyWrap261 happyOut261 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut261 #-} newtype HappyWrap262 = HappyWrap262 (Located [LIPBind GhcPs]) happyIn262 :: (Located [LIPBind GhcPs]) -> (HappyAbsSyn ) happyIn262 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap262 x) {-# INLINE happyIn262 #-} happyOut262 :: (HappyAbsSyn ) -> HappyWrap262 happyOut262 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut262 #-} newtype HappyWrap263 = HappyWrap263 (LIPBind GhcPs) happyIn263 :: (LIPBind GhcPs) -> (HappyAbsSyn ) happyIn263 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap263 x) {-# INLINE happyIn263 #-} happyOut263 :: (HappyAbsSyn ) -> HappyWrap263 happyOut263 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut263 #-} newtype HappyWrap264 = HappyWrap264 (Located HsIPName) happyIn264 :: (Located HsIPName) -> (HappyAbsSyn ) happyIn264 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap264 x) {-# INLINE happyIn264 #-} happyOut264 :: (HappyAbsSyn ) -> HappyWrap264 happyOut264 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut264 #-} newtype HappyWrap265 = HappyWrap265 (Located FastString) happyIn265 :: (Located FastString) -> (HappyAbsSyn ) happyIn265 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap265 x) {-# INLINE happyIn265 #-} happyOut265 :: (HappyAbsSyn ) -> HappyWrap265 happyOut265 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut265 #-} newtype HappyWrap266 = HappyWrap266 (LBooleanFormula (Located RdrName)) happyIn266 :: (LBooleanFormula (Located RdrName)) -> (HappyAbsSyn ) happyIn266 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap266 x) {-# INLINE happyIn266 #-} happyOut266 :: (HappyAbsSyn ) -> HappyWrap266 happyOut266 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut266 #-} newtype HappyWrap267 = HappyWrap267 (LBooleanFormula (Located RdrName)) happyIn267 :: (LBooleanFormula (Located RdrName)) -> (HappyAbsSyn ) happyIn267 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap267 x) {-# INLINE happyIn267 #-} happyOut267 :: (HappyAbsSyn ) -> HappyWrap267 happyOut267 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut267 #-} newtype HappyWrap268 = HappyWrap268 (LBooleanFormula (Located RdrName)) happyIn268 :: (LBooleanFormula (Located RdrName)) -> (HappyAbsSyn ) happyIn268 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap268 x) {-# INLINE happyIn268 #-} happyOut268 :: (HappyAbsSyn ) -> HappyWrap268 happyOut268 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut268 #-} newtype HappyWrap269 = HappyWrap269 ([LBooleanFormula (Located RdrName)]) happyIn269 :: ([LBooleanFormula (Located RdrName)]) -> (HappyAbsSyn ) happyIn269 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap269 x) {-# INLINE happyIn269 #-} happyOut269 :: (HappyAbsSyn ) -> HappyWrap269 happyOut269 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut269 #-} newtype HappyWrap270 = HappyWrap270 (LBooleanFormula (Located RdrName)) happyIn270 :: (LBooleanFormula (Located RdrName)) -> (HappyAbsSyn ) happyIn270 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap270 x) {-# INLINE happyIn270 #-} happyOut270 :: (HappyAbsSyn ) -> HappyWrap270 happyOut270 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut270 #-} newtype HappyWrap271 = HappyWrap271 (Located [Located RdrName]) happyIn271 :: (Located [Located RdrName]) -> (HappyAbsSyn ) happyIn271 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap271 x) {-# INLINE happyIn271 #-} happyOut271 :: (HappyAbsSyn ) -> HappyWrap271 happyOut271 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut271 #-} newtype HappyWrap272 = HappyWrap272 (Located RdrName) happyIn272 :: (Located RdrName) -> (HappyAbsSyn ) happyIn272 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap272 x) {-# INLINE happyIn272 #-} happyOut272 :: (HappyAbsSyn ) -> HappyWrap272 happyOut272 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut272 #-} newtype HappyWrap273 = HappyWrap273 (Located RdrName) happyIn273 :: (Located RdrName) -> (HappyAbsSyn ) happyIn273 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap273 x) {-# INLINE happyIn273 #-} happyOut273 :: (HappyAbsSyn ) -> HappyWrap273 happyOut273 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut273 #-} newtype HappyWrap274 = HappyWrap274 (Located RdrName) happyIn274 :: (Located RdrName) -> (HappyAbsSyn ) happyIn274 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap274 x) {-# INLINE happyIn274 #-} happyOut274 :: (HappyAbsSyn ) -> HappyWrap274 happyOut274 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut274 #-} newtype HappyWrap275 = HappyWrap275 (Located RdrName) happyIn275 :: (Located RdrName) -> (HappyAbsSyn ) happyIn275 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap275 x) {-# INLINE happyIn275 #-} happyOut275 :: (HappyAbsSyn ) -> HappyWrap275 happyOut275 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut275 #-} newtype HappyWrap276 = HappyWrap276 (Located RdrName) happyIn276 :: (Located RdrName) -> (HappyAbsSyn ) happyIn276 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap276 x) {-# INLINE happyIn276 #-} happyOut276 :: (HappyAbsSyn ) -> HappyWrap276 happyOut276 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut276 #-} newtype HappyWrap277 = HappyWrap277 (Located [Located RdrName]) happyIn277 :: (Located [Located RdrName]) -> (HappyAbsSyn ) happyIn277 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap277 x) {-# INLINE happyIn277 #-} happyOut277 :: (HappyAbsSyn ) -> HappyWrap277 happyOut277 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut277 #-} newtype HappyWrap278 = HappyWrap278 (Located DataCon) happyIn278 :: (Located DataCon) -> (HappyAbsSyn ) happyIn278 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap278 x) {-# INLINE happyIn278 #-} happyOut278 :: (HappyAbsSyn ) -> HappyWrap278 happyOut278 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut278 #-} newtype HappyWrap279 = HappyWrap279 (Located DataCon) happyIn279 :: (Located DataCon) -> (HappyAbsSyn ) happyIn279 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap279 x) {-# INLINE happyIn279 #-} happyOut279 :: (HappyAbsSyn ) -> HappyWrap279 happyOut279 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut279 #-} newtype HappyWrap280 = HappyWrap280 (Located RdrName) happyIn280 :: (Located RdrName) -> (HappyAbsSyn ) happyIn280 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap280 x) {-# INLINE happyIn280 #-} happyOut280 :: (HappyAbsSyn ) -> HappyWrap280 happyOut280 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut280 #-} newtype HappyWrap281 = HappyWrap281 (Located RdrName) happyIn281 :: (Located RdrName) -> (HappyAbsSyn ) happyIn281 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap281 x) {-# INLINE happyIn281 #-} happyOut281 :: (HappyAbsSyn ) -> HappyWrap281 happyOut281 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut281 #-} newtype HappyWrap282 = HappyWrap282 (Located RdrName) happyIn282 :: (Located RdrName) -> (HappyAbsSyn ) happyIn282 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap282 x) {-# INLINE happyIn282 #-} happyOut282 :: (HappyAbsSyn ) -> HappyWrap282 happyOut282 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut282 #-} newtype HappyWrap283 = HappyWrap283 (Located RdrName) happyIn283 :: (Located RdrName) -> (HappyAbsSyn ) happyIn283 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap283 x) {-# INLINE happyIn283 #-} happyOut283 :: (HappyAbsSyn ) -> HappyWrap283 happyOut283 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut283 #-} newtype HappyWrap284 = HappyWrap284 (Located RdrName) happyIn284 :: (Located RdrName) -> (HappyAbsSyn ) happyIn284 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap284 x) {-# INLINE happyIn284 #-} happyOut284 :: (HappyAbsSyn ) -> HappyWrap284 happyOut284 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut284 #-} newtype HappyWrap285 = HappyWrap285 (Located RdrName) happyIn285 :: (Located RdrName) -> (HappyAbsSyn ) happyIn285 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap285 x) {-# INLINE happyIn285 #-} happyOut285 :: (HappyAbsSyn ) -> HappyWrap285 happyOut285 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut285 #-} newtype HappyWrap286 = HappyWrap286 (Located RdrName) happyIn286 :: (Located RdrName) -> (HappyAbsSyn ) happyIn286 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap286 x) {-# INLINE happyIn286 #-} happyOut286 :: (HappyAbsSyn ) -> HappyWrap286 happyOut286 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut286 #-} newtype HappyWrap287 = HappyWrap287 (Located RdrName) happyIn287 :: (Located RdrName) -> (HappyAbsSyn ) happyIn287 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap287 x) {-# INLINE happyIn287 #-} happyOut287 :: (HappyAbsSyn ) -> HappyWrap287 happyOut287 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut287 #-} newtype HappyWrap288 = HappyWrap288 (LHsType GhcPs) happyIn288 :: (LHsType GhcPs) -> (HappyAbsSyn ) happyIn288 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap288 x) {-# INLINE happyIn288 #-} happyOut288 :: (HappyAbsSyn ) -> HappyWrap288 happyOut288 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut288 #-} newtype HappyWrap289 = HappyWrap289 (Located RdrName) happyIn289 :: (Located RdrName) -> (HappyAbsSyn ) happyIn289 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap289 x) {-# INLINE happyIn289 #-} happyOut289 :: (HappyAbsSyn ) -> HappyWrap289 happyOut289 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut289 #-} newtype HappyWrap290 = HappyWrap290 (Located RdrName) happyIn290 :: (Located RdrName) -> (HappyAbsSyn ) happyIn290 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap290 x) {-# INLINE happyIn290 #-} happyOut290 :: (HappyAbsSyn ) -> HappyWrap290 happyOut290 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut290 #-} newtype HappyWrap291 = HappyWrap291 (Located RdrName) happyIn291 :: (Located RdrName) -> (HappyAbsSyn ) happyIn291 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap291 x) {-# INLINE happyIn291 #-} happyOut291 :: (HappyAbsSyn ) -> HappyWrap291 happyOut291 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut291 #-} newtype HappyWrap292 = HappyWrap292 (Located RdrName) happyIn292 :: (Located RdrName) -> (HappyAbsSyn ) happyIn292 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap292 x) {-# INLINE happyIn292 #-} happyOut292 :: (HappyAbsSyn ) -> HappyWrap292 happyOut292 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut292 #-} newtype HappyWrap293 = HappyWrap293 (Located RdrName) happyIn293 :: (Located RdrName) -> (HappyAbsSyn ) happyIn293 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap293 x) {-# INLINE happyIn293 #-} happyOut293 :: (HappyAbsSyn ) -> HappyWrap293 happyOut293 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut293 #-} newtype HappyWrap294 = HappyWrap294 (forall b. DisambInfixOp b => PV (Located b)) happyIn294 :: (forall b. DisambInfixOp b => PV (Located b)) -> (HappyAbsSyn ) happyIn294 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap294 x) {-# INLINE happyIn294 #-} happyOut294 :: (HappyAbsSyn ) -> HappyWrap294 happyOut294 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut294 #-} newtype HappyWrap295 = HappyWrap295 (forall b. DisambInfixOp b => PV (Located b)) happyIn295 :: (forall b. DisambInfixOp b => PV (Located b)) -> (HappyAbsSyn ) happyIn295 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap295 x) {-# INLINE happyIn295 #-} happyOut295 :: (HappyAbsSyn ) -> HappyWrap295 happyOut295 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut295 #-} newtype HappyWrap296 = HappyWrap296 (forall b. DisambInfixOp b => PV (Located b)) happyIn296 :: (forall b. DisambInfixOp b => PV (Located b)) -> (HappyAbsSyn ) happyIn296 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap296 x) {-# INLINE happyIn296 #-} happyOut296 :: (HappyAbsSyn ) -> HappyWrap296 happyOut296 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut296 #-} newtype HappyWrap297 = HappyWrap297 (Located RdrName) happyIn297 :: (Located RdrName) -> (HappyAbsSyn ) happyIn297 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap297 x) {-# INLINE happyIn297 #-} happyOut297 :: (HappyAbsSyn ) -> HappyWrap297 happyOut297 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut297 #-} newtype HappyWrap298 = HappyWrap298 (Located RdrName) happyIn298 :: (Located RdrName) -> (HappyAbsSyn ) happyIn298 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap298 x) {-# INLINE happyIn298 #-} happyOut298 :: (HappyAbsSyn ) -> HappyWrap298 happyOut298 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut298 #-} newtype HappyWrap299 = HappyWrap299 (Located RdrName) happyIn299 :: (Located RdrName) -> (HappyAbsSyn ) happyIn299 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap299 x) {-# INLINE happyIn299 #-} happyOut299 :: (HappyAbsSyn ) -> HappyWrap299 happyOut299 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut299 #-} newtype HappyWrap300 = HappyWrap300 (Located RdrName) happyIn300 :: (Located RdrName) -> (HappyAbsSyn ) happyIn300 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap300 x) {-# INLINE happyIn300 #-} happyOut300 :: (HappyAbsSyn ) -> HappyWrap300 happyOut300 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut300 #-} newtype HappyWrap301 = HappyWrap301 (Located RdrName) happyIn301 :: (Located RdrName) -> (HappyAbsSyn ) happyIn301 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap301 x) {-# INLINE happyIn301 #-} happyOut301 :: (HappyAbsSyn ) -> HappyWrap301 happyOut301 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut301 #-} newtype HappyWrap302 = HappyWrap302 (Located RdrName) happyIn302 :: (Located RdrName) -> (HappyAbsSyn ) happyIn302 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap302 x) {-# INLINE happyIn302 #-} happyOut302 :: (HappyAbsSyn ) -> HappyWrap302 happyOut302 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut302 #-} newtype HappyWrap303 = HappyWrap303 (Located RdrName) happyIn303 :: (Located RdrName) -> (HappyAbsSyn ) happyIn303 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap303 x) {-# INLINE happyIn303 #-} happyOut303 :: (HappyAbsSyn ) -> HappyWrap303 happyOut303 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut303 #-} newtype HappyWrap304 = HappyWrap304 (Located RdrName) happyIn304 :: (Located RdrName) -> (HappyAbsSyn ) happyIn304 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap304 x) {-# INLINE happyIn304 #-} happyOut304 :: (HappyAbsSyn ) -> HappyWrap304 happyOut304 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut304 #-} newtype HappyWrap305 = HappyWrap305 (Located RdrName) happyIn305 :: (Located RdrName) -> (HappyAbsSyn ) happyIn305 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap305 x) {-# INLINE happyIn305 #-} happyOut305 :: (HappyAbsSyn ) -> HappyWrap305 happyOut305 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut305 #-} newtype HappyWrap306 = HappyWrap306 (Located RdrName) happyIn306 :: (Located RdrName) -> (HappyAbsSyn ) happyIn306 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap306 x) {-# INLINE happyIn306 #-} happyOut306 :: (HappyAbsSyn ) -> HappyWrap306 happyOut306 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut306 #-} newtype HappyWrap307 = HappyWrap307 (Located RdrName) happyIn307 :: (Located RdrName) -> (HappyAbsSyn ) happyIn307 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap307 x) {-# INLINE happyIn307 #-} happyOut307 :: (HappyAbsSyn ) -> HappyWrap307 happyOut307 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut307 #-} newtype HappyWrap308 = HappyWrap308 (Located RdrName) happyIn308 :: (Located RdrName) -> (HappyAbsSyn ) happyIn308 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap308 x) {-# INLINE happyIn308 #-} happyOut308 :: (HappyAbsSyn ) -> HappyWrap308 happyOut308 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut308 #-} newtype HappyWrap309 = HappyWrap309 (Located RdrName) happyIn309 :: (Located RdrName) -> (HappyAbsSyn ) happyIn309 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap309 x) {-# INLINE happyIn309 #-} happyOut309 :: (HappyAbsSyn ) -> HappyWrap309 happyOut309 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut309 #-} newtype HappyWrap310 = HappyWrap310 (Located RdrName) happyIn310 :: (Located RdrName) -> (HappyAbsSyn ) happyIn310 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap310 x) {-# INLINE happyIn310 #-} happyOut310 :: (HappyAbsSyn ) -> HappyWrap310 happyOut310 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut310 #-} newtype HappyWrap311 = HappyWrap311 (Located FastString) happyIn311 :: (Located FastString) -> (HappyAbsSyn ) happyIn311 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap311 x) {-# INLINE happyIn311 #-} happyOut311 :: (HappyAbsSyn ) -> HappyWrap311 happyOut311 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut311 #-} newtype HappyWrap312 = HappyWrap312 (Located FastString) happyIn312 :: (Located FastString) -> (HappyAbsSyn ) happyIn312 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap312 x) {-# INLINE happyIn312 #-} happyOut312 :: (HappyAbsSyn ) -> HappyWrap312 happyOut312 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut312 #-} newtype HappyWrap313 = HappyWrap313 (Located RdrName) happyIn313 :: (Located RdrName) -> (HappyAbsSyn ) happyIn313 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap313 x) {-# INLINE happyIn313 #-} happyOut313 :: (HappyAbsSyn ) -> HappyWrap313 happyOut313 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut313 #-} newtype HappyWrap314 = HappyWrap314 (Located RdrName) happyIn314 :: (Located RdrName) -> (HappyAbsSyn ) happyIn314 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap314 x) {-# INLINE happyIn314 #-} happyOut314 :: (HappyAbsSyn ) -> HappyWrap314 happyOut314 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut314 #-} newtype HappyWrap315 = HappyWrap315 (Located RdrName) happyIn315 :: (Located RdrName) -> (HappyAbsSyn ) happyIn315 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap315 x) {-# INLINE happyIn315 #-} happyOut315 :: (HappyAbsSyn ) -> HappyWrap315 happyOut315 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut315 #-} newtype HappyWrap316 = HappyWrap316 (Located RdrName) happyIn316 :: (Located RdrName) -> (HappyAbsSyn ) happyIn316 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap316 x) {-# INLINE happyIn316 #-} happyOut316 :: (HappyAbsSyn ) -> HappyWrap316 happyOut316 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut316 #-} newtype HappyWrap317 = HappyWrap317 (Located (HsLit GhcPs)) happyIn317 :: (Located (HsLit GhcPs)) -> (HappyAbsSyn ) happyIn317 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap317 x) {-# INLINE happyIn317 #-} happyOut317 :: (HappyAbsSyn ) -> HappyWrap317 happyOut317 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut317 #-} newtype HappyWrap318 = HappyWrap318 (()) happyIn318 :: (()) -> (HappyAbsSyn ) happyIn318 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap318 x) {-# INLINE happyIn318 #-} happyOut318 :: (HappyAbsSyn ) -> HappyWrap318 happyOut318 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut318 #-} newtype HappyWrap319 = HappyWrap319 (Located ModuleName) happyIn319 :: (Located ModuleName) -> (HappyAbsSyn ) happyIn319 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap319 x) {-# INLINE happyIn319 #-} happyOut319 :: (HappyAbsSyn ) -> HappyWrap319 happyOut319 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut319 #-} newtype HappyWrap320 = HappyWrap320 (([SrcSpan],Int)) happyIn320 :: (([SrcSpan],Int)) -> (HappyAbsSyn ) happyIn320 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap320 x) {-# INLINE happyIn320 #-} happyOut320 :: (HappyAbsSyn ) -> HappyWrap320 happyOut320 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut320 #-} newtype HappyWrap321 = HappyWrap321 (([SrcSpan],Int)) happyIn321 :: (([SrcSpan],Int)) -> (HappyAbsSyn ) happyIn321 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap321 x) {-# INLINE happyIn321 #-} happyOut321 :: (HappyAbsSyn ) -> HappyWrap321 happyOut321 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut321 #-} newtype HappyWrap322 = HappyWrap322 (([SrcSpan],Int)) happyIn322 :: (([SrcSpan],Int)) -> (HappyAbsSyn ) happyIn322 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap322 x) {-# INLINE happyIn322 #-} happyOut322 :: (HappyAbsSyn ) -> HappyWrap322 happyOut322 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut322 #-} newtype HappyWrap323 = HappyWrap323 (LHsDocString) happyIn323 :: (LHsDocString) -> (HappyAbsSyn ) happyIn323 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap323 x) {-# INLINE happyIn323 #-} happyOut323 :: (HappyAbsSyn ) -> HappyWrap323 happyOut323 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut323 #-} newtype HappyWrap324 = HappyWrap324 (LHsDocString) happyIn324 :: (LHsDocString) -> (HappyAbsSyn ) happyIn324 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap324 x) {-# INLINE happyIn324 #-} happyOut324 :: (HappyAbsSyn ) -> HappyWrap324 happyOut324 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut324 #-} newtype HappyWrap325 = HappyWrap325 (Located (String, HsDocString)) happyIn325 :: (Located (String, HsDocString)) -> (HappyAbsSyn ) happyIn325 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap325 x) {-# INLINE happyIn325 #-} happyOut325 :: (HappyAbsSyn ) -> HappyWrap325 happyOut325 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut325 #-} newtype HappyWrap326 = HappyWrap326 (Located (Int, HsDocString)) happyIn326 :: (Located (Int, HsDocString)) -> (HappyAbsSyn ) happyIn326 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap326 x) {-# INLINE happyIn326 #-} happyOut326 :: (HappyAbsSyn ) -> HappyWrap326 happyOut326 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut326 #-} newtype HappyWrap327 = HappyWrap327 (Maybe LHsDocString) happyIn327 :: (Maybe LHsDocString) -> (HappyAbsSyn ) happyIn327 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap327 x) {-# INLINE happyIn327 #-} happyOut327 :: (HappyAbsSyn ) -> HappyWrap327 happyOut327 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut327 #-} newtype HappyWrap328 = HappyWrap328 (Maybe LHsDocString) happyIn328 :: (Maybe LHsDocString) -> (HappyAbsSyn ) happyIn328 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap328 x) {-# INLINE happyIn328 #-} happyOut328 :: (HappyAbsSyn ) -> HappyWrap328 happyOut328 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut328 #-} newtype HappyWrap329 = HappyWrap329 (Maybe LHsDocString) happyIn329 :: (Maybe LHsDocString) -> (HappyAbsSyn ) happyIn329 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap329 x) {-# INLINE happyIn329 #-} happyOut329 :: (HappyAbsSyn ) -> HappyWrap329 happyOut329 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut329 #-} happyInTok :: ((Located Token)) -> (HappyAbsSyn ) happyInTok x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyInTok #-} happyOutTok :: (HappyAbsSyn ) -> ((Located Token)) happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOutTok #-} happyExpList :: HappyAddr happyExpList = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc7\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xcd\x57\xfd\xff\x97\xff\xfb\x19\x04\x41\x03\x20\x2a\x9c\xf9\xff\x7f\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x00\x04\x05\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x10\x34\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x73\x11\xfd\xff\xe5\xff\x1c\x04\x41\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x1f\x7f\x70\x00\x00\x41\x03\x20\x2a\x9c\xf9\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xd1\xef\x4f\xf8\x01\x00\x80\x40\x1c\x82\x28\xe8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\xf7\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x00\x08\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x08\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x81\x88\x02\x47\x30\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x29\xf8\x3d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x75\x38\xe2\xf0\xf7\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\xc6\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x40\xf0\xe3\x13\x7e\x00\x00\x00\x00\x00\x00\x00\x18\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xd1\xef\x4f\xf8\x01\x00\x80\x00\x1c\x82\x28\xe8\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x00\x04\x05\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xd4\x21\x00\x41\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x00\x00\x60\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x00\x04\x05\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x10\x14\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x00\x14\x05\x88\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x17\x7e\x00\x00\x00\x41\x00\x20\x2a\x9c\xf9\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xe1\x07\x00\x00\x10\x04\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xe1\x07\x00\x00\x30\x24\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x17\x7f\x00\x00\x00\x41\x00\x20\x2a\x9c\xf9\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xf8\x01\x00\x00\x04\x01\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x12\x74\x08\xa6\xe2\xff\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd1\x21\x88\xcb\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x17\x7f\x70\x00\x20\x45\x87\x20\x3a\xff\xff\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x07\x00\x00\x00\x00\x00\xa2\x80\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x10\x14\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf4\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xcf\x00\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x10\x14\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x17\x7f\x70\x00\x00\x41\x01\x20\x2a\x9c\xf9\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x1c\x02\x00\x88\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x28\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x00\x08\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x07\x00\x00\x00\x00\x00\xa2\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x17\x7f\x70\x00\x20\x45\x87\x20\x2e\xff\xff\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\xc0\x21\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf0\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xc7\x00\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x80\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x20\x04\xbf\x3f\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\x77\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x40\xf4\xfb\x13\x7e\x00\x00\x00\x00\x00\x20\x0a\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x07\x00\x00\x00\x00\x00\xa2\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x48\xf5\xfb\x13\x7e\x00\x00\x00\x00\x00\x20\x0a\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xf8\x01\x00\x00\x04\x01\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xf8\x01\x00\x00\x04\x01\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x1c\x02\x10\x84\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x08\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x80\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x04\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf4\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xc7\x00\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xc1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x1d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xc1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x1d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\xf7\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\x41\x01\x00\x04\x05\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf4\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xcf\x80\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x00\x00\x60\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\x77\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\xc0\x3f\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd0\x21\x88\xca\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x17\x7f\x70\x00\x20\x45\x87\x20\x2a\xfe\xff\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x00\x00\x10\x04\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x00\x00\x60\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x07\x00\x00\x02\x70\x08\xe2\x90\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x40\xf4\xfb\x13\x7e\x00\x00\x00\x00\x00\x00\x02\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf4\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xcf\x00\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x00\x08\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\xcd\x45\xf4\xff\x97\xff\x73\x10\x04\x41\x03\x20\x2a\x9c\xf9\xff\x7f\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x17\xd1\xff\x5f\xfe\xcf\x41\x10\x04\x0d\x80\xa8\x70\xe6\xff\xff\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x07\x00\x00\x00\x00\x00\x20\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x50\x87\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x35\x08\x40\x10\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x70\x08\x00\x20\x66\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x70\x08\x40\x10\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x80\x04\x1d\x82\xa8\xfc\xff\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x04\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x17\x7e\x00\x00\x00\x41\x02\x20\x2a\x9c\xf9\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xe1\x07\x00\x00\x10\x04\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x7f\xfc\xc1\x01\x00\x04\x0d\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\xff\xf1\x07\x07\x00\x10\x34\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x10\x34\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xe1\x07\x00\x00\x10\x04\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x40\xf4\xfb\x13\x7e\x00\x00\x10\x00\x00\x00\x02\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x07\x00\x00\x00\x40\x20\xa2\xc0\x11\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x00\x04\x05\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\xf7\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x17\x7f\x70\x00\x00\x41\x01\x20\x2a\x9c\xf9\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x00\x04\x05\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x10\x14\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf4\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0e\x7f\xcf\x00\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x00\x00\x60\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x40\xf4\xfb\x13\x7e\x00\x00\x00\x00\x00\x00\x02\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x07\x00\x00\x00\x00\x00\xa2\x80\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x07\x00\x00\x00\x00\x00\x20\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x40\xf0\xe3\x13\x7e\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xc1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x1d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf4\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xcf\x00\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x3d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x40\x70\xe0\x13\x7e\x00\x00\x00\x00\x00\x00\x00\x18\x40\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\xf7\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x21\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x3d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x3d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\xf7\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x17\x7f\x70\x00\x00\x41\x01\x20\x2a\x9c\xf9\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x00\x04\x05\x80\xa8\x70\xe6\xff\xe1\xf5\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x00\x04\x05\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x89\x2a\x67\xfe\x1f\x5e\x7f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x17\x7f\x70\x00\x00\x41\x03\x30\xaa\x9c\xf9\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xf8\x01\x00\x00\x04\x09\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd0\x21\x88\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x00\x04\x05\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x4c\xff\x7f\xf1\x07\x07\x00\x10\x34\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd0\x21\x88\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x80\x04\x1d\x82\xa8\xfc\xff\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf4\xfb\x13\x7e\x00\x00\x00\x00\x00\x20\x6a\x9c\xf9\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x37\x5f\xf5\xff\x5f\xfe\xef\x67\x10\x04\x0d\x80\xa8\x70\xe6\xff\xff\xf5\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf0\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xc7\x00\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xc1\x8f\x4f\xf8\x01\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x10\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x70\x08\x00\x20\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x07\x00\x00\x00\x00\x00\xa2\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x1c\x02\x00\x88\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x17\x7f\x70\x00\x00\x41\x01\x20\x2a\x9c\xf9\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x80\x04\x1d\x82\xa8\xf8\xff\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xc1\x8f\x4f\xf8\x01\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x10\x14\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf0\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xc7\x00\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x0d\x02\x00\x80\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xc1\x8f\x4f\xf8\x01\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\xf7\x0c\x08\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x00\x08\x20\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x40\xf4\xfb\x13\x7e\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\xf7\x0c\x08\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x40\xf4\xfb\x13\x7e\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x10\x34\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x80\x28\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x07\x00\x00\x00\x00\x00\xa2\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x80\x28\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xe1\x07\x00\x00\x10\x04\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xdf\x7c\xd5\xff\x7f\xf9\xbf\x9f\x41\x10\x34\x00\xa2\xc2\x99\xff\xff\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x17\x7f\x70\x00\x00\x41\x01\x20\x2a\x9c\xf9\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x07\x00\x00\x00\x00\x00\x20\x80\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x40\xf4\xfb\x13\x7e\x00\x00\x00\x00\x00\x00\x02\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x3d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x07\x00\x00\x00\x00\x00\x20\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\xf7\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x3d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x40\xf0\xe3\x13\x7e\x00\x00\x00\x10\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\x77\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf4\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xcf\x80\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x3d\x03\x02\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x3d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xc1\x8f\x4f\xf8\x01\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x3d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf4\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xcf\x00\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x5c\x44\xff\x7f\xf9\x3f\x07\x41\x10\x34\x00\xa2\xc2\x99\xff\xff\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\xf7\x0c\x08\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\x77\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf4\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xcf\x80\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x1d\x02\x00\x88\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x00\x04\x05\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x17\x7f\x70\x00\x00\x41\x01\x20\x2a\x9c\xf9\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x88\x2a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x7f\xfc\xc1\x01\x00\x04\x0d\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x00\x04\x05\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x10\x34\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x12\x74\x08\xa2\xe2\xff\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x04\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x3d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x07\x3e\xe1\x07\x00\x00\x00\x00\x00\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x00\x04\x05\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x10\x34\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x31\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\xc4\xf4\xff\x17\x7f\x70\x00\x00\x41\x03\x20\x2a\x9c\xf9\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x00\x04\x05\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf4\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xcf\x80\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x3d\x03\x02\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\x77\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x60\x00\x00\x00\x00\x00\x00\x20\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x3d\x03\x02\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x10\x14\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\xcd\x45\xf5\xff\x97\xff\x73\x10\x04\x41\x03\x20\x2a\x9c\xf9\xff\x7f\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x35\x17\xd5\xff\x5f\xfe\xcf\x41\x10\x04\x0d\x80\xa8\x70\xe6\xff\xff\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\xcd\x55\xf5\xff\x97\xff\x73\x10\x04\x41\x03\x20\x2a\x9c\xf9\xff\x7f\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x34\x57\xd5\xff\x5f\xfe\xcf\x41\x10\x04\x0d\x80\xa8\x70\xe6\xff\xff\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x3f\x3e\xe1\x07\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf0\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xc7\x00\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x3d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x07\x00\x00\x00\x00\x00\x20\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xd1\xef\x4f\xf8\x01\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x70\x08\x00\x20\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x17\x7f\x70\x00\x00\x41\x01\x20\x2a\x9c\xf9\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\xcd\x45\xf4\xff\x97\xff\x73\x10\x04\x41\x03\x20\x2a\x9c\xf9\xff\x7f\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x17\xd1\xff\x5f\xfe\xcf\x41\x10\x04\x0d\x80\xa8\x70\xe6\xff\xff\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf4\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xcf\x80\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x40\xf0\xe3\x13\x7e\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x10\x14\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x81\x10\xfd\xfa\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x0a\x10\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x28\x40\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xe2\xe0\xf7\x0c\x08\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x04\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\x77\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x3d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x0d\x44\xf4\xff\x17\x7f\x70\x00\x00\x41\x01\x20\x2a\x9c\xf9\x7f\x78\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x34\x10\xd1\xff\x5f\xfc\xc1\x01\x00\x04\x05\x80\xa8\x70\xe6\xff\xe1\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x07\x3e\xe1\x07\x00\x00\x00\x00\x00\x00\x80\x01\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x52\xfd\xfe\xa4\x1f\x00\x00\x00\x00\x00\x80\x40\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x28\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x74\x08\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x04\x07\x3e\xe1\x07\x00\x00\x00\x00\x00\x00\x80\x01\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x10\x14\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x40\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x40\xf0\xe3\x13\x7e\x00\x00\x00\x00\x00\x00\x02\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x5b\x73\x51\xfd\xff\xe5\xff\x1c\x04\x41\xd0\x00\x88\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\x77\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x87\x00\x00\x62\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xc1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x1d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x34\x57\xd5\xff\x5f\xfe\xcf\x41\x10\x04\x0d\x80\xa8\x70\xe6\xff\xff\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\x77\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x0c\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf4\xe3\x13\x7e\x00\x06\x30\x40\x87\x23\x0a\x7e\xc7\x00\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xc1\x8f\x4f\xf8\x01\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\xf7\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x44\xbf\x3f\xe1\x07\x00\x00\x00\x00\x00\x20\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\x77\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\xf7\x0c\x08\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\xf7\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x0a\x10\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf0\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xc7\x00\x01\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xc1\x8f\x4f\xf8\x01\x18\x80\x00\x1d\x8e\x28\xf8\x1d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xd0\x40\x44\xff\x7f\xf1\x07\x07\x00\x10\x14\x00\xa2\xc2\x99\xff\x87\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x40\x10\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x54\xbf\x3f\xe1\x07\x00\x00\x01\x00\x00\x20\x80\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x40\xf0\xe3\x13\x7e\x00\x06\x20\x40\x87\x23\x0a\x7e\xc7\x00\x01\x8c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x10\x00\xd1\x8f\x4f\xf8\x01\x18\x80\x40\x1d\x8e\x38\xfc\x3d\x03\x00\x30\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x40\xf0\xe3\x13\x7e\x00\x00\x00\x00\x00\x00\x02\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x40\x00\x44\x3f\x3e\xe1\x07\x60\x00\x02\x74\x38\xa2\xe0\x77\x0c\x00\xc0\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\xc1\x8f\x4f\xf8\x01\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x40\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x40\x70\xe0\x13\x7e\x00\x00\x00\x00\x00\x00\x00\x38\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x50\xfd\xfe\x84\x1f\x00\x00\x04\x00\x00\x80\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x80\x54\xbf\x3f\xe9\x07\x00\x00\x00\x00\x00\x20\x80\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# {-# NOINLINE happyExpListPerState #-} happyExpListPerState st = token_strs_expected where token_strs = ["error","%dummy","%start_parseModule","%start_parseSignature","%start_parseImport","%start_parseStatement","%start_parseDeclaration","%start_parseExpression","%start_parsePattern","%start_parseTypeSignature","%start_parseStmt","%start_parseIdentifier","%start_parseType","%start_parseBackpack","%start_parseHeader","identifier","backpack","units","unit","unitid","msubsts","msubst","moduleid","pkgname","litpkgname_segment","litpkgname","mayberns","rns","rn","unitbody","unitdecls","unitdecl","signature","module","maybedocheader","missing_module_keyword","implicit_top","maybemodwarning","body","body2","top","top1","header","header_body","header_body2","header_top","header_top_importdecls","maybeexports","exportlist","exportlist1","expdoclist","exp_doc","export","export_subspec","qcnames","qcnames1","qcname_ext_w_wildcard","qcname_ext","qcname","semis1","semis","importdecls","importdecls_semi","importdecl","maybe_src","maybe_safe","maybe_pkg","optqualified","maybeas","maybeimpspec","impspec","prec","infix","ops","topdecls","topdecls_semi","topdecl","cl_decl","ty_decl","standalone_kind_sig","sks_vars","inst_decl","overlap_pragma","deriv_strategy_no_via","deriv_strategy_via","deriv_standalone_strategy","opt_injective_info","injectivity_cond","inj_varids","where_type_family","ty_fam_inst_eqn_list","ty_fam_inst_eqns","ty_fam_inst_eqn","at_decl_cls","opt_family","opt_instance","at_decl_inst","data_or_newtype","opt_kind_sig","opt_datafam_kind_sig","opt_tyfam_kind_sig","opt_at_kind_inj_sig","tycl_hdr","tycl_hdr_inst","capi_ctype","stand_alone_deriving","role_annot","maybe_roles","roles","role","pattern_synonym_decl","pattern_synonym_lhs","vars0","cvars1","where_decls","pattern_synonym_sig","decl_cls","decls_cls","decllist_cls","where_cls","decl_inst","decls_inst","decllist_inst","where_inst","decls","decllist","binds","wherebinds","rules","rule","rule_activation","rule_explicit_activation","rule_foralls","rule_vars","rule_var","warnings","warning","deprecations","deprecation","strings","stringlist","annotation","fdecl","callconv","safety","fspec","opt_sig","opt_tyconsig","sigtype","sigtypedoc","sig_vars","sigtypes1","unpackedness","forall_vis_flag","ktype","ktypedoc","ctype","ctypedoc","context","constr_context","type","typedoc","constr_btype","constr_tyapps","constr_tyapp","btype","tyapps","tyapp","atype","inst_type","deriv_types","comma_types0","comma_types1","bar_types2","tv_bndrs","tv_bndr","fds","fds1","fd","varids0","kind","gadt_constrlist","gadt_constrs","gadt_constr_with_doc","gadt_constr","constrs","constrs1","constr","forall","constr_stuff","fielddecls","fielddecls1","fielddecl","maybe_derivings","derivings","deriving","deriv_clause_types","docdecl","docdecld","decl_no_th","decl","rhs","gdrhs","gdrh","sigdecl","activation","explicit_activation","quasiquote","exp","infixexp","infixexp_top","exp10_top","exp10","optSemi","scc_annot","hpc_annot","fexp","aexp","aexp1","aexp2","splice_exp","splice_untyped","splice_typed","cmdargs","acmd","cvtopbody","cvtopdecls0","texp","tup_exprs","commas_tup_tail","tup_tail","list","lexps","flattenedpquals","pquals","squals","transformqual","guardquals","guardquals1","altslist","alts","alts1","alt","alt_rhs","ralt","gdpats","ifgdpats","gdpat","pat","bindpat","apat","apats","stmtlist","stmts","maybe_stmt","e_stmt","stmt","qual","fbinds","fbinds1","fbind","dbinds","dbind","ipvar","overloaded_label","name_boolformula_opt","name_boolformula","name_boolformula_and","name_boolformula_and_list","name_boolformula_atom","namelist","name_var","qcon_nowiredlist","qcon","gen_qcon","con","con_list","sysdcon_nolist","sysdcon","conop","qconop","gtycon","ntgtycon","oqtycon","oqtycon_no_varcon","qtyconop","qtycon","qtycondoc","tycon","qtyconsym","tyconsym","op","varop","qop","qopm","hole_op","qvarop","qvaropm","tyvar","tyvarop","tyvarid","var","qvar","qvarid","varid","qvarsym","qvarsym_no_minus","qvarsym1","varsym","varsym_no_minus","special_id","special_sym","qconid","conid","qconsym","consym","literal","close","modid","commas","bars0","bars","docnext","docprev","docnamed","docsection","moduleheader","maybe_docprev","maybe_docnext","'_'","'as'","'case'","'class'","'data'","'default'","'deriving'","'do'","'else'","'hiding'","'if'","'import'","'in'","'infix'","'infixl'","'infixr'","'instance'","'let'","'module'","'newtype'","'of'","'qualified'","'then'","'type'","'where'","'forall'","'foreign'","'export'","'label'","'dynamic'","'safe'","'interruptible'","'unsafe'","'mdo'","'family'","'role'","'stdcall'","'ccall'","'capi'","'prim'","'javascript'","'proc'","'rec'","'group'","'by'","'using'","'pattern'","'static'","'stock'","'anyclass'","'via'","'unit'","'signature'","'dependency'","'{-# INLINE'","'{-# SPECIALISE'","'{-# SPECIALISE_INLINE'","'{-# SOURCE'","'{-# RULES'","'{-# CORE'","'{-# SCC'","'{-# GENERATED'","'{-# DEPRECATED'","'{-# WARNING'","'{-# UNPACK'","'{-# NOUNPACK'","'{-# ANN'","'{-# MINIMAL'","'{-# CTYPE'","'{-# OVERLAPPING'","'{-# OVERLAPPABLE'","'{-# OVERLAPS'","'{-# INCOHERENT'","'{-# COMPLETE'","'#-}'","'..'","':'","'::'","'='","'\\\\'","'lcase'","'|'","'<-'","'->'","'@'","'~'","'=>'","'-'","'!'","'*'","'-<'","'>-'","'-<<'","'>>-'","'.'","TYPEAPP","'{'","'}'","vocurly","vccurly","'['","']'","'[:'","':]'","'('","')'","'(#'","'#)'","'(|'","'|)'","';'","','","'`'","SIMPLEQUOTE","VARID","CONID","VARSYM","CONSYM","QVARID","QCONID","QVARSYM","QCONSYM","IPDUPVARID","LABELVARID","CHAR","STRING","INTEGER","RATIONAL","PRIMCHAR","PRIMSTRING","PRIMINTEGER","PRIMWORD","PRIMFLOAT","PRIMDOUBLE","DOCNEXT","DOCPREV","DOCNAMED","DOCSECTION","'[|'","'[p|'","'[t|'","'[d|'","'|]'","'[||'","'||]'","TH_ID_SPLICE","'$('","TH_ID_TY_SPLICE","'$$('","TH_TY_QUOTE","TH_QUASIQUOTE","TH_QQUASIQUOTE","%eof"] bit_start = st * 482 bit_end = (st + 1) * 482 read_bit = readArrayBit happyExpList bits = map read_bit [bit_start..bit_end - 1] bits_indexed = zip bits [0..481] token_strs_expected = concatMap f bits_indexed f (False, _) = [] f (True, nr) = [token_strs !! nr] happyActOffsets :: HappyAddr happyActOffsets = HappyA# "\x45\x00\xe1\xff\x33\x01\x14\x25\xcc\x19\x34\x2c\x3c\x29\x4c\x23\x14\x25\xc5\x42\x13\x3a\x2a\x00\x40\x00\xc5\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x02\x00\x00\x00\x00\x68\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x23\x01\x23\x01\x00\x00\xde\x00\x5c\x01\x65\x01\x00\x00\x36\x04\x05\x41\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x4a\x00\x00\x00\x00\x00\x00\xa4\x01\xdc\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x41\x0e\x00\x1d\x35\x21\x33\xa0\x33\x5f\x45\x2a\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x2c\x00\x00\x00\x00\xd3\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x01\x47\x09\x16\x02\xc5\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x02\xbd\x16\x00\x00\x00\x00\x34\x2c\x34\x2c\x2c\x2f\x00\x00\x60\x02\x00\x00\x00\x00\x00\x00\x48\x02\x83\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x02\x00\x00\x00\x00\x34\x2c\x3f\x00\xac\x25\x59\x03\xca\x03\x8c\x31\xca\x03\x8c\x31\xef\x02\x24\x01\x05\x03\x94\x2e\x8c\x31\xc4\x2f\x8c\x31\x54\x20\x5c\x1d\xf4\x1d\x9a\x32\x2f\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x2c\x34\x2c\x13\x3a\xb6\x04\x34\x2c\x00\x00\x34\x2c\xfb\x44\x57\x02\x00\x00\x07\x03\x80\x03\x00\x00\x5f\x03\x6c\x03\x00\x00\x00\x00\x00\x00\xf8\x04\x7e\x03\x2f\x03\x81\x00\x2f\x03\xc5\x45\xa7\x47\x7e\x03\x8c\x1e\x00\x00\x13\x03\x8c\x31\x13\x03\x13\x03\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x07\x00\x00\x00\x00\x00\x00\x00\x00\x05\x41\xd0\x03\xb7\x03\xbd\x02\x9f\x04\x00\x00\x9c\x35\xf9\x00\xe2\x47\xce\x03\x0f\x48\x0f\x48\x7a\x47\x8c\x31\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x03\x00\x00\xcb\x03\x3c\x04\xd4\x03\x56\x04\xf7\x03\x88\x04\x00\x00\x00\x00\x00\x00\x4b\x04\x60\x04\x59\x00\x8f\x02\x8f\x02\xa8\x04\x8d\x04\x58\x04\x8c\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x31\x7b\x04\x0a\x07\x47\x01\x00\x00\x80\x00\xa6\x04\x53\x01\x00\x00\x80\x00\x54\x01\x00\x00\x90\x04\xab\x02\x0d\x49\xcc\x04\x43\x01\x37\x01\x00\x00\x1a\x04\x1a\x04\x5d\x00\xce\x04\xd4\x04\xd0\x00\x0d\x3d\x05\x41\x52\x03\x13\x3a\xe4\x04\xf0\x04\xfc\x04\x0d\x05\x00\x00\x30\x05\x00\x00\x00\x00\x00\x00\x05\x41\x13\x3a\x05\x41\x0c\x05\x0e\x05\x00\x00\x58\x04\x00\x00\xfc\x2d\x00\x00\x00\x00\x1b\x36\x8f\x43\x05\x41\x26\x05\x00\x05\x00\x00\x22\x05\xbd\x16\x96\x02\x1e\x05\x00\x00\x34\x2c\x00\x00\x00\x00\x00\x00\x49\x05\x4f\x05\x5e\x05\x64\x05\x24\x1f\xec\x20\x00\x00\xc4\x2f\x00\x00\x00\x00\x8f\x43\x1c\x05\x41\x05\x8b\x05\x00\x00\x8c\x05\x00\x00\x89\x05\x00\x00\xf2\x45\x31\x00\xc5\x45\x00\x00\xb7\x00\xc5\x45\x13\x3a\xc5\x45\x00\x00\xd6\x05\xc4\x1c\xc4\x1c\x53\x49\x9a\x36\x3b\x04\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x05\x89\x09\xc6\x02\xdc\x05\x9d\x05\xa5\x05\x00\x00\x00\x00\xcf\x05\x65\x04\xdf\x05\x00\x00\x00\x00\x70\x0b\x00\x00\x00\x00\xb2\x01\xf9\x05\x00\x00\x00\x00\xbc\x1f\x00\x00\xff\x05\xf4\x01\x0a\x06\x04\x06\x00\x00\x00\x00\x5c\x30\x00\x00\x00\x00\xf4\x30\x16\x05\x8c\x31\x09\x06\x3e\x06\x40\x06\x41\x06\x00\x00\x00\x00\x44\x26\x44\x26\x28\x06\x00\x00\x87\x06\x2e\x06\x57\x00\x00\x00\x00\x00\xd4\x29\x4c\x06\x00\x00\x8a\x06\x8c\x31\x34\x2c\x8c\x45\x00\x00\x84\x41\x00\x00\x00\x00\x34\x2c\x13\x3a\x34\x2c\x34\x2c\x34\x2c\x34\x2c\x2f\x06\x30\x06\x2d\x03\x38\x06\x39\x06\x9b\x01\x3a\x06\x3b\x06\x3c\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x3a\x1f\x34\x28\x45\x36\x06\x37\x06\x3c\x01\x3d\x06\x3f\x06\x88\x03\x00\x00\xfb\x02\x42\x06\x2c\x03\x45\x06\x00\x00\xba\x01\x00\x00\x48\x06\x00\x00\xbe\x01\x00\x00\x53\x49\x00\x00\x97\x44\x00\x00\x00\x00\x4f\x00\x07\x4a\x00\x00\xc7\x32\x05\x41\x00\x00\x13\x3a\x13\x3a\x13\x3a\xb0\x00\x00\x00\x94\x0f\x54\x00\x00\x00\x4a\x06\x00\x00\x9d\x03\x9d\x03\x15\x03\x00\x00\x00\x00\x15\x03\x00\x00\x00\x00\xa2\x06\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x06\x98\x06\x5f\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x06\x00\x00\x13\x3a\x00\x00\x00\x00\x3f\x01\x00\x00\x34\x03\x50\x06\x00\x00\x00\x00\x13\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x3a\x00\x00\x00\x00\x00\x00\x13\x3a\x13\x3a\x00\x00\x00\x00\x52\x06\x51\x06\x5a\x06\x61\x06\x62\x06\x63\x06\x64\x06\x68\x06\x70\x06\x71\x06\x72\x06\x73\x06\x7b\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x06\x00\x00\x77\x06\x9a\x06\x00\x00\x00\x00\x00\x00\x16\x05\x23\x02\x96\x06\x80\x06\x00\x00\x00\x00\x00\x00\xdc\x06\x00\x00\x34\x2c\x34\x2c\x61\x00\x00\x00\xe3\x00\x34\x2c\x00\x00\x00\x00\xa8\x06\x00\x00\x00\x00\x7c\x24\x34\x19\xf4\x30\xa5\x06\xe4\x23\x00\x00\x34\x2c\xdc\x26\xe4\x23\x00\x00\x8c\x06\x00\x00\x00\x00\x00\x00\x84\x21\xab\x06\x00\x00\x13\x32\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x19\x59\x00\x9c\x06\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x06\x00\x00\x9d\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x48\x00\x00\x00\x00\xb3\x06\x00\x00\x62\x00\xbe\x06\x05\x41\x07\x4a\x87\x01\x6a\x00\x00\x00\x00\x00\x79\x0e\x00\x00\x1c\x22\xb4\x22\x68\x01\x00\x00\xc0\x06\x56\x01\x3d\x02\xc5\x06\x00\x00\xc8\x06\xc6\x06\xa0\x06\xaf\x06\xd0\x06\x00\x00\xd5\x06\xb7\x06\xb9\x06\x4a\x48\x4a\x48\x00\x00\xd9\x06\xf3\x03\x7e\x03\xb4\x06\xb5\x06\xd6\x06\x00\x00\xbc\x06\x5d\x0c\x00\x00\x00\x00\x34\x2c\xe4\x23\x3c\x00\x8c\x3d\x1d\x00\x00\x00\xd2\x06\x97\x01\xdd\x06\x07\x4a\x00\x00\x00\x00\x58\x00\x00\x00\x34\x2c\xd4\x29\x05\x41\x0e\x07\x00\x00\xdf\x06\xca\x06\x00\x00\x9f\x04\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x07\x5c\x00\x19\x06\x3c\x03\x00\x00\xe8\x06\x07\x4a\x9a\x36\x9a\x36\x52\x03\xa5\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x42\x40\x32\xcd\x06\x9a\x36\x00\x00\x40\x32\x53\x49\x6c\x2a\x6c\x2a\x1f\x07\x00\x00\x3b\x01\x00\x00\xc7\x06\x00\x00\xcb\x06\x00\x00\x00\x00\x77\x48\x77\x48\x00\x00\x00\x00\x77\x48\x8c\x31\xef\x06\xfd\x06\x00\x00\x00\x00\x35\x07\x00\x00\xf8\x03\xf8\x03\x00\x00\x00\x00\x00\x00\x43\x07\x00\x00\xe3\x06\x00\x00\xcc\x19\xff\x06\x80\x00\x80\x00\xff\x06\xec\x06\x00\x00\x00\x00\x00\x00\x1b\x07\x00\x00\x00\x00\x00\x00\x69\x02\x00\x00\x00\x00\x79\x01\x05\x07\x34\x2c\x80\x49\x57\x07\x00\x00\x0f\x07\x02\x07\x00\x00\x00\x00\x08\x07\x00\x00\x35\x42\x00\x00\x25\x07\x28\x07\x2e\x07\x2f\x07\xad\x49\x00\x00\x00\x00\x00\x00\x30\x07\x00\x00\x2a\x07\x13\x3a\x38\x07\x13\x3a\x07\x4a\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x05\x13\x3a\x00\x00\x00\x00\x13\x3a\x1d\x07\x00\x00\xa8\x46\x00\x00\x55\x05\x00\x00\x3c\x07\x75\x07\x00\x00\x00\x00\x68\x05\x4f\x00\x05\x41\x3d\x07\x19\x37\x19\x37\x77\x07\x8d\x07\x46\x07\x13\x3a\x1d\x00\x3f\x07\x00\x00\x34\x4a\x00\x00\x55\x07\x00\x00\x00\x00\x50\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x3a\x00\x00\x40\x07\x13\x3a\x00\x00\x00\x00\x00\x00\x32\x07\x00\x00\xc4\x1c\x34\x2c\x00\x00\x00\x00\x98\x37\xad\x49\x4f\x00\x4f\x07\x05\x41\x98\x37\x98\x37\x3b\x04\x00\x00\x00\x00\x44\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x02\x00\x00\x00\x00\x00\x00\xaa\x01\x00\x00\x00\x00\xcc\x2c\x00\x00\x00\x00\x64\x2d\x00\x00\x59\x00\x48\x07\x00\x00\x85\x05\x00\x00\x74\x27\x58\x07\x00\x00\x33\x07\x00\x00\x00\x00\x0c\x28\x00\x00\x00\x00\x00\x00\x64\x2d\x04\x2b\x64\x2d\x00\x00\x00\x00\xe4\x23\x8c\x45\x00\x00\x00\x00\x00\x00\x13\x3a\x00\x00\x00\x00\x6a\x07\x00\x00\x53\x07\x5e\x07\x36\x07\x13\x3a\x00\x00\x13\x3a\xdf\x48\x7e\x05\x00\x00\x5c\x07\x5c\x07\xad\x07\xd6\x03\xb0\x07\x00\x00\x30\x00\x30\x00\x00\x00\x60\x07\x45\x07\x00\x00\x47\x07\x00\x00\x00\x00\x61\x07\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x07\x00\x00\x78\x07\x00\x00\x00\x00\x00\x00\xb6\x07\x81\x07\x64\x2d\x9c\x2b\x00\x00\x00\x00\xa7\x07\x27\x04\xa4\x28\xa4\x28\x64\x2d\x68\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x37\x98\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x07\x6d\x07\x93\x07\x00\x00\x94\x07\x00\x00\x82\x07\x05\x41\xc7\x07\xdd\x07\x00\x00\x65\x07\x00\x00\xe0\x07\x00\x00\x4c\x00\xe0\x07\x99\x05\x98\x37\x85\x04\x17\x38\x00\x00\x00\x00\x64\x2d\x00\x00\x64\x1a\x64\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x1a\xfc\x1a\x00\x00\x00\x00\x00\x00\xe1\x07\xc7\x32\x00\x00\x05\x41\x13\x3a\xb2\x07\x96\x38\x00\x00\x00\x00\xad\x49\x00\x00\x00\x00\xaa\x05\xa2\x07\xda\x49\x00\x00\x40\x32\x09\x0b\x00\x00\x00\x00\xa0\x07\x00\x00\x8c\x07\x00\x00\x9d\x03\x00\x00\xf0\x07\xc0\x07\xc5\x07\xf8\x07\xa4\x07\x00\x00\xb0\x05\x00\x00\x00\x00\xb0\x05\xfe\x07\x00\x00\x00\x00\x64\x2d\xc8\x07\x00\x00\xfd\x07\xc4\x1c\xc4\x1c\x00\x00\x00\x00\x96\x38\x00\x00\xca\x07\x00\x00\xc6\x07\x00\x00\xca\x05\x00\x00\x0a\x08\x00\x00\x6a\x01\x00\x00\x00\x00\x0a\x08\x40\x02\x00\x00\xc7\x32\x00\x00\x00\x00\x8f\x01\x00\x00\xf9\x07\x64\x2d\x15\x39\x75\x02\x00\x00\x00\x00\x00\x00\xf0\x05\xf0\x05\x00\x00\x83\x03\xea\x07\x97\x07\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x34\x00\x00\x25\x00\x00\x00\x08\x08\x00\x00\x1e\x08\x00\x00\x05\x41\x00\x00\x00\x00\x13\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x2d\x64\x2d\x64\x2d\x00\x00\x00\x00\x00\x00\xa9\x07\x26\x08\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x01\x00\x00\x7b\x00\x62\x42\xc4\x02\xda\x05\xd1\x07\x00\x00\xbc\x43\xd6\x03\x00\x00\x00\x00\x00\x00\xda\x05\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x03\xc9\x07\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x03\xb8\x03\x61\x04\xa9\x0a\xd6\x03\x00\x00\x00\x00\x00\x00\x43\x00\xd4\x07\xcb\x07\x8f\x42\x02\x08\x9d\x03\x00\x00\x64\x2d\xf4\x07\x00\x00\x00\x00\x15\x08\x00\x00\xee\x07\x00\x00\x00\x00\x0b\x3e\x34\x4a\xfa\x07\xd6\x07\xe5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\xdc\x07\x00\x00\x05\x08\xe7\x07\xf5\x07\x00\x00\x94\x1b\x00\x00\x6d\x04\x8a\x3e\x05\x41\x37\x18\x05\x41\x00\x00\x00\x00\x00\x00\x2c\x1c\x8a\x3e\x00\x00\x00\x00\x16\x08\x00\x00\x92\x3a\x11\x3b\xc7\x32\x90\x3b\x00\x00\xf0\x01\xd6\x02\xda\x49\x90\x3b\x00\x00\x58\x08\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x08\x4b\x00\x9d\x03\xf2\x07\x07\x08\x00\x00\x00\x00\x00\x00\xc7\x32\x00\x00\xff\x01\x00\x00\x59\x00\xf5\x02\x06\x08\x09\x3f\x00\x00\x00\x00\x11\x08\x94\x39\x8e\x04\x00\x00\x00\x00\x90\x3b\x0f\x3c\x00\x00\x00\x00\x7e\x03\x94\x39\xf0\x05\x00\x00\x00\x00\x94\x39\xe8\x07\x14\x08\x12\x08\x00\x00\x8e\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x05\x41\x64\x2d\xf7\x07\x00\x00\x26\x02\x9d\x03\x00\x00\x9d\x03\x00\x00\x9d\x03\x00\x00\x00\x00\x0d\x08\x0e\x08\x13\x08\x19\x08\x00\x00\x98\x02\x00\x00\x00\x00\x00\x00\x5d\x44\x0b\x08\x00\x00\x00\x00\xd6\x03\x1c\x08\x0c\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x03\x00\x00\x7e\x08\xc7\x02\x00\x00\x3d\x00\x26\x02\x21\x08\x33\x08\x00\x00\x00\x00\x00\x00\x88\x3f\x00\x00\x04\x08\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x08\x3b\x08\x21\x33\x00\x00\x00\x00\x34\x4a\x00\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x07\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x08\xd6\x03\x00\x00\x00\x00\x2a\x08\xd6\x03\x00\x00\x76\x08\x89\x08\x47\x08\xc7\x32\x00\x00\x86\x40\x00\x00\x00\x00\x7d\x08\x2e\x08\x50\x09\x9d\x03\x00\x00\x9d\x03\x9d\x03\x00\x00\x9d\x03\x5d\x44\x00\x00\x00\x00\xf5\x43\x00\x00\x00\x00\x00\x00\x00\x00\x24\x08\x4d\x08\x00\x00\x9d\x03\x82\x08\xe6\x05\x00\x00\x00\x00\x95\x08\x35\x08\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x05\x2c\x08\x9d\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# happyGotoOffsets :: HappyAddr happyGotoOffsets = HappyA# "\x05\x00\xfe\xff\x72\x08\x01\x4e\x4a\x01\x95\x52\xbd\x51\xd0\xff\x49\x4e\x01\x00\x81\x12\x71\x00\x07\x00\x92\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x04\x00\x00\x00\x00\x00\x00\x90\x02\x00\x00\x00\x00\x00\x00\xba\x02\x00\x00\x00\x00\xf6\x04\x02\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x04\x2c\x00\x9e\x12\x34\x0e\x14\x0e\x86\x02\x35\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x73\x07\x24\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x0b\x00\x00\x00\x00\x25\x53\x6d\x53\xfc\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x53\xb7\x07\x55\x50\x40\x05\xbc\x07\xdd\x35\xbd\x07\x5c\x36\x00\x00\x00\x00\x00\x00\x24\x13\xdb\x36\x10\x14\x5a\x37\x01\x4a\x79\x45\x5f\x46\x50\x3c\x4b\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x53\x95\x5b\xbb\x12\xda\x07\x45\x54\x00\x00\x8d\x54\x69\x04\x75\x08\x00\x00\x00\x00\xf0\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x05\xa1\x01\x06\x05\x31\x05\x37\x05\x3a\x03\xf7\x06\x47\x02\xec\x45\x00\x00\x00\x00\xd9\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x01\x00\x00\x00\x00\x00\x00\x00\x00\x57\x03\x00\x00\x00\x00\xfd\x05\x6c\x08\x00\x00\x1a\x01\x31\x08\x94\x00\xdb\x05\x81\x02\x1d\x01\xd1\x05\xd7\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x08\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x01\x00\x00\x21\x02\x00\x00\x9b\x02\x86\x07\x87\x07\x88\x07\x83\x08\x00\x00\x94\x04\x56\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x39\xb4\x07\xe2\x04\x00\x00\x00\x00\x42\x08\x00\x00\x00\x00\x00\x00\x45\x08\x00\x00\x00\x00\xdd\x05\x00\x00\xc0\xff\x00\x00\xb9\x00\xfe\x02\x00\x00\x46\x08\x48\x08\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x04\x44\x16\x7d\x03\xe9\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x16\xa9\x10\x78\x16\x28\x08\x00\x00\x00\x00\xb3\x04\x00\x00\x60\x34\x00\x00\x00\x00\x56\x08\x24\x03\xb1\x07\x6e\x08\x00\x00\x00\x00\x00\x00\xdd\x0c\x8c\xff\x00\x00\x00\x00\xdd\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x4a\x4b\x4b\x00\x00\x10\x14\x00\x00\x00\x00\xe6\x03\x00\x00\x4c\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x05\x00\x00\x03\x04\x00\x00\x00\x00\x06\x04\x0b\x0f\x23\x04\x00\x00\x00\x00\x08\x03\x50\x03\xb7\xff\x7c\x08\xeb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x01\x9a\x07\x00\x00\x00\x00\x00\x00\x0d\x00\x11\x00\x00\x00\x12\x0e\x00\x00\x00\x00\x00\x00\x0c\x04\xfb\x07\x00\x00\x8c\xff\x00\x00\x00\x00\x00\x00\x6f\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x3a\x00\x00\x00\x00\x7b\x09\xf1\x07\xd3\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x4e\xd9\x4e\x00\x00\x00\x00\x00\x00\x10\x08\x7f\xff\x00\x00\x00\x00\x26\x4f\x72\x05\x00\x00\x00\x00\x52\x3b\xd5\x54\x4f\x02\x00\x00\x2d\x05\x00\x00\x00\x00\xb1\x5c\x8c\x10\x1d\x55\x65\x55\xad\x55\xf5\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x10\xee\x0d\x75\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x02\x00\x00\xac\x00\x00\x00\xb1\x04\x00\x00\x00\x00\x4a\x08\x55\x01\x00\x00\x8a\xff\xdd\x16\x00\x00\x45\x15\x62\x15\x50\x13\x00\x00\x00\x00\x16\x00\xb3\x07\x00\x00\xda\x01\x00\x00\xa6\x07\xaf\x07\xca\x08\x00\x00\x00\x00\xd0\x08\x00\x00\x00\x00\xb9\x08\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x15\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x03\x00\x00\x00\x00\x00\x00\xe3\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x11\x00\x00\x00\x00\x00\x00\x95\x11\xb2\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x08\x03\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x56\x85\x56\xc4\x07\x00\x00\x00\x00\xcd\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x4f\xb7\x49\x5e\x35\x00\x00\xb9\x4b\x00\x00\x15\x57\x71\x4d\x27\x4c\x00\x00\x8f\xff\x00\x00\x00\x00\x00\x00\xdd\x4a\x00\x00\x00\x00\xc4\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x92\x01\xcd\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x02\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x07\x00\x00\x1e\x18\x90\x01\x00\x00\xce\x07\x00\x00\x00\x00\x78\x01\x00\x00\x00\x00\x00\x00\xd0\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x06\xa0\x04\x00\x00\x00\x00\xb8\x02\x5c\x02\x00\x00\x00\x00\x25\x05\x00\x00\x00\x00\x12\x0e\x00\x00\x00\x00\xb1\x5c\x95\x4c\x00\x00\x0f\x08\xb0\xff\x00\x00\x00\x00\xc1\x07\x00\x00\x99\x01\x00\x00\x00\x00\x06\x00\x00\x00\x5d\x57\xc0\x4f\xf7\x16\x8e\x08\x1e\x04\xa4\x08\x00\x00\x00\x00\xb6\x08\x00\x00\x00\x00\x00\x00\x00\x00\x93\x08\x77\x05\x4a\x05\xab\x08\x00\x00\x00\x00\x9d\x01\x32\x0c\x4f\x0c\x02\x04\xc1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xff\xdc\x02\xd7\x07\xbe\x08\x00\x00\xd4\xff\x51\x00\x05\x52\x4d\x52\x8f\x08\x00\x00\x00\x00\x00\x00\x91\x08\x00\x00\x8a\x08\x00\x00\x00\x00\xc0\x00\xd3\x07\x00\x00\x00\x00\xdc\x00\xd1\x3b\x00\x00\x00\x00\x00\x00\x00\x00\xd2\x08\x00\x00\xf2\x08\xf3\x08\x00\x00\x00\x00\x00\x00\xe8\x02\x00\x00\xe0\x08\x00\x00\x92\x01\xed\x08\x94\x08\x9b\x08\xef\x08\xde\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x5c\xe5\xff\xb5\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x13\xd5\x08\x8a\x13\x56\x00\x00\x00\xbb\x08\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x08\xa0\x0f\x00\x00\x00\x00\xa7\x13\x00\x00\x00\x00\x4b\x02\x00\x00\xbc\x08\x00\x00\x00\x00\xb7\x08\x00\x00\x00\x00\xf2\x05\x9c\x08\x11\x17\x00\x00\x28\x0b\x45\x0b\x7f\x08\x33\x05\x00\x00\x3c\x14\xbf\xff\x00\x00\x00\x00\xe4\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x0f\x00\x00\x00\x00\xda\x0f\x00\x00\x00\x00\x00\x00\x6b\x05\x00\x00\xcf\x06\xa5\x57\x00\x00\x00\x00\x1c\x09\xa7\x03\x9e\x08\x00\x00\x24\x17\x6c\x0c\x02\x0d\x0e\x03\x00\x00\x00\x00\xfd\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x57\x00\x00\x00\x00\x35\x58\x00\x00\x01\x08\x00\x00\x00\x00\xbd\x04\x00\x00\x0d\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x50\x00\x00\x00\x00\x00\x00\x7d\x58\x2d\x51\xc5\x58\x00\x00\x00\x00\x03\x4d\xf6\x01\x00\x00\x00\x00\x00\x00\xcf\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x03\x14\x16\x00\x00\x59\x14\x22\x00\x24\x09\x00\x00\x17\x09\x18\x09\x00\x00\x15\x00\x00\x00\x00\x00\xfb\xff\xfd\xff\x00\x00\x00\x00\x71\x03\x00\x00\xa1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x08\x52\x08\x0d\x59\x75\x51\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x4d\xe5\x50\x55\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x0d\x3c\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x17\x9a\x08\x6a\x05\x00\x00\x84\x00\x00\x00\x8d\x08\x00\x00\x0c\x00\x6d\x05\x00\x00\x59\x0d\x00\x00\x62\x0b\x00\x00\x00\x00\x9d\x59\x00\x00\xeb\x03\x33\x04\x00\x00\x9f\x08\xc4\x05\x00\x00\x00\x00\x00\x00\x29\x02\x71\x02\x00\x00\x00\x00\x00\x00\xf8\x08\x1b\x00\x00\x00\xbd\x17\x76\x14\x00\x00\x5e\x09\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\xff\x00\x00\xeb\x02\x12\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x09\x00\x00\x00\x00\x2f\x09\x14\x09\x00\x00\x00\x00\xe5\x59\x00\x00\x00\x00\x00\x00\xcd\x05\x4e\x06\x00\x00\x00\x00\x84\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x01\x09\x00\x00\x2b\x08\x00\x00\x00\x00\x03\x09\x00\x00\x00\x00\x4b\x02\x00\x00\x00\x00\x2d\x08\x00\x00\x09\x09\x6d\x5c\x99\x06\x00\x00\x00\x00\x00\x00\x00\x00\x77\x02\xb1\x02\x00\x00\xdc\xff\x19\x09\x29\x08\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x0b\x00\x00\x42\x03\x00\x00\xaf\x08\x00\x00\x70\x05\x00\x00\x37\x0a\x00\x00\x00\x00\xf7\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x5a\x75\x5a\xbd\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x08\x00\x00\x00\x00\x26\x00\x00\x00\x43\x09\x00\x00\x00\x00\x55\x00\xe3\xff\x00\x00\x00\x00\x00\x00\x4e\x09\x00\x00\xe6\x02\xe7\x02\x00\x00\x27\x00\x3d\x09\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x08\x53\x04\xdb\x02\x84\x04\x2b\x00\x00\x00\x00\x00\x00\x00\x03\x00\x64\x09\x00\x00\x29\x00\x3f\x09\x4b\x08\x00\x00\x05\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x0a\x34\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x05\x00\x00\x25\x09\x18\x07\xd7\x17\x12\x0e\xea\x17\x00\x00\x00\x00\x00\x00\xca\x04\x52\x07\x00\x00\x00\x00\x27\x09\x00\x00\x24\x05\x31\x06\x46\x00\x93\x14\x00\x00\x62\x08\x00\x00\x20\x00\x31\x16\x00\x00\x5c\x09\x00\x00\x3a\x02\x5f\x02\x00\x00\x64\x08\x00\x00\x44\x06\x66\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x02\x00\x00\x65\x08\x00\x00\x68\x08\x00\x00\x00\x00\x22\x08\x00\x00\x00\x00\x46\x09\xca\x09\x48\x09\x00\x00\x00\x00\x28\x15\x64\x12\x00\x00\x00\x00\x2d\x01\x24\x0a\x39\x04\x00\x00\x00\x00\x15\x0c\x95\x03\x00\x00\x00\x00\x00\x00\x91\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x04\x18\x4d\x5b\x00\x00\x00\x00\x86\x09\x78\x08\x00\x00\xff\xff\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x01\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x09\x88\x09\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x0a\x00\x00\x98\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x0e\x00\x00\x00\x00\x52\x01\x00\x00\x00\x00\xc9\xff\x00\x00\x00\x00\x76\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x06\x09\x73\x05\x00\x00\x1c\x00\x00\x00\x91\x0a\x00\x00\x00\x00\x00\x00\x8d\x09\x1f\x00\x7a\x08\x00\x00\x02\x00\x8b\x08\x00\x00\xf5\xff\x5f\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x08\x00\x00\x99\x09\x00\x00\x00\x00\x76\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x09\x00\x00\x90\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# happyAdjustOffset :: Happy_GHC_Exts.Int# -> Happy_GHC_Exts.Int# happyAdjustOffset off = off happyDefActions :: HappyAddr happyDefActions = HappyA# "\xbe\xff\xbf\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\xfd\x00\x00\x00\x00\xbd\xff\xbe\xff\x00\x00\xf2\xff\x09\xfd\x06\xfd\x03\xfd\xf3\xfc\xf1\xfc\xf2\xfc\xff\xfc\xf0\xfc\xef\xfc\xee\xfc\x01\xfd\x00\xfd\x02\xfd\xfe\xfc\xfd\xfc\xed\xfc\xec\xfc\xeb\xfc\xea\xfc\xe9\xfc\xe8\xfc\xe7\xfc\xe6\xfc\xe5\xfc\xe4\xfc\xe2\xfc\xe3\xfc\x00\x00\x04\xfd\x05\xfd\x00\x00\x89\xff\x00\x00\xaf\xff\xc0\xff\x89\xff\xc1\xfc\x00\x00\x00\x00\x00\x00\x7a\xfe\x00\x00\x9e\xfe\x00\x00\x97\xfe\x90\xfe\x83\xfe\x82\xfe\x80\xfe\x6e\xfe\x6d\xfe\x00\x00\x79\xfe\x40\xfd\x7e\xfe\x3b\xfd\x31\xfd\x34\xfd\x2b\xfd\x78\xfe\x7d\xfe\x12\xfd\x0f\xfd\x65\xfe\x5a\xfe\x0d\xfd\x0c\xfd\x0e\xfd\x00\x00\x00\x00\x28\xfd\x24\xfd\x27\xfd\x26\xfd\x77\xfe\x25\xfd\x00\x00\xbd\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\xfd\x2e\xfd\x29\xfd\x2a\xfd\x32\xfd\x2c\xfd\x2d\xfd\x67\xfd\x66\xfe\x67\xfe\xc8\xfd\x00\x00\x0e\xfe\x0d\xfe\x00\x00\xf1\xff\x56\xfd\x49\xfd\x55\xfd\xef\xff\xf0\xff\x16\xfd\xfb\xfc\xfc\xfc\xf7\xfc\xf4\xfc\x54\xfd\xde\xfc\x45\xfd\xdb\xfc\xd8\xfc\xed\xff\xf6\xfc\xe1\xfc\xdf\xfc\xe0\xfc\x00\x00\x00\x00\x00\x00\x00\x00\xdc\xfc\xf5\xfc\xd9\xfc\xdd\xfc\xf8\xfc\xda\xfc\xcc\xfd\x74\xfd\x07\xfe\xfe\xfd\x06\xfe\x00\x00\x00\x00\xff\xfd\xf4\xfd\xe8\xfd\xe6\xfd\xd8\xfd\xd7\xfd\x00\x00\x00\x00\x7a\xfd\x77\xfd\xe3\xfd\xe2\xfd\xe4\xfd\xe5\xfd\xe1\xfd\xd9\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\xfd\xd7\xfc\xd6\xfc\xe0\xfd\xdf\xfd\xd3\xfc\xd2\xfc\xd5\xfc\xd4\xfc\xd1\xfc\xd0\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xfd\x00\x00\xd2\xfd\x76\xff\x1b\xfe\x00\x00\x00\x00\x04\xfe\x00\x00\x06\xfd\x74\xff\x73\xff\x72\xff\x00\x00\x00\x00\x12\xfe\x12\xfe\x12\xfe\x00\x00\x64\xfd\x00\x00\x00\x00\x88\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x6c\xff\x6b\xff\x6a\xff\x69\xff\x12\xff\x68\xff\x67\xff\x27\xfe\x61\xff\x26\xfe\x2f\xfe\x60\xff\x2a\xfe\x5f\xff\x2e\xfe\x2d\xfe\x2c\xfe\x2b\xfe\x00\x00\x26\xff\x00\x00\x44\xff\x4d\xff\x25\xff\x00\x00\x00\x00\x00\x00\xd9\xfe\xc3\xfe\xc8\xfe\x00\x00\x00\x00\xc5\xfc\xc4\xfc\xc3\xfc\xc2\xfc\x00\x00\x78\xfd\x00\x00\x83\xff\x00\x00\x00\x00\x00\x00\x00\x00\x89\xff\xc1\xff\x89\xff\x00\x00\x86\xff\x00\x00\x00\x00\x00\x00\x81\xff\x00\x00\x00\x00\x00\x00\x59\xfd\x50\xfd\x5a\xfd\x0b\xfd\x52\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xc9\xfe\x00\x00\x5c\xfd\x00\x00\xc4\xfe\x00\x00\x00\x00\xda\xfe\xd7\xfe\x00\x00\x4f\xfd\x00\x00\x00\x00\x00\x00\x65\xff\x00\x00\x00\x00\x00\x00\x00\x00\x90\xfe\x40\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\xff\x00\x00\x46\xff\x48\xff\x47\xff\x00\x00\x60\xfe\x00\x00\x57\xfe\x00\x00\x19\xff\x00\x00\x1c\xfd\x00\x00\x1b\xfd\x1d\xfd\x00\x00\x00\x00\x00\x00\x12\xff\x00\x00\x87\xfd\xbd\xfd\x07\xfe\x00\x00\x00\x00\x19\xfd\x00\x00\x18\xfd\x1a\xfd\x14\xfd\xf9\xfc\x00\x00\xfa\xfc\x45\xfd\x00\x00\x00\x00\xc6\xfc\xf6\xfc\x4d\xfd\xca\xfc\x00\x00\x4f\xfd\xaa\xfe\x00\x00\x65\xfd\x63\xfd\x61\xfd\x60\xfd\x5d\xfd\x00\x00\x00\x00\x00\x00\x11\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xfe\x00\x00\xe4\xfe\xe4\xfe\x00\x00\x00\x00\x00\x00\x75\xff\xd3\xfd\x43\xfd\xd4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\xff\x6d\xff\x00\x00\x00\x00\x00\x00\xd5\xfd\xd6\xfd\x00\x00\xc3\xfd\xe5\xfd\x00\x00\x00\x00\xf9\xfc\xfa\xfc\x00\x00\x4b\xfd\x00\x00\xb1\xfd\x00\x00\xb0\xfd\x48\xfd\x85\xfd\x02\xfe\xf2\xfd\x84\xfd\x81\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xfd\x76\xfd\x7b\xfd\x7b\xfd\x00\x00\xea\xfd\x73\xfd\xfb\xfd\x00\x00\xed\xfd\x8c\xfd\x00\x00\x00\x00\xeb\xfd\x00\x00\x00\x00\x00\x00\x71\xfd\xf7\xfd\x00\x00\x01\xfe\xfd\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\xfe\x58\xfd\x57\xfd\x7c\xfe\x7b\xfe\x69\xfe\x1f\xfd\x60\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x5f\xfe\x00\x00\x00\x00\x00\x00\x73\xfe\x00\x00\x34\xfd\x00\x00\x00\x00\x75\xfe\x00\x00\x3c\xfd\x00\x00\x3d\xfe\x3b\xfe\xbe\xfc\x00\x00\x7f\xfe\x00\x00\xa1\xfe\xa2\xfe\x00\x00\x5a\xfe\x59\xfe\x00\x00\x00\x00\x81\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xe7\xff\x00\x00\x00\x00\xac\xff\x86\xff\xab\xff\x00\x00\x00\x00\xba\xff\xcd\xfc\xcc\xfc\xba\xff\xaa\xff\xa8\xff\xa9\xff\x8a\xff\xeb\xff\xce\xfc\xcf\xfc\xe8\xff\x00\x00\xd7\xff\xdb\xff\xd8\xff\xda\xff\xd9\xff\xdc\xff\xea\xff\x50\xfe\x9d\xfe\x99\xfe\x8f\xfe\x98\xfe\x00\x00\x5b\xfe\x00\x00\x9f\xfe\xa0\xfe\x00\x00\xa5\xfe\x00\x00\x00\x00\x76\xfe\x70\xfe\x00\x00\x3d\xfd\x3f\xfd\xcb\xfc\x3a\xfd\x6f\xfe\x00\x00\x3e\xfd\x71\xfe\x72\xfe\x00\x00\x00\x00\x11\xfd\x33\xfd\x00\x00\x00\x00\x00\x00\x28\xfd\x27\xfd\x26\xfd\x77\xfe\x25\xfd\x29\xfd\x2a\xfd\x2d\xfd\x5f\xfe\x00\x00\x61\xfe\xc7\xfd\xec\xff\xee\xff\x4c\xfd\x53\xfd\x07\xfd\x4a\xfd\x44\xfd\x15\xfd\x08\xfe\x09\xfe\x0a\xfe\x0b\xfe\x0c\xfe\xa8\xfe\x05\xfe\xf6\xfd\x00\x00\x72\xfd\x6f\xfd\x6c\xfd\x6e\xfd\x75\xfd\xf3\xfd\x00\x00\x00\x00\x00\x00\x9d\xfd\x9b\xfd\x8d\xfd\x8a\xfd\x00\x00\xfc\xfd\x00\x00\x00\x00\x00\x00\x7c\xfd\x00\x00\x00\x00\xfa\xfd\xf9\xfd\x00\x00\x83\xfd\xef\xfd\x00\x00\x00\x00\x81\xfd\x00\x00\x00\x00\xda\xfd\xaf\xfd\x00\x00\x00\x00\x08\xfd\xb3\xfd\xb7\xfd\xdb\xfd\xb9\xfd\xb2\xfd\xb8\xfd\xdc\xfd\x00\x00\xd1\xfd\xce\xfd\xcf\xfd\xbe\xfd\xbf\xfd\x00\x00\x00\x00\xcd\xfd\xd0\xfd\xc5\xfd\x41\xfd\x00\x00\x42\xfd\x1c\xfe\x22\xfd\x70\xff\x23\xfd\x47\xfd\x21\xfd\x20\xfd\x00\x00\x1e\xfe\xa7\xfe\x00\x00\x93\xfe\x8e\xfe\x00\x00\x00\x00\x5a\xfe\x00\x00\x00\x00\x25\xfe\xe5\xfe\xac\xfe\x24\xfe\xca\xfd\xc9\xfd\x00\x00\x69\xfd\xe3\xfd\x00\x00\x00\x00\x00\x00\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\xfc\xc7\xfc\x08\xfd\xbb\xfd\xdd\xfd\xde\xfd\xbc\xfd\x00\x00\x00\x00\x00\x00\x24\xff\xab\xfe\x00\x00\x8e\xfe\x00\x00\x5a\xfe\x03\xfe\x28\xfe\xdd\xfe\x20\xfe\x00\x00\x00\x00\x00\x00\xf2\xfe\x52\xfe\x22\xff\x00\x00\x49\xff\x4d\xff\x4e\xff\x4f\xff\x51\xff\x50\xff\xe8\xfe\x0f\xff\x00\x00\x20\xff\x54\xff\x00\x00\x5a\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xb6\xfe\xb5\xfe\xb4\xfe\xb3\xfe\xb2\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x06\xff\x03\xff\x00\x00\x00\x00\x00\x00\xd0\xfe\xd6\xfe\x00\x00\x62\xff\xdb\xfe\xc2\xfe\xbd\xfe\xc1\xfe\x64\xff\xc5\xfe\x00\x00\xc7\xfe\x63\xff\xca\xfe\x00\x00\x00\x00\x00\x00\x29\xfe\x84\xff\x7d\xff\x82\xff\xba\xff\xba\xff\xb6\xff\xb5\xff\xb2\xff\x6d\xff\xb7\xff\x88\xff\xb3\xff\xb4\xff\xa6\xff\x00\x00\x00\x00\xa6\xff\x7f\xff\x7e\xff\xbc\xfe\xba\xfe\x00\x00\xcb\xfe\x5b\xfd\xc6\xfe\x00\x00\xbe\xfe\xdc\xfe\x00\x00\x00\x00\x00\x00\xce\xfe\x08\xff\x09\xff\x00\x00\x01\xff\x02\xff\xfd\xfe\x00\x00\x05\xff\x00\x00\xb8\xfe\x00\x00\xb0\xfe\xaf\xfe\xb1\xfe\x00\x00\xb7\xfe\x57\xff\x58\xff\x9c\xfe\x5d\xff\x00\x00\x00\x00\x43\xff\x00\x00\x00\x00\x10\xff\x0e\xff\x0d\xff\x0a\xff\x0b\xff\x55\xff\x00\x00\x00\x00\x66\xff\x59\xff\x00\x00\x56\xfe\x54\xfe\x00\x00\x5e\xff\x00\x00\x1a\xff\x00\x00\xdd\xfe\x22\xfe\x21\xfe\x00\x00\x00\x00\x00\x00\x8d\xfe\x00\x00\x00\x00\x4d\xfe\x39\xfe\x00\x00\x00\x00\x24\xff\x00\x00\x15\xff\x5a\xfe\x13\xff\x00\x00\xba\xfd\xb6\xfd\xc9\xfc\x17\xfd\x13\xfd\x4e\xfd\xa9\xfe\x1a\xfe\x62\xfd\x5f\xfd\x51\xfd\x5e\xfd\x17\xfe\x00\x00\x10\xfe\x00\x00\x00\x00\x14\xfe\x19\xfe\xe0\xfe\x6a\xfd\xe3\xfe\xe6\xfe\x00\x00\xdf\xfe\xe2\xfe\x00\x00\x00\x00\x00\x00\x8c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xc1\xfd\xc0\xfd\x6f\xff\xc2\xfd\xc4\xfd\xcb\xfd\xb5\xfd\xb4\xfd\xbd\xfd\xa9\xfd\xab\xfd\xa8\xfd\xa6\xfd\xa3\xfd\xa2\xfd\x00\x00\xad\xfd\xaa\xfd\x00\x00\x82\xfd\x00\x00\x96\xfd\x92\xfd\x00\x00\x97\xfd\x00\x00\x00\x00\x98\xfd\x00\x00\x00\xfe\x80\xfd\x7d\xfd\x7f\xfd\xe9\xfd\xf0\xfd\x00\x00\x00\x00\x00\x00\x8b\xfd\xec\xfd\x00\x00\x00\x00\xe7\xfd\x6a\xfe\x0a\xfd\x00\x00\x1e\xfd\x5e\xfe\x5d\xfe\x5c\xfe\x00\x00\x00\x00\xbf\xfc\x00\x00\x9a\xfe\x00\x00\x00\x00\x00\x00\xe9\xff\xa6\xff\xa6\xff\x00\x00\x9f\xff\x00\x00\xe6\xff\xbf\xff\xbf\xff\xd6\xff\x00\x00\xbf\xfc\xc0\xfc\xbd\xfc\x68\xfe\x74\xfe\x00\x00\x70\xfd\x6d\xfd\x89\xfd\x9c\xfd\xfb\xfd\x7e\xfd\x00\x00\x9a\xfd\x95\xfd\x91\xfd\xdd\xfe\x8e\xfd\x00\x00\x93\xfd\x99\xfd\xf1\xfd\xa1\xfd\xe8\xfc\x00\x00\x00\x00\xae\xfd\x6e\xff\x8b\xff\x71\xff\x95\xfe\x8b\xfe\x94\xfe\x00\x00\x00\x00\xa6\xfe\x1d\xfe\x68\xfd\xe7\xfe\x6b\xfd\x00\x00\xa4\xfe\x00\x00\x0f\xfe\x00\x00\x14\xff\x00\x00\x00\x00\x4d\xfe\x39\xfe\x23\xff\xbd\xfc\x5b\xff\x38\xfe\x36\xfe\x00\x00\x39\xfe\x00\x00\x00\x00\x94\xfe\x00\x00\xde\xfe\x23\xfe\x00\x00\xf3\xfe\xf6\xfe\xf6\xfe\x51\xfe\x52\xfe\x52\xfe\x21\xff\x11\xff\xe9\xfe\xec\xfe\xec\xfe\x0c\xff\x1e\xff\x1f\xff\x3e\xff\x00\x00\x33\xff\x00\x00\x00\x00\x00\x00\x00\x00\xb9\xfe\x46\xfd\x00\x00\x04\xff\x07\xff\x00\x00\x00\x00\xce\xfe\xcd\xfe\x00\x00\x00\x00\xd5\xfe\xd3\xfe\x00\x00\xc0\xfe\x00\x00\xbb\xfe\x00\x00\x80\xff\x00\x00\x00\x00\x00\x00\x00\x00\x87\xff\x8c\xff\x00\x00\xbc\xff\xbb\xff\x00\x00\x7d\xff\xbf\xfe\xd4\xfe\x00\x00\x00\x00\xcf\xfe\xd1\xfe\xe4\xfe\xe4\xfe\x00\xff\xad\xfe\x00\x00\x9b\xfe\x00\x00\x42\xff\x00\x00\x5c\xff\x00\x00\xf1\xfe\x2b\xff\xed\xfe\x00\x00\xf0\xfe\x26\xff\x2b\xff\x00\x00\x55\xfe\x53\xfe\xfc\xfe\xf7\xfe\x00\x00\xfb\xfe\x2d\xff\x00\x00\x00\x00\x00\x00\x1f\xfe\x96\xfe\x8a\xfe\x4a\xfe\x4a\xfe\x5a\xff\x00\x00\x35\xfe\x30\xfd\x32\xfe\x4a\xff\x4c\xff\x4b\xff\x00\x00\x37\xfe\x46\xfe\x44\xfe\x40\xfe\x53\xff\x39\xfe\x16\xff\x00\x00\x15\xfe\x16\xfe\x00\x00\x89\xfe\xac\xfd\xa5\xfd\xa4\xfd\xa7\xfd\x00\x00\x00\x00\x00\x00\x94\xfd\x8f\xfd\x90\xfd\x00\x00\x00\x00\x6b\xfe\x3c\xfe\x3a\xfe\x58\xfe\x00\x00\xca\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\xff\xa1\xff\x9f\xff\x9c\xff\x9d\xff\x9e\xff\x00\x00\xb0\xff\x89\xff\x89\xff\xa0\xff\x9f\xff\x98\xff\x90\xff\x8d\xff\x39\xfd\x8e\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9f\xff\xa7\xff\xb1\xff\xce\xff\xcb\xff\xd5\xff\xe5\xff\xe2\xfc\x83\xff\x00\x00\xcd\xff\x00\x00\x00\x00\xa0\xfd\x9f\xfd\x00\x00\xa3\xfe\x00\x00\x17\xff\x52\xff\x00\x00\x5a\xfe\x00\x00\x63\xfe\x00\x00\x31\xfe\x2f\xfd\x33\xfe\x34\xfe\x00\x00\x4b\xfe\x48\xfe\x00\x00\x00\x00\x00\x00\xf5\xfe\xf8\xfe\x2f\xff\x1d\xff\x00\x00\x00\x00\x00\x00\x00\x00\x2c\xff\xf4\xfe\xeb\xfe\xee\xfe\x00\x00\x2a\xff\xea\xfe\x12\xff\x3d\xff\x35\xff\x35\xff\x00\x00\x00\x00\xae\xfe\x00\x00\x00\x00\xce\xfe\x00\x00\xd8\xfe\x7b\xff\xc3\xff\x89\xff\x89\xff\xc2\xff\x00\x00\x00\x00\x79\xff\x00\x00\x00\x00\x00\x00\xff\xfe\xfe\xfe\x34\xff\x41\xff\x3f\xff\x00\x00\x36\xff\x00\x00\x00\x00\x00\x00\x00\x00\x29\xff\xef\xfe\x22\xff\x00\x00\x1d\xff\x2e\xff\x31\xff\x00\x00\x00\x00\xf9\xfe\x4f\xfe\x00\x00\x00\x00\x4a\xfe\x4e\xfe\x30\xfe\x00\x00\xbf\xfc\x00\x00\x00\x00\x91\xfe\x3f\xfe\x87\xfe\x85\xfe\x42\xfe\x84\xfe\x00\x00\x00\x00\x00\x00\xee\xfd\xc6\xff\x00\x00\xc4\xff\x00\x00\xc5\xff\x00\x00\xcc\xff\xa5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x99\xff\x00\x00\x8f\xff\x9a\xff\x9b\xff\x96\xff\xa2\xff\xad\xff\xae\xff\x9f\xff\x00\x00\x95\xff\x93\xff\x92\xff\x91\xff\x38\xfd\x37\xfd\x35\xfd\x36\xfd\x00\x00\xd1\xff\xcf\xff\x00\x00\xe1\xff\x00\x00\xc7\xff\xa6\xff\x00\x00\x9e\xfd\x18\xff\x86\xfe\x00\x00\x41\xfe\xbd\xfc\x62\xfe\x4c\xfe\x47\xfe\x49\xfe\x00\x00\x78\xfe\x00\x00\x1c\xff\x30\xff\x00\x00\xfa\xfe\x32\xff\x24\xff\x3a\xff\x3c\xff\x37\xff\x39\xff\x3b\xff\x40\xff\xd2\xfe\xcc\xfe\x7c\xff\x85\xff\x7a\xff\x00\x00\x9f\xff\xb9\xff\xb8\xff\x00\x00\x9f\xff\x38\xff\x4d\xfe\x39\xfe\x78\xfe\x00\x00\x45\xfe\x3f\xfe\x43\xfe\xf8\xfd\x00\x00\xa6\xff\x00\x00\x00\x00\xe4\xff\xe2\xff\x00\x00\xd4\xff\xd2\xff\x00\x00\x97\xff\xa3\xff\xa1\xff\x94\xff\xd3\xff\xd0\xff\xe3\xff\x00\x00\x00\x00\xe0\xff\x00\x00\x00\x00\x00\x00\x1b\xff\x28\xff\x39\xfe\x00\x00\x78\xff\x77\xff\x27\xff\xc8\xff\x00\x00\x00\x00\x00\x00\xdf\xff\xdd\xff\xde\xff\xc9\xff"# happyCheck :: HappyAddr happyCheck = HappyA# "\xff\xff\x00\x00\x0d\x00\x53\x00\x05\x00\x06\x00\x23\x00\x24\x00\x06\x00\x39\x00\x0f\x00\x10\x00\x0f\x00\x10\x00\x13\x00\x11\x00\x13\x00\x13\x00\x53\x00\x10\x00\x0c\x00\x0d\x00\x13\x00\x12\x00\x13\x00\x14\x00\x13\x00\x14\x00\x53\x00\x18\x00\x08\x00\x09\x00\x0a\x00\x61\x00\x1b\x00\x04\x00\x1d\x00\x3a\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x04\x00\x09\x00\x0a\x00\x04\x00\x08\x00\x09\x00\x0a\x00\x08\x00\x09\x00\x0a\x00\x64\x00\x61\x00\x21\x00\x22\x00\x23\x00\x24\x00\x21\x00\x22\x00\x23\x00\x24\x00\x87\x00\x21\x00\x22\x00\x23\x00\x24\x00\x82\x00\xac\x00\x22\x00\x23\x00\x24\x00\x3b\x00\x3c\x00\x23\x00\x24\x00\x3b\x00\x3c\x00\x23\x00\x24\x00\x44\x00\xb0\x00\xb1\x00\x13\x00\x00\x00\x0a\x00\x13\x00\x00\x00\x13\x00\x00\x00\xaa\x00\x76\x00\x77\x00\x01\x00\x76\x00\x77\x00\x14\x00\x00\x00\xd6\x00\x48\x00\x48\x00\xd6\x00\x36\x00\xe8\x00\x87\x00\xaa\x00\x00\x00\x4e\x00\x4f\x00\x00\x00\x81\x00\x82\x00\x62\x00\x19\x00\x01\x00\xaa\x00\x11\x00\x35\x00\x70\x00\x52\x00\x35\x00\x36\x00\x25\x00\x13\x00\x4b\x00\x31\x00\x32\x00\x2a\x00\x2b\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x15\x00\x4b\x00\x29\x00\x2a\x00\x2b\x00\x61\x00\x4f\x00\xbd\x00\x13\x00\x49\x00\xc0\x00\xb5\x00\x11\x00\xc3\x00\xc4\x00\x87\x00\x76\x00\x77\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x35\x00\xce\x00\xcf\x00\x61\x00\x61\x00\x63\x00\x54\x00\x87\x00\x1b\x01\x61\x00\x1d\x01\x45\x00\x52\x00\x52\x00\x4e\x00\x87\x00\x2e\x01\x5f\x00\x7e\x00\x35\x00\x27\x01\x75\x00\x62\x00\x69\x00\x69\x00\x54\x00\x87\x00\x64\x00\x57\x00\x7e\x00\x64\x00\x30\x01\x64\x00\x32\x01\x30\x01\x74\x00\xb5\x00\xbc\x00\x6f\x00\x78\x00\x64\x00\x62\x00\x87\x00\xf8\x00\xf9\x00\x87\x00\x33\x01\x87\x00\x70\x00\x64\x00\x73\x00\x6f\x00\x39\x01\x02\x01\x03\x01\x33\x01\x1e\x01\x06\x01\x07\x01\x21\x01\x6f\x00\x39\x01\xaf\x00\xb0\x00\xb1\x00\x27\x01\x1e\x01\xd3\x00\x21\x01\x21\x01\x33\x01\xd3\x00\x65\x00\x65\x00\x27\x01\x27\x01\x39\x01\x88\x00\x0f\x01\x10\x01\x11\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\x33\x01\x08\x01\x60\x00\x21\x01\xa0\x00\x27\x01\x39\x01\x29\x01\x2a\x01\x27\x01\x33\x01\x2d\x01\x7e\x00\x14\x01\x15\x01\x82\x00\x39\x01\x02\x01\x03\x01\x0c\x00\x21\x01\x06\x01\x07\x01\x21\x01\x09\x01\x1e\x01\x27\x01\x56\x00\x21\x01\x27\x01\x25\x01\x26\x01\x62\x00\x28\x01\x27\x01\x1c\x00\x33\x01\x2c\x01\x35\x01\x36\x01\x19\x01\x0f\x01\x10\x01\x11\x01\x4e\x00\x6f\x00\x1f\x01\x20\x01\x21\x01\x22\x01\x2f\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2f\x01\xab\x00\xac\x00\x2f\x01\x37\x01\x87\x00\x37\x01\x37\x01\x7f\x00\x2f\x01\x1d\x01\x1d\x01\x37\x01\x7b\x00\x37\x01\x27\x01\x37\x01\x0c\x00\x70\x00\x21\x01\x27\x01\x27\x01\x99\x00\x62\x00\x27\x01\x27\x01\x33\x01\x27\x01\x35\x01\x36\x01\x33\x01\x27\x01\x35\x01\x36\x01\x27\x01\x33\x01\x6f\x00\x35\x01\x36\x01\x79\x00\x33\x01\x34\x00\x35\x01\x36\x01\x33\x01\x41\x00\x35\x01\x36\x01\x33\x01\x33\x01\x35\x01\x36\x01\x0d\x01\x1d\x01\x0f\x01\x39\x01\x11\x01\x0d\x01\x00\x00\x0f\x01\x00\x00\x11\x01\x0d\x01\x27\x01\x0f\x01\x1e\x01\x11\x01\x1b\x01\x21\x01\x1d\x01\x1f\x01\x20\x01\x21\x01\x99\x00\x27\x01\x1f\x01\x20\x01\x21\x01\x27\x01\x27\x01\x1f\x01\x20\x01\x21\x01\x27\x01\x1e\x01\x39\x00\x4d\x00\x21\x01\x27\x01\x3d\x00\x3e\x00\x3f\x00\x40\x00\x27\x01\x42\x00\x4e\x00\x52\x00\x00\x00\x4d\x00\x56\x00\x4b\x00\x9f\x00\xa0\x00\x78\x00\x79\x00\x73\x00\x04\x01\x05\x01\x06\x01\x07\x01\x52\x00\x1e\x01\x4b\x00\x4b\x00\x21\x01\x6a\x00\x7e\x00\x89\x00\x5a\x00\x5b\x00\x27\x01\x70\x00\x00\x00\x5f\x00\x4e\x00\x91\x00\x70\x00\x76\x00\x64\x00\x70\x00\x96\x00\x97\x00\x98\x00\x99\x00\x71\x00\x21\x01\x6f\x00\x33\x01\x62\x00\x76\x00\x7f\x00\x27\x01\x57\x00\x39\x01\x2a\x01\xff\x00\x00\x01\x08\x01\x6f\x00\x6f\x00\x04\x01\x6f\x00\x06\x01\x07\x01\x7e\x00\x19\x00\x1e\x01\x39\x00\x64\x00\x21\x01\x64\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x27\x01\x42\x00\x4e\x00\xa9\x00\x6f\x00\x4e\x00\x6f\x00\xc0\x00\xff\x00\x00\x01\x2d\x00\x1e\x01\x66\x00\x04\x01\x21\x01\x06\x01\x07\x01\x52\x00\x2c\x01\x4f\x00\x27\x01\xce\x00\x52\x00\x2a\x01\x54\x00\x5a\x00\x5b\x00\x57\x00\x4b\x00\x00\x00\x5f\x00\xa0\x00\x64\x00\x9f\x00\xa0\x00\x64\x00\x70\x00\x7f\x00\x1f\x00\x1e\x01\x83\x00\x52\x00\x21\x01\x6f\x00\x00\x00\xb6\x00\xb7\x00\xb8\x00\x27\x01\x52\x00\x6a\x00\x2a\x01\xbd\x00\x2e\x00\x2f\x00\xc0\x00\x70\x00\x64\x00\xc3\x00\xc4\x00\x1b\x01\x7e\x00\x1d\x01\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6f\x00\xce\x00\xcf\x00\x70\x00\x27\x01\xff\x00\x00\x01\x6c\x00\x88\x00\x66\x00\x04\x01\x70\x00\x06\x01\x07\x01\x0b\x01\x0c\x01\x4b\x00\x0e\x01\x0f\x01\x70\x00\x11\x01\x12\x01\x13\x01\x70\x00\x9f\x00\xa0\x00\x04\x01\x05\x01\x06\x01\x07\x01\x1b\x01\x1c\x01\x1d\x01\x9f\x00\xa0\x00\x19\x00\x1e\x01\x9f\x00\xa0\x00\x21\x01\x19\x00\x4c\x00\x27\x01\xf8\x00\xf9\x00\x27\x01\x87\x00\x52\x00\x2a\x01\xb6\x00\xb7\x00\xb8\x00\x66\x00\x02\x01\x03\x01\x2d\x00\xbd\x00\x06\x01\x07\x01\xc0\x00\x19\x00\x64\x00\xc3\x00\xc4\x00\x2a\x01\x12\x01\x13\x01\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\x6f\x00\xce\x00\xcf\x00\x39\x00\x64\x00\x70\x00\x3f\x00\x40\x00\x2d\x00\x1e\x01\x1f\x01\x20\x01\x21\x01\x99\x00\x1b\x01\x6f\x00\x1d\x01\x1b\x01\x27\x01\x1d\x01\x29\x01\x2a\x01\x52\x00\x30\x01\x2d\x01\x19\x00\x27\x01\x51\x00\x52\x00\x27\x01\x33\x01\x34\x01\x35\x01\x36\x01\x09\x01\x6c\x00\x9f\x00\xa0\x00\x62\x00\x70\x00\x89\x00\x5f\x00\x53\x00\xf8\x00\xf9\x00\x2d\x00\x64\x00\x16\x01\x69\x00\x18\x01\x19\x01\x69\x00\x6a\x00\x02\x01\x03\x01\x98\x00\x99\x00\x06\x01\x07\x01\x22\x01\x53\x00\x24\x01\x25\x01\x26\x01\x62\x00\x28\x01\x4c\x00\x62\x00\x2b\x01\x2c\x01\x04\x01\x05\x01\x06\x01\x07\x01\x54\x00\x39\x00\x1b\x01\x6f\x00\x1d\x01\x1e\x00\x6f\x00\x1e\x01\x1f\x01\x20\x01\x21\x01\x1b\x01\x1a\x00\x1d\x01\x27\x01\x1b\x01\x27\x01\x1d\x01\x29\x01\x2a\x01\x2d\x00\xc0\x00\x2d\x01\x27\x01\x61\x00\x51\x00\x52\x00\x27\x01\x33\x01\x34\x01\x35\x01\x36\x01\x2e\x00\x2f\x00\x2a\x01\xce\x00\x2b\x01\x2c\x01\x66\x00\x5f\x00\x14\x00\x30\x01\x9f\x00\xa0\x00\x64\x00\x7f\x00\x62\x00\x1e\x00\x70\x00\x69\x00\x6a\x00\x58\x00\x59\x00\x5a\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x5f\x00\x6f\x00\x4d\x00\xbd\x00\x2d\x00\x52\x00\xc0\x00\xf4\x00\xf5\x00\xc3\x00\xc4\x00\x31\x00\x32\x00\x33\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\x75\x00\x4f\x00\x7a\x00\x7b\x00\x79\x00\x53\x00\x1b\x01\x6a\x00\x1d\x01\x6a\x00\x74\x00\x1e\x00\x1e\x00\x70\x00\x78\x00\x70\x00\x0b\x01\x0c\x01\x27\x01\x0e\x01\x0f\x01\x76\x00\x11\x01\x12\x01\x13\x01\x7a\x00\x2d\x00\x2d\x00\x1f\x01\x20\x01\x21\x01\x30\x00\x1b\x01\x1c\x01\x1d\x01\x99\x00\x27\x01\xa7\x00\xa8\x00\xa9\x00\xf8\x00\xf9\x00\x3b\x00\x3c\x00\x27\x01\x62\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x02\x01\x03\x01\x66\x00\xbd\x00\x06\x01\x07\x01\xc0\x00\x6c\x00\x6f\x00\xc3\x00\xc4\x00\x70\x00\x70\x00\x62\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\x39\x00\xf3\x00\xf4\x00\xf5\x00\x6f\x00\x55\x00\x1e\x01\x1f\x01\x20\x01\x21\x01\x04\x01\x05\x01\x06\x01\x07\x01\x1b\x01\x27\x01\x1d\x01\x29\x01\x2a\x01\x3f\x00\x40\x00\x2d\x01\x62\x00\xa7\x00\xa8\x00\xa9\x00\x27\x01\x33\x01\x34\x01\x35\x01\x36\x01\x04\x01\x05\x01\x06\x01\x07\x01\x6f\x00\x6a\x00\x1b\x01\x5f\x00\x1d\x01\xf8\x00\xf9\x00\x70\x00\x64\x00\x7e\x00\x1f\x01\x20\x01\x21\x01\x2a\x01\x27\x01\x02\x01\x03\x01\x6d\x00\x27\x01\x06\x01\x07\x01\x21\x01\x1d\x01\x04\x01\x05\x01\x06\x01\x07\x01\x27\x01\xff\x00\x00\x01\x2a\x01\x7e\x00\x27\x01\x04\x01\x2a\x01\x06\x01\x07\x01\x39\x00\x4e\x00\x4f\x00\x58\x00\x59\x00\x5a\x00\x1e\x01\x1f\x01\x20\x01\x21\x01\x5f\x00\x65\x00\x0f\x01\x6a\x00\x11\x01\x27\x01\x6c\x00\x29\x01\x2a\x01\x70\x00\x70\x00\x2d\x01\x1e\x01\x99\x00\x2a\x01\x21\x01\x1d\x01\x33\x01\x34\x01\x35\x01\x36\x01\x27\x01\x75\x00\x33\x01\x2a\x01\x99\x00\x27\x01\x57\x00\x5f\x00\x39\x01\x1f\x01\x20\x01\x21\x01\x64\x00\x04\x01\x05\x01\x06\x01\x07\x01\x27\x01\x61\x00\x69\x00\x63\x00\x6d\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x0a\x01\x0b\x01\x0c\x01\xbd\x00\x74\x00\x0f\x01\xc0\x00\x11\x01\x78\x00\xc3\x00\xc4\x00\x4d\x00\x4e\x00\x70\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\x58\x00\x59\x00\x5a\x00\x2a\x01\x70\x00\x02\x01\x03\x01\x5f\x00\x89\x00\x06\x01\x07\x01\x65\x00\x33\x01\x6a\x00\x8f\x00\x69\x00\x91\x00\x6b\x00\x39\x01\x70\x00\x69\x00\x96\x00\x97\x00\x98\x00\x99\x00\x71\x00\x74\x00\x23\x00\x6c\x00\x75\x00\x76\x00\x74\x00\x70\x00\x79\x00\x7a\x00\x78\x00\x33\x01\x21\x01\xf6\x00\xf7\x00\xf8\x00\xf9\x00\x39\x01\x27\x01\x29\x01\x2a\x01\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x02\x01\x03\x01\x21\x01\xbd\x00\x06\x01\x07\x01\xc0\x00\x74\x00\x27\x01\xc3\x00\xc4\x00\x78\x00\x08\x01\xc0\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\x69\x00\x69\x00\x14\x01\x15\x01\x39\x00\xce\x00\x1e\x01\x1f\x01\x20\x01\x21\x01\x2c\x01\x61\x00\x74\x00\x63\x00\x30\x01\x27\x01\x78\x00\x29\x01\x2a\x01\x25\x01\x26\x01\x2d\x01\x28\x01\x3f\x00\x40\x00\x4e\x00\x2c\x01\x33\x01\x34\x01\x35\x01\x36\x01\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x20\x01\x21\x01\xf6\x00\xf7\x00\xf8\x00\xf9\x00\x5f\x00\x27\x01\x7e\x00\x29\x01\x2a\x01\x64\x00\x65\x00\x66\x00\x02\x01\x03\x01\x2d\x00\x2e\x00\x06\x01\x07\x01\x65\x00\x1f\x01\x20\x01\x21\x01\x69\x00\x87\x00\x6b\x00\x89\x00\x8a\x00\x27\x01\x0b\x01\x0c\x01\x99\x00\x0e\x01\x0f\x01\x74\x00\x11\x01\x12\x01\x13\x01\x78\x00\x39\x00\x99\x00\x1e\x01\x1f\x01\x20\x01\x21\x01\x1b\x01\x1c\x01\x1d\x01\x33\x01\x3a\x00\x27\x01\x34\x01\x29\x01\x2a\x01\x39\x01\x38\x01\x2d\x01\x27\x01\x25\x01\x26\x01\x4e\x00\x28\x01\x33\x01\x34\x01\x35\x01\x36\x01\x4d\x00\x4d\x00\x0c\x01\x54\x00\x35\x00\x0f\x01\x57\x00\x11\x01\x54\x00\x99\x00\x56\x00\x5f\x00\x58\x00\x59\x00\x5a\x00\x21\x01\x64\x00\x65\x00\x66\x00\x5f\x00\x13\x00\x27\x01\x1e\x01\x29\x01\x2a\x01\x21\x01\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x34\x01\x27\x01\x4f\x00\xbd\x00\x38\x01\x52\x00\xc0\x00\x71\x00\x62\x00\xc3\x00\xc4\x00\x75\x00\x76\x00\x4d\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\x4e\x00\x4f\x00\x58\x00\x59\x00\x5a\x00\xa2\x00\xa3\x00\xa4\x00\x89\x00\x5f\x00\x1e\x01\x65\x00\x1f\x00\x21\x01\x34\x01\x69\x00\x91\x00\x6b\x00\x38\x01\x27\x01\x6f\x00\x96\x00\x97\x00\x98\x00\x99\x00\x4f\x00\x74\x00\x71\x00\x52\x00\x4b\x00\x78\x00\x75\x00\x76\x00\x4e\x00\x4f\x00\x79\x00\x7a\x00\xa7\x00\xa8\x00\xa9\x00\xf8\x00\xf9\x00\x46\x00\x47\x00\x48\x00\x49\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x02\x01\x03\x01\x74\x00\xbd\x00\x06\x01\x07\x01\xc0\x00\x8f\x00\x65\x00\xc3\x00\xc4\x00\x02\x00\x03\x00\xc0\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\x39\x00\x02\x00\x03\x00\x20\x01\x21\x01\xce\x00\x1e\x01\x1f\x01\x20\x01\x21\x01\x27\x01\x0c\x01\x29\x01\x2a\x01\x0f\x01\x27\x01\x11\x01\x29\x01\x2a\x01\x70\x00\x61\x00\x2d\x01\x63\x00\x4e\x00\x51\x00\x52\x00\x4f\x00\x33\x01\x34\x01\x35\x01\x36\x01\x1f\x01\x20\x01\x21\x01\x1f\x01\x20\x01\x21\x01\x54\x00\x5f\x00\x27\x01\xf8\x00\xf9\x00\x27\x01\x64\x00\x4b\x00\x24\x01\x25\x01\x26\x01\x69\x00\x28\x01\x02\x01\x03\x01\x2b\x01\x2c\x01\x06\x01\x07\x01\x4b\x00\x30\x01\x04\x01\x05\x01\x06\x01\x07\x01\x11\x00\x1f\x01\x20\x01\x21\x01\x0b\x01\x0c\x01\x4b\x00\x0e\x01\x0f\x01\x27\x01\x11\x01\x12\x01\x13\x01\xba\x00\xbb\x00\xbc\x00\x1e\x01\x1f\x01\x20\x01\x21\x01\x1b\x01\x1c\x01\x1d\x01\x4b\x00\x61\x00\x27\x01\x63\x00\x29\x01\x2a\x01\x52\x00\x0c\x01\x2d\x01\x27\x01\x0f\x01\x2a\x01\x11\x01\x57\x00\x33\x01\x34\x01\x35\x01\x36\x01\x99\x00\x45\x00\x33\x01\xba\x00\xbb\x00\xbc\x00\x4c\x00\x4d\x00\x39\x01\x0a\x01\x0b\x01\x0c\x01\x54\x00\x61\x00\x0f\x01\x63\x00\x11\x01\x24\x01\x25\x01\x26\x01\x7e\x00\x28\x01\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x1b\x01\x39\x00\x1d\x01\xbd\x00\x6a\x00\x61\x00\xc0\x00\x63\x00\x70\x00\xc3\x00\xc4\x00\x4e\x00\x27\x01\xc0\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\x4e\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xce\x00\x00\x01\xe4\x00\xe5\x00\xe6\x00\x04\x01\xe8\x00\x06\x01\x07\x01\x24\x01\x25\x01\x26\x01\x5f\x00\x28\x01\x89\x00\x6e\x00\x6f\x00\x64\x00\x65\x00\x01\x01\x6a\x00\x03\x01\x91\x00\x61\x00\x06\x01\x63\x00\x6a\x00\x96\x00\x97\x00\x98\x00\x99\x00\x1e\x01\x6e\x00\x6f\x00\x21\x01\xf8\x00\xf9\x00\xbe\x00\xbf\x00\x99\x00\x27\x01\x6a\x00\x61\x00\x2a\x01\x63\x00\x02\x01\x03\x01\x6a\x00\x1e\x01\x06\x01\x07\x01\x21\x01\x5c\x00\x5d\x00\x5e\x00\x4b\x00\x52\x00\x27\x01\x54\x00\x29\x01\x2a\x01\x0b\x01\x0c\x01\x52\x00\x61\x00\x0f\x01\x63\x00\x11\x01\x0d\x00\xc0\x00\xb2\x00\xb3\x00\xb4\x00\x1e\x01\x1f\x01\x20\x01\x21\x01\x1b\x01\xc0\x00\x1d\x01\xbe\x00\xbf\x00\x27\x01\xce\x00\x29\x01\x2a\x01\xbe\x00\xbf\x00\x2d\x01\x27\x01\x70\x00\x61\x00\xce\x00\x63\x00\x33\x01\x34\x01\x35\x01\x36\x01\x66\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x39\x00\x25\x01\x26\x01\xbd\x00\x28\x01\x61\x00\xc0\x00\x63\x00\x2c\x01\xc3\x00\xc4\x00\x61\x00\x30\x01\x63\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xb2\x00\xb3\x00\xb4\x00\xb2\x00\xb3\x00\xb4\x00\xb2\x00\xb3\x00\xb4\x00\xb2\x00\xb3\x00\xb4\x00\xb2\x00\xb3\x00\xb4\x00\x61\x00\x5f\x00\x63\x00\x91\x00\x0b\x01\x0c\x01\x64\x00\x0e\x01\x0f\x01\x8f\x00\x11\x01\x12\x01\x13\x01\x0b\x01\x0c\x01\x6d\x00\x61\x00\x0f\x01\x63\x00\x11\x01\x1b\x01\x1c\x01\x1d\x01\x45\x00\x46\x00\xf8\x00\xf9\x00\x6a\x00\x61\x00\x1b\x01\x63\x00\x1d\x01\x27\x01\x71\x00\x72\x00\x02\x01\x03\x01\x73\x00\x74\x00\x06\x01\x07\x01\x27\x01\x65\x00\x31\x01\x32\x01\xe6\x00\x69\x00\xe8\x00\x6b\x00\x12\x01\x13\x01\x8f\x00\x6f\x00\x6e\x00\x6f\x00\xf7\x00\xf8\x00\x74\x00\x6c\x00\x4d\x00\xa3\x00\xa4\x00\x6a\x00\x1e\x01\x1f\x01\x20\x01\x21\x01\x8f\x00\x56\x00\x66\x00\x58\x00\x59\x00\x27\x01\x70\x00\x29\x01\x2a\x01\x87\x00\x5f\x00\x2d\x01\x36\x00\x37\x00\x54\x00\x4c\x00\x4d\x00\x33\x01\x34\x01\x35\x01\x36\x01\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x39\x00\x7f\x00\x4b\x00\xbd\x00\x4b\x00\x4b\x00\xc0\x00\x75\x00\x76\x00\xc3\x00\xc4\x00\x79\x00\x7a\x00\x0d\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\x6f\x00\x52\x00\x15\x00\x71\x00\x71\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x71\x00\x71\x00\x6c\x00\x62\x00\x6c\x00\x6a\x00\x5f\x00\x0c\x00\x6a\x00\x34\x00\x19\x00\x64\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\x58\x00\x00\x01\x6f\x00\x89\x00\x6d\x00\x04\x01\x4e\x00\x06\x01\x07\x01\x70\x00\x70\x00\x91\x00\x71\x00\x6a\x00\xf8\x00\xf9\x00\x96\x00\x97\x00\x98\x00\x99\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x02\x01\x03\x01\x00\x01\x6a\x00\x06\x01\x07\x01\x04\x01\x1e\x01\x06\x01\x07\x01\x21\x01\x6a\x00\x6a\x00\x6a\x00\x25\x01\x26\x01\x27\x01\x28\x01\x66\x00\x2a\x01\x70\x00\x2c\x01\x62\x00\x4d\x00\x70\x00\x30\x01\x4f\x00\x54\x00\x1e\x01\x1f\x01\x20\x01\x21\x01\x1e\x01\x70\x00\xc0\x00\x21\x01\x17\x00\x27\x01\x4d\x00\x29\x01\x2a\x01\x27\x01\x54\x00\x2d\x01\x2a\x01\x70\x00\x52\x00\x62\x00\xce\x00\x33\x01\x34\x01\x35\x01\x36\x01\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x39\x00\x6a\x00\x57\x00\xbd\x00\x4e\x00\x70\x00\xc0\x00\x4f\x00\x4b\x00\xc3\x00\xc4\x00\x4b\x00\x4e\x00\x66\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\x4e\x00\x7f\x00\x4b\x00\x6a\x00\x89\x00\x6a\x00\x4b\x00\x71\x00\x71\x00\x19\x00\x52\x00\x57\x00\x91\x00\x4e\x00\x70\x00\x4e\x00\x5f\x00\x96\x00\x97\x00\x98\x00\x99\x00\x64\x00\x6a\x00\x19\x00\x01\x01\x4f\x00\x03\x01\x1a\x00\x4b\x00\x06\x01\x0b\x01\x0c\x01\x09\x01\x0e\x01\x0f\x01\x74\x00\x11\x01\x12\x01\x13\x01\x7e\x00\xf8\x00\xf9\x00\x4b\x00\x7e\x00\x15\x01\x16\x00\x1b\x01\x1c\x01\x1d\x01\x0c\x00\x02\x01\x03\x01\x6f\x00\x1e\x01\x06\x01\x07\x01\x21\x01\x4d\x00\x27\x01\xc0\x00\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x58\x00\x59\x00\x5a\x00\x4d\x00\x4b\x00\xce\x00\x69\x00\x5f\x00\x7e\x00\x66\x00\x1e\x01\x1f\x01\x20\x01\x21\x01\x19\x00\x62\x00\x70\x00\x4e\x00\x6a\x00\x27\x01\x4e\x00\x29\x01\x2a\x01\x71\x00\x70\x00\x2d\x01\x4e\x00\x4e\x00\x4e\x00\x75\x00\x76\x00\x33\x01\x34\x01\x35\x01\x36\x01\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x5f\x00\x52\x00\x4f\x00\xbd\x00\x70\x00\x19\x00\xc0\x00\x19\x00\x54\x00\xc3\x00\xc4\x00\x07\x00\x4f\x00\x57\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\x4d\x00\x4b\x00\x89\x00\x52\x00\x54\x00\x0b\x01\x0c\x01\x66\x00\x0e\x01\x0f\x01\x91\x00\x11\x01\x12\x01\x13\x01\x7b\x00\x96\x00\x97\x00\x98\x00\x99\x00\x7f\x00\x6f\x00\x1b\x01\x1c\x01\x1d\x01\x6f\x00\xfd\x00\xfe\x00\x62\x00\x00\x01\x52\x00\x6a\x00\x88\x00\x04\x01\x27\x01\x06\x01\x07\x01\x4d\x00\x66\x00\x69\x00\x19\x00\xf8\x00\xf9\x00\x19\x00\x6a\x00\x6a\x00\x6f\x00\x88\x00\x87\x00\x19\x00\x58\x00\x02\x01\x03\x01\x52\x00\x2d\x00\x06\x01\x07\x01\x6f\x00\xc0\x00\x1e\x01\x4f\x00\x89\x00\x21\x01\x70\x00\x4b\x00\x4b\x00\x19\x00\x5f\x00\x27\x01\x91\x00\x07\x00\x2a\x01\xce\x00\x07\x00\x96\x00\x97\x00\x98\x00\x99\x00\x87\x00\x1e\x01\x1f\x01\x20\x01\x21\x01\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\x27\x01\x00\x01\x29\x01\x2a\x01\x19\x00\x04\x01\x2d\x01\x06\x01\x07\x01\x89\x00\x4e\x00\x5f\x00\x33\x01\x34\x01\x35\x01\x36\x01\x66\x00\x91\x00\x57\x00\x19\x00\x7e\x00\x4b\x00\x96\x00\x97\x00\x98\x00\x99\x00\x4b\x00\x19\x00\xc0\x00\x6f\x00\x16\x00\x1e\x01\x4e\x00\x1a\x00\x21\x01\x4f\x00\x54\x00\x11\x00\x23\x00\x33\x00\x27\x01\x88\x00\xce\x00\x2a\x01\x1a\x00\x0b\x01\x0c\x01\x07\x00\x0e\x01\x0f\x01\x7f\x00\x11\x01\x12\x01\x13\x01\x4d\x00\x4e\x00\x4f\x00\x09\x00\x65\x00\x52\x00\x69\x00\x1b\x01\x1c\x01\x1d\x01\xc0\x00\x58\x00\x59\x00\x5a\x00\x89\x00\x6a\x00\x3a\x00\x69\x00\x5f\x00\x27\x01\x8f\x00\x4d\x00\x91\x00\x2e\x00\xce\x00\x57\x00\x70\x00\x96\x00\x97\x00\x98\x00\x99\x00\x6f\x00\x52\x00\x02\x01\x03\x01\x6a\x00\x71\x00\x06\x01\x07\x01\x4e\x00\x75\x00\x76\x00\x6f\x00\x62\x00\x79\x00\x7a\x00\x02\x00\x45\x00\x6a\x00\x0b\x01\x0c\x01\x4e\x00\x0e\x01\x0f\x01\x62\x00\x11\x01\x12\x01\x13\x01\x5f\x00\x58\x00\x62\x00\x57\x00\x1f\x01\x20\x01\x21\x01\x1b\x01\x1c\x01\x1d\x01\x88\x00\xc0\x00\x27\x01\x5f\x00\x29\x01\x2a\x01\x7f\x00\x6a\x00\x6a\x00\x27\x01\x58\x00\x70\x00\x70\x00\x6a\x00\x4b\x00\xce\x00\x02\x00\x0b\x01\x0c\x01\x6a\x00\x0e\x01\x0f\x01\x6a\x00\x11\x01\x12\x01\x13\x01\x69\x00\x87\x00\x52\x00\x52\x00\x69\x00\x19\x00\x07\x00\x1b\x01\x1c\x01\x1d\x01\x6a\x00\x4e\x00\x19\x00\x69\x00\x89\x00\x75\x00\x4d\x00\x19\x00\x07\x00\x27\x01\x8f\x00\x6a\x00\x91\x00\x75\x00\x30\x00\x30\x01\xed\x00\x96\x00\x97\x00\x98\x00\x99\x00\xed\x00\xed\x00\x89\x00\xd2\x00\x38\x00\x59\x00\x43\x00\x7f\x00\x8f\x00\x31\x00\x91\x00\x2e\x01\x32\x00\x2f\x01\x2f\x01\x96\x00\x97\x00\x98\x00\x99\x00\x0b\x01\x0c\x01\x7c\x00\x0e\x01\x0f\x01\x7c\x00\x11\x01\x12\x01\x13\x01\x11\x01\x80\x00\x59\x00\x80\x00\xa1\x00\x30\x01\xd0\x00\x1b\x01\x1c\x01\x1d\x01\xc0\x00\x84\x00\xe0\x00\xff\x00\x00\x01\x8a\x00\x2f\x01\xc6\x00\x04\x01\x27\x01\x06\x01\x07\x01\x85\x00\x86\x00\xce\x00\x2f\x01\x89\x00\x16\x00\x2e\x01\xc0\x00\x8d\x00\x8e\x00\x8f\x00\x16\x00\x91\x00\x92\x00\x30\x00\x03\x00\xe8\x00\x96\x00\x97\x00\x98\x00\x99\x00\xce\x00\x1e\x01\x2e\x01\x34\x01\x21\x01\x34\x01\x68\x00\xe0\x00\x54\x00\x43\x00\x27\x01\x2e\x01\x2e\x01\x2a\x01\x2e\x01\x6c\x00\x55\x00\x2a\x01\x86\x00\x72\x00\x75\x00\x89\x00\x34\x00\x7d\x00\x16\x00\x16\x00\x8e\x00\x8f\x00\x2c\x00\x20\x00\x92\x00\x20\x00\x7c\x00\x33\x00\x96\x00\x97\x00\x98\x00\x99\x00\xc0\x00\x7c\x00\x63\x00\x5e\x00\x0b\x01\x0c\x01\x47\x00\x0e\x01\x0f\x01\x6b\x00\x11\x01\x12\x01\x13\x01\x67\x00\xce\x00\xa6\x00\x8a\x00\x70\x00\x8a\x00\x2c\x00\x1b\x01\x1c\x01\x1d\x01\x0b\x01\x0c\x01\x2e\x01\x0e\x01\x0f\x01\x0e\x00\x11\x01\x12\x01\x13\x01\x27\x01\x20\x00\x20\x00\xc6\x00\xe8\x00\x70\x00\xc0\x00\x1b\x01\x1c\x01\x1d\x01\xa6\x00\xb4\x00\x4a\x00\xa4\x00\x86\x00\x17\x00\x17\x00\x89\x00\x34\x00\x27\x01\xce\x00\x4b\x00\x8e\x00\x8f\x00\xf8\x00\x2f\x01\x92\x00\x50\x00\x02\x00\x50\x00\x96\x00\x97\x00\x98\x00\x99\x00\x4f\x00\x2e\x01\x0a\x00\x2e\x01\xad\x00\x34\x01\x45\x00\x1c\x00\x2e\x01\x0b\x01\x0c\x01\x26\x00\x0e\x01\x0f\x01\x16\x00\x11\x01\x12\x01\x13\x01\x1c\x00\x2f\x01\x1c\x00\x1d\x00\x1e\x00\x0b\x00\x31\x00\x1b\x01\x1c\x01\x1d\x01\xf8\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2f\x01\x56\x00\x2c\x00\x27\x01\xc0\x00\x2e\x01\x59\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0b\x01\x0c\x01\x33\x01\x0e\x01\x0f\x01\xce\x00\x11\x01\x12\x01\x13\x01\x2e\x01\x35\x00\x2e\x01\x2e\x01\x4d\x00\x2f\x01\x2e\x01\x1b\x01\x1c\x01\x1d\x01\x54\x00\x54\x00\x16\x00\x56\x00\x56\x00\x58\x00\x59\x00\x5a\x00\x86\x00\x27\x01\x16\x00\x89\x00\x5f\x00\x2f\x01\x20\x00\x2f\x01\x8e\x00\x8f\x00\xa6\x00\x20\x00\x92\x00\x33\x01\x17\x00\x6a\x00\x96\x00\x97\x00\x98\x00\x99\x00\xf8\x00\x70\x00\x17\x00\xff\xff\x2f\x01\x2f\x01\x75\x00\x76\x00\xff\xff\x2f\x01\x79\x00\x7a\x00\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\x7e\x00\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xc0\x00\x54\x00\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\x86\x00\x27\x01\xff\xff\x89\x00\x5f\x00\xff\xff\xce\x00\xff\xff\x8e\x00\x8f\x00\xff\xff\xff\xff\x92\x00\x33\x01\xff\xff\x6a\x00\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x86\x00\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8e\x00\x8f\x00\xf8\x00\xff\xff\x92\x00\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xce\x00\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xc0\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\x33\x01\x86\x00\xff\xff\xce\x00\x89\x00\xff\xff\xff\xff\xf8\x00\xff\xff\x8e\x00\x8f\x00\xff\xff\xff\xff\x92\x00\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xeb\x00\xec\x00\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xf8\x00\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\x27\x01\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x01\x0c\x01\x33\x01\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xce\x00\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\x86\x00\x27\x01\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8e\x00\x8f\x00\xff\xff\xff\xff\x92\x00\x33\x01\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x89\x00\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\x1b\x01\x1c\x01\x1d\x01\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\x27\x01\xce\x00\x93\x00\x94\x00\x95\x00\x4d\x00\xc0\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\x33\x01\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xce\x00\xff\xff\x89\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xae\x00\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\x89\x00\xff\xff\xf8\x00\xff\xff\x75\x00\x76\x00\xc0\x00\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x95\x00\xff\xff\xff\xff\x98\x00\x99\x00\xff\xff\xae\x00\xff\xff\xce\x00\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\x1b\x01\x1c\x01\x1d\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\x27\x01\xce\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\x1b\x01\x1c\x01\x1d\x01\xff\xff\x4d\x00\x33\x01\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xce\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x1b\x01\x1c\x01\x1d\x01\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\x34\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\x27\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\x89\x00\x34\x01\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x27\x01\x91\x00\x92\x00\xff\xff\xff\xff\x4d\x00\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\x34\x01\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x89\x00\x5f\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\xff\xff\x91\x00\x92\x00\xff\xff\xff\xff\x6a\x00\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xc0\x00\x79\x00\x7a\x00\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\xff\xff\x91\x00\x92\x00\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\x8c\x00\x09\x01\x8e\x00\x8f\x00\xff\xff\xff\xff\x92\x00\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x16\x01\x9b\x00\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\x22\x01\xff\xff\x24\x01\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\x2b\x01\x2c\x01\xce\x00\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\x33\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\x33\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\x33\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\x89\x00\xff\xff\xff\xff\x8c\x00\xff\xff\x8e\x00\x8f\x00\xff\xff\x27\x01\x92\x00\xff\xff\xff\xff\x4d\x00\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\x9b\x00\xff\xff\x33\x01\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x89\x00\x5f\x00\xff\xff\x8c\x00\xff\xff\x8e\x00\x8f\x00\xff\xff\xff\xff\x92\x00\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x71\x00\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xc0\x00\x79\x00\x7a\x00\x89\x00\xff\xff\xff\xff\x8c\x00\xff\xff\x8e\x00\x8f\x00\xff\xff\xff\xff\x92\x00\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\x09\x01\x8e\x00\x8f\x00\xff\xff\xff\xff\x92\x00\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x16\x01\xff\xff\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\x22\x01\xff\xff\x24\x01\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\x2b\x01\x2c\x01\xce\x00\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\x33\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\x33\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\x33\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8e\x00\x8f\x00\xff\xff\x27\x01\x92\x00\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\x33\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8e\x00\x8f\x00\xff\xff\xff\xff\x92\x00\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8e\x00\x8f\x00\xff\xff\xff\xff\x92\x00\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\x09\x01\x8e\x00\x8f\x00\xff\xff\xff\xff\x92\x00\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x16\x01\xff\xff\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\x22\x01\xff\xff\x24\x01\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\x2b\x01\x2c\x01\xce\x00\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\x33\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\x33\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\x33\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\x27\x01\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\x33\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xc0\x00\xff\xff\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\x4d\x00\x4e\x00\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xc0\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\xff\xff\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\x71\x00\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xce\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x26\x01\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\x2c\x01\x09\x01\xff\xff\xff\xff\x30\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\x16\x01\xff\xff\x18\x01\x19\x01\xf8\x00\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\x22\x01\xff\xff\x24\x01\x25\x01\x26\x01\xff\xff\x28\x01\x27\x01\xff\xff\x2b\x01\x2c\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\x30\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\x27\x01\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\x02\x00\xce\x00\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\x0a\x00\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xc0\x00\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xf8\x00\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xce\x00\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\x30\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\x1b\x01\x1c\x01\x1d\x01\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x85\x00\x1b\x01\x1c\x01\x1d\x01\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\x27\x01\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\x88\x00\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x85\x00\xc0\x00\xff\xff\x88\x00\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x85\x00\xc0\x00\xff\xff\x88\x00\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x85\x00\x1b\x01\x1c\x01\x1d\x01\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\x27\x01\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x9c\x00\x9d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x9c\x00\x9d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\x9d\x00\xff\xff\xff\xff\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\x27\x01\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\x9d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\x9d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\x9d\x00\xff\xff\xff\xff\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\x27\x01\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\x27\x01\xff\xff\xc0\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xa5\x00\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xeb\x00\xc0\x00\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xf8\x00\xf9\x00\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xc0\x00\xff\xff\xa5\x00\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xf8\x00\xff\xff\xc0\x00\x27\x01\xa5\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\x27\x01\xff\xff\xc0\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xa5\x00\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xa5\x00\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xf8\x00\xf9\x00\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xc0\x00\xff\xff\xa5\x00\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xf8\x00\xff\xff\xc0\x00\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\x27\x01\xff\xff\xc0\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xa5\x00\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xf8\x00\xf9\x00\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xc0\x00\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xce\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xf8\x00\xff\xff\xc0\x00\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\x27\x01\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xc0\x00\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\x89\x00\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\x4d\x00\x4e\x00\xf8\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xce\x00\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xc0\x00\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xf8\x00\xff\xff\xff\xff\xce\x00\xff\xff\x71\x00\x1b\x01\x1c\x01\x1d\x01\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xc0\x00\xff\xff\xff\xff\x27\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xce\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\x27\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\x0b\x01\x0c\x01\x27\x01\x0e\x01\x0f\x01\x91\x00\x11\x01\x12\x01\x13\x01\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\x0b\x01\x0c\x01\x27\x01\x0e\x01\x0f\x01\x91\x00\x11\x01\x12\x01\x13\x01\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xc0\x00\xff\xff\x27\x01\xff\xff\xff\xff\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xce\x00\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xc0\x00\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xc0\x00\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xce\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\x0b\x01\x0c\x01\x27\x01\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xce\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x01\x0c\x01\x27\x01\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\x27\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\x0b\x01\x0c\x01\x27\x01\x0e\x01\x0f\x01\x91\x00\x11\x01\x12\x01\x13\x01\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\xff\xff\x91\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xc0\x00\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x4d\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\x89\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x91\x00\x5f\x00\xc0\x00\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xce\x00\xff\xff\x89\x00\x71\x00\xff\xff\xc0\x00\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\xce\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xce\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\x0b\x01\x0c\x01\x27\x01\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xce\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\x0b\x01\x0c\x01\xff\xff\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\x27\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x01\x0c\x01\x27\x01\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x01\x0c\x01\x27\x01\x0e\x01\x0f\x01\xff\xff\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\x1b\x01\x1c\x01\x1d\x01\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\x43\x00\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\x6c\x00\x6d\x00\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\x6c\x00\x6d\x00\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\x4e\x00\x4f\x00\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\x4e\x00\x4f\x00\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\x0a\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\x0a\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x73\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\x0a\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x73\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xc4\x00\x87\x00\xff\xff\x0a\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1f\x01\x20\x01\x21\x01\x65\x00\x66\x00\xff\xff\xff\xff\x69\x00\x27\x01\x6b\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xeb\x00\xec\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1f\x01\x20\x01\x21\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x27\x01\x6b\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1f\x01\x20\x01\x21\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x27\x01\x6b\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1f\x01\x20\x01\x21\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x27\x01\x6b\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1f\x01\x20\x01\x21\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x27\x01\x6b\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1f\x01\x20\x01\x21\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x27\x01\x6b\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1f\x01\x20\x01\x21\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x27\x01\x6b\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1f\x01\x20\x01\x21\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x27\x01\x6b\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1f\x01\x20\x01\x21\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x27\x01\x6b\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1f\x01\x20\x01\x21\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x27\x01\x6b\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1f\x01\x20\x01\x21\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x27\x01\x6b\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1f\x01\x20\x01\x21\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x27\x01\x6b\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1f\x01\x20\x01\x21\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x27\x01\x6b\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1f\x01\x20\x01\x21\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x27\x01\x6b\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1f\x01\x20\x01\x21\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x27\x01\x6b\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x02\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\x0a\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\x73\x00\xff\xff\xff\xff\x97\x00\x98\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x7e\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7e\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7e\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x7e\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x02\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\x71\x00\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x01\x00\x02\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\x71\x00\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\xff\xff\x7a\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x13\x00\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x69\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x02\x00\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x69\x00\x02\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x02\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x69\x00\x02\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x65\x00\x02\x00\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x65\x00\x02\x00\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x4c\x00\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\x69\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xc0\x00\xc1\x00\xc2\x00\x77\x00\xc4\x00\xc5\x00\x4d\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xd4\x00\xd5\x00\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\xff\xff\xff\xff\x30\x01\x02\x00\x32\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\x0a\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\x16\x00\xff\xff\xd4\x00\xd5\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\xff\xff\x73\x00\x30\x01\xff\xff\x32\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd4\x00\xd5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\xff\xff\xff\xff\x02\x00\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\x0a\x00\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x13\x00\xff\xff\x30\x01\x16\x00\x32\x01\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x02\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x65\x00\xff\xff\x2c\x00\xff\xff\x69\x00\x02\x00\x6b\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x02\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x65\x00\xff\xff\x2c\x00\xff\xff\x69\x00\x02\x00\x6b\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x02\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x65\x00\xff\xff\x2c\x00\xff\xff\x69\x00\x02\x00\x6b\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x02\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x73\x00\x74\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x0a\x00\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x61\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x70\x00\xff\xff\x2c\x00\x73\x00\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x73\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x73\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\x73\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe1\x00\xe2\x00\xe3\x00\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd4\x00\x1f\x01\x20\x01\x21\x01\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x2e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\xff\xff\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd4\x00\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\xff\xff\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd4\x00\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\xff\xff\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\xff\xff\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\xff\xff\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\xff\xff\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\xff\xff\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\xff\xff\x1a\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\xff\xff\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xda\x00\xdb\x00\xdc\x00\xdd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xdb\x00\xdc\x00\xdd\x00\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf0\x00\xf1\x00\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xff\xff\xff\xff\xff\xff\xff\xff\xef\x00\xff\xff\xf1\x00\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xf1\x00\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xff\xff\xff\xff\xff\xff\xee\x00\xff\xff\xff\xff\xf1\x00\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xde\x00\xdf\x00\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xe1\x00\xe2\x00\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xde\x00\xdf\x00\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xe1\x00\xe2\x00\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xe6\x00\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf1\x00\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xdd\x00\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xe3\x00\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xc0\x00\xff\xff\x06\x01\x07\x01\xc4\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\x27\x01\xd1\x00\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x01\x20\x01\x21\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x01\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# happyTable :: HappyAddr happyTable = HappyA# "\x00\x00\x70\x00\x84\x05\x62\x03\x43\x05\x44\x05\xa4\x04\x9c\x04\x86\x05\xce\x00\x97\x04\x94\x04\x93\x04\x94\x04\x95\x04\x0e\x01\x95\x04\x0f\x01\x03\x04\x27\x05\x40\x05\x41\x05\x95\x04\x10\x01\x11\x01\x12\x01\x2d\x00\x2e\x00\x6e\x05\x13\x01\x13\x02\x14\x02\x15\x02\xf7\x02\x2f\x00\x88\x05\x30\x00\x92\x02\x89\x05\xb5\x04\x14\x02\x15\x02\xb4\x04\x14\x02\xd1\x03\x23\x05\xb5\x04\x14\x02\x15\x02\xb5\x04\x14\x02\x15\x02\xcf\x00\x32\x03\x99\x04\x9a\x04\x9b\x04\x9c\x04\x6b\x05\x9a\x04\x9b\x04\x9c\x04\xa2\x02\x90\x05\x9a\x04\x9b\x04\x9c\x04\x3d\x03\x72\x05\x81\x05\x82\x05\x9c\x04\x88\x02\x89\x02\x33\x05\x9c\x04\x88\x02\x89\x02\x28\x05\x9c\x04\x6f\x04\x90\x04\xee\x01\xbf\xff\x11\x02\x68\x05\xbf\xff\x11\x02\xbf\xff\x11\x02\x63\x03\x2e\x04\x2f\x04\x4b\x03\x4a\x04\x2f\x04\x74\x04\x11\x02\x80\x02\x53\x04\x8d\x05\x95\x03\x97\x04\x64\x02\x34\x00\x04\x04\x11\x02\x66\x03\xbd\xfc\xff\xff\x36\x03\x37\x03\x3e\xfe\x5d\x03\x34\x00\x6f\x05\x58\x01\xbf\xff\x5a\x03\xbd\xfc\xbf\xff\x97\x04\xa5\x04\x06\x02\xb7\x02\x75\x04\x76\x04\xa6\x04\xa7\x04\x37\x05\x38\x05\x39\x05\x3a\x05\xa7\x04\x35\x00\x6b\x03\x83\x05\x3a\x05\xa7\x04\x37\x00\x79\x05\xd0\x00\xb8\x04\xfb\x04\x90\x00\xcb\x04\x7d\x01\xd1\x00\xd2\x00\x07\x01\xf7\x04\x2f\x04\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x07\x02\x9b\x00\x9c\x00\xb2\x01\x33\x00\xb3\x01\x24\x02\x07\x01\x20\x02\x15\x01\x4c\x00\x59\x01\xbb\x01\xd8\x02\xec\x02\x07\x01\x65\x02\x25\x02\xb8\x02\xb9\x04\x4d\x00\x7a\x05\x30\x03\x69\x05\x77\x04\x8c\x03\x34\x00\x12\x02\x92\xfe\x6c\x03\x12\x02\x81\x02\x12\x02\x82\x02\x81\x02\x64\x00\x70\x04\x5b\x03\x13\x02\x67\x00\x12\x02\x4e\x04\x34\x00\xa1\x00\xa2\x00\x34\x00\xef\x01\x34\x00\xed\x02\x12\x02\x4c\x03\xae\x03\x7a\x04\xa3\x00\x72\x00\xef\x01\x26\x02\x73\x00\x74\x00\x21\x01\x83\x03\xf0\x01\xec\x01\xed\x01\xee\x01\x11\x00\x38\x03\x8b\x02\xf8\x02\x21\x01\xef\x01\x8a\x02\x03\x03\x7b\x01\x11\x00\x11\x00\x64\x03\x08\x01\x71\x04\x72\x04\x47\x00\xd3\x00\xa4\x00\x0f\x00\xd4\x00\xef\x01\x93\x02\x30\x01\xf8\x02\x1f\x04\x11\x00\x64\x03\x7c\x00\x7d\x00\x11\x00\xef\x01\xa5\x00\x04\x03\x94\x02\x95\x02\x28\x04\x64\x03\x71\x00\x72\x00\x37\x01\x30\x04\x73\x00\x74\x00\x30\x04\x75\x00\x38\x03\x11\x00\xb4\x02\x21\x01\x11\x00\xda\x01\x7a\x00\x1b\x02\x7b\x00\x11\x00\x38\x01\x9d\x04\x96\x02\x9e\x04\x9f\x04\x76\x00\x71\x04\x72\x04\x47\x00\x56\xff\x13\x02\x0e\x00\x0f\x00\x10\x00\x77\x00\x42\x05\x78\x00\x79\x00\x7a\x00\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x45\x05\x78\x04\x79\x04\x45\x05\x31\x00\x25\x02\x31\x00\x31\x00\xb5\x02\x42\x05\x54\x04\x54\x04\x31\x00\x26\x03\x31\x00\x16\x02\x31\x00\x0e\x01\x56\xff\x30\x04\x4d\x00\x4d\x00\xff\xff\xad\x03\x16\x02\x11\x00\x9d\x04\x16\x02\x9e\x04\x9f\x04\x9d\x04\x16\x02\x9e\x04\x9f\x04\x16\x02\x9d\x04\xae\x03\x9e\x04\x9f\x04\x24\x03\x9d\x04\x01\x02\x9e\x04\x9f\x04\x9d\x04\x38\x01\x9e\x04\x9f\x04\x9d\x04\xef\x01\x9e\x04\x9f\x04\xa8\x04\xfc\x04\xa9\x04\xf0\x01\x47\x00\xa8\x04\x11\x02\xa9\x04\x11\x02\x47\x00\xa8\x04\x4d\x00\xa9\x04\x31\x03\x47\x00\xf7\x01\x21\x01\x4c\x00\xaa\x04\x0f\x00\x10\x00\xff\xff\x11\x00\xaa\x04\x0f\x00\x10\x00\x11\x00\x4d\x00\xaa\x04\x0f\x00\x10\x00\x11\x00\x31\x03\xce\x00\x81\x00\x21\x01\x11\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x11\x00\xe9\x00\xc4\x03\x36\x02\x11\x02\x81\x00\x2b\x03\x09\x03\xf5\x01\xf6\x01\x26\x01\x27\x01\xad\x01\x31\x01\x32\x01\x73\x00\x1f\x01\xea\x00\x38\x03\x05\x03\x00\x03\x21\x01\x6c\x01\xae\x01\x37\x00\xeb\x00\xec\x00\x11\x00\x6d\x01\x11\x02\xed\x00\xfe\x01\x39\x01\x37\x02\x8d\x00\xcf\x00\x88\x03\x3a\x01\x3d\x00\x3e\x00\x3f\x00\xf6\x02\x33\x01\x0a\x03\xef\x01\x82\x03\x8d\x00\x2c\x03\x11\x00\xfd\x01\x7a\x04\x22\x01\x2c\x01\x29\x01\xf4\x02\x06\x03\x01\x03\x1e\x01\x83\x03\x73\x00\x1f\x01\xee\x00\x17\x01\x26\x02\xce\x00\x12\x02\x21\x01\x12\x02\x90\x03\xe6\x00\xe7\x00\xe8\x00\x11\x00\xe9\x00\x87\x03\x52\x05\x81\x03\xfa\x01\xde\x04\x40\x00\x28\x01\x29\x01\x16\x01\x20\x01\x35\x04\x1e\x01\x21\x01\x73\x00\x1f\x01\xea\x00\x96\x02\x90\xfe\x11\x00\x41\x00\x90\xfe\x22\x01\x61\x03\xeb\x00\xec\x00\x92\xfe\xf5\x01\x11\x02\xed\x00\x53\x05\x12\x02\x21\x02\xf6\x01\xcf\x00\x88\x03\x36\x04\x0b\x02\x20\x01\x4f\x01\xec\x03\x21\x01\xd4\x04\x11\x02\xef\x00\xf0\x00\xf1\x00\x11\x00\x6a\x01\x4b\x02\x22\x01\xf2\x00\x0c\x02\x0d\x02\x90\x00\x2f\x02\x12\x02\xf3\x00\xd2\x00\xf7\x01\xee\x00\x4c\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xb4\x04\x9b\x00\x9c\x00\xed\x03\x4d\x00\x28\x01\x29\x01\x84\x02\x08\x01\x2b\x02\x1e\x01\x6d\x01\x73\x00\x1f\x01\x43\x00\x3b\x01\xf4\x01\x45\x00\x46\x00\x2c\x02\x47\x00\x48\x00\x49\x00\xbd\xfc\x88\x03\xf6\x01\x6e\x01\xcf\x04\x73\x00\x1f\x01\x4a\x00\x4b\x00\x4c\x00\x5d\x03\xf6\x01\x15\x01\x20\x01\x42\x03\xf6\x01\x21\x01\xba\xff\x7a\x02\x4d\x00\xa1\x00\xa2\x00\x11\x00\x07\x01\x7b\x02\x22\x01\xef\x00\xf0\x00\xf1\x00\xa4\x01\xa3\x00\x72\x00\x16\x01\xf2\x00\x73\x00\x74\x00\x90\x00\xf3\x04\x12\x02\xf3\x00\xd2\x00\x22\x01\x90\x02\x49\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x83\x03\x9b\x00\x9c\x00\xce\x00\x12\x02\x7c\x02\x1d\x03\x1e\x03\x16\x01\xd3\x00\xa4\x00\x0f\x00\xd4\x00\xff\xff\xf7\x01\x5f\x05\x4c\x00\xf7\x01\x11\x00\x4c\x00\x7c\x00\x7d\x00\xbb\x01\xe7\x01\xa5\x00\xf2\x04\x4d\x00\x57\x04\x58\x04\x4d\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\x50\x01\x9f\x01\x01\x04\xf6\x01\xb5\x03\x6d\x01\x37\x00\xed\x00\x86\xfd\xa1\x00\xa2\x00\x16\x01\xcf\x00\x51\x01\xba\xff\x52\x01\x53\x01\x59\x04\x5e\x04\xa3\x00\x72\x00\xfa\x01\x3f\x00\x73\x00\x74\x00\x77\x00\xc0\x01\x78\x00\x79\x00\x7a\x00\x80\x03\x7b\x00\xee\x03\xdd\x04\x7e\x00\x7f\x00\x6e\x01\x32\x01\x73\x00\x1f\x01\xca\x02\xce\x00\xf7\x01\x81\x03\x4c\x00\x04\x02\xde\x04\xd3\x00\xa4\x00\x0f\x00\xd4\x00\xf7\x01\x14\x03\x4c\x00\x4d\x00\xf7\x01\x11\x00\x4c\x00\x7c\x00\x7d\x00\x03\x02\x40\x00\xa5\x00\x4d\x00\xc1\x01\x57\x04\x58\x04\x4d\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\x15\x03\x16\x03\x22\x01\x41\x00\xcf\x01\x7f\x00\x37\x04\xed\x00\x47\x01\xd0\x01\x15\x05\xf6\x01\xcf\x00\x86\x01\xd3\x04\x02\x02\x38\x04\x59\x04\x5a\x04\x83\x00\x84\x00\x85\x00\xef\x00\xf0\x00\xa4\x02\x5b\x04\x86\x00\xd4\x04\x81\x00\xf2\x00\x03\x02\x6a\x01\x90\x00\xd9\x03\x5a\x02\xa6\x02\xd2\x00\x48\x01\x49\x01\x4a\x01\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xa7\x02\xa8\x02\xa9\x02\x8c\x00\xfb\x02\x2a\x01\x2b\x01\x8f\x00\xfc\x02\xf7\x01\xc8\x02\x4c\x00\x6c\x01\x09\x02\x35\x05\x34\x05\x6d\x01\x0a\x02\x6d\x01\x43\x00\x44\x00\x4d\x00\x45\x00\x46\x00\x8d\x00\x47\x00\x48\x00\x49\x00\x90\x00\x03\x02\x03\x02\x5b\x02\x0f\x00\x10\x00\x18\x03\x4a\x00\x4b\x00\x4c\x00\xff\xff\x11\x00\xd1\x04\xcd\x04\xce\x04\xa1\x00\xa2\x00\x19\x03\x1a\x03\x4d\x00\xb3\x04\xef\x00\xf0\x00\xa4\x02\x5b\x04\xa3\x00\x72\x00\x7b\x05\xf2\x00\x73\x00\x74\x00\x90\x00\x90\x02\xb4\x04\xa6\x02\xd2\x00\x6d\x01\x7c\x05\xf9\x04\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xa7\x02\xa8\x02\xa9\x02\xce\x00\x58\x02\x59\x02\x5a\x02\x83\x03\xbf\x01\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x6e\x01\x6f\x01\x73\x00\x1f\x01\xf7\x01\x11\x00\x4c\x00\x7c\x00\x7d\x00\x1d\x03\x1e\x03\xa5\x00\x5e\x05\xcc\x04\xcd\x04\xce\x04\x4d\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\x6e\x01\x71\x03\x73\x00\x1f\x01\x5f\x05\x31\x02\x16\x04\xed\x00\x4c\x00\xa1\x00\xa2\x00\x32\x02\xcf\x00\xaf\x01\x5b\x02\x0f\x00\x10\x00\x22\x01\x4d\x00\xa3\x00\x72\x00\xad\x02\x11\x00\x73\x00\x74\x00\x39\x02\x61\x05\x6e\x01\xcf\x04\x73\x00\x1f\x01\x11\x00\x2c\x01\x29\x01\x34\x03\xac\x01\x4d\x00\x1e\x01\x22\x01\x73\x00\x1f\x01\xce\x00\x46\x03\x47\x03\x83\x00\x84\x00\x85\x00\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x86\x00\x7b\x01\xde\x01\x2e\x02\x47\x00\x11\x00\x4e\x02\x7c\x00\x7d\x00\x2f\x02\x2f\x02\xa5\x00\x20\x01\xff\xff\x22\x01\x21\x01\xdf\x01\xf4\x00\xf5\x00\xf6\x00\xf7\x00\x11\x00\x8c\x00\xef\x01\x22\x01\xff\xff\x4d\x00\x4c\x01\xed\x00\xd0\x04\x0e\x00\x0f\x00\x10\x00\xcf\x00\x6e\x01\xcf\x04\x73\x00\x1f\x01\x11\x00\x81\x01\xe6\x02\x82\x01\xa3\x02\xef\x00\xf0\x00\xa4\x02\xa5\x02\x72\x03\x87\x01\x44\x00\xf2\x00\x64\x00\x46\x00\x90\x00\x47\x00\x67\x00\xa6\x02\xd2\x00\x81\x00\x84\x01\x83\x01\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xa7\x02\xa8\x02\xa9\x02\x83\x00\x84\x00\x85\x00\x22\x01\x0b\xfd\x2d\x05\x72\x00\x86\x00\x37\x00\x73\x00\x74\x00\x87\x00\xef\x01\x7e\x05\x4d\x01\x35\x01\x4e\x01\x89\x00\xd0\x04\x7f\x05\x77\x04\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x56\x01\x8b\x00\x4c\x01\x33\x02\x8c\x00\x8d\x00\x64\x00\x2f\x02\x8f\x00\x90\x00\x67\x00\xef\x01\x35\x03\xae\x02\xab\x02\xac\x02\xa2\x00\x28\x02\x11\x00\x7c\x00\x7d\x00\xef\x00\xf0\x00\xa4\x02\xa5\x02\xa3\x00\x72\x00\x49\x04\xf2\x00\x73\x00\x74\x00\x90\x00\x09\x02\x11\x00\xa6\x02\xd2\x00\x0a\x02\x93\x02\x40\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xa7\x02\xa8\x02\xa9\x02\x4b\x01\xe6\x02\xf0\x03\x95\x02\xce\x00\x41\x00\xd3\x00\xa4\x00\x0f\x00\xd4\x00\xb9\x02\xb2\x01\x64\x00\xb3\x01\xd0\x01\x11\x00\x67\x00\x7c\x00\x7d\x00\xda\x01\x7a\x00\xa5\x00\x7b\x00\x1d\x03\x1e\x03\x61\x04\x96\x02\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xef\x02\xf0\x02\xf1\x02\xf2\x02\xf3\x02\xcb\x01\x10\x00\xaa\x02\xab\x02\xac\x02\xa2\x00\xed\x00\x11\x00\x30\x01\xcc\x01\x7d\x00\xcf\x00\x62\x04\x68\x04\xa3\x00\x72\x00\x88\x04\x89\x04\x73\x00\x74\x00\x8a\x01\x77\x01\x0f\x00\x10\x00\x8b\x01\x07\x01\x8c\x01\x09\x01\x0a\x01\x11\x00\x43\x00\x44\x00\xff\xff\x45\x00\x46\x00\x64\x00\x47\x00\x48\x00\x49\x00\x67\x00\xce\x00\xff\xff\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x4a\x00\x4b\x00\x4c\x00\xef\x01\x1c\x01\x11\x00\xd4\x03\x7c\x00\x7d\x00\xc5\x04\xd5\x03\xa5\x00\x4d\x00\x3b\x02\x7a\x00\x61\x04\x7b\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xe7\x02\x81\x00\xe4\x02\xfc\x01\x1a\x01\x46\x00\x92\xfe\x47\x00\x98\x02\xff\xff\x99\x02\xed\x00\x83\x00\x84\x00\x85\x00\x39\x02\xcf\x00\x62\x04\x63\x04\x86\x00\x19\x01\x11\x00\x26\x04\xcc\x01\x7d\x00\x21\x01\xef\x00\xf0\x00\xa4\x02\x64\x04\xd4\x03\x11\x00\xd7\x02\xf2\x00\x91\x04\xd8\x02\x90\x00\x9a\x02\x18\x03\xa6\x02\xd2\x00\x8c\x00\x8d\x00\x81\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xa7\x02\xa8\x02\xa9\x02\x0b\x05\x0c\x05\x83\x00\x84\x00\x85\x00\x52\x03\x53\x03\x54\x03\x37\x00\x86\x00\xf6\x03\x87\x00\x11\x03\x21\x01\xd4\x03\x2f\x05\xe8\x02\x89\x00\x4e\x05\x11\x00\x0f\x02\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x98\xfe\x8b\x00\x56\x01\x98\xfe\x0f\x03\x8e\x00\x8c\x00\x8d\x00\x0b\x05\x59\x05\x8f\x00\x90\x00\x50\x05\xcd\x04\xce\x04\xa1\x00\xa2\x00\x41\x01\x42\x01\x43\x01\x44\x01\xef\x00\xf0\x00\xa4\x02\x64\x04\xa3\x00\x72\x00\x64\x00\xf2\x00\x73\x00\x74\x00\x90\x00\x87\x02\xff\x02\xa6\x02\xd2\x00\x01\x02\xff\x01\x40\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xa7\x02\xa8\x02\xa9\x02\xce\x00\xfe\x01\xff\x01\xc0\x02\x10\x00\x41\x00\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x11\x00\x3e\x03\xcc\x01\x7d\x00\x46\x00\x11\x00\x47\x00\x7c\x00\x7d\x00\x07\x03\x90\x01\xa5\x00\x91\x01\xf7\x02\x57\x04\x58\x04\xeb\x02\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xb5\x02\x0f\x00\x10\x00\xb2\x02\x0f\x00\x10\x00\xfc\x01\xed\x00\x11\x00\xa1\x00\xa2\x00\x11\x00\xcf\x00\xe3\x02\xce\x01\x9f\x01\x7a\x00\x04\x05\x7b\x00\xa3\x00\x72\x00\xcf\x01\x7f\x00\x73\x00\x74\x00\xe2\x02\xd0\x01\x6e\x01\xcf\x04\x73\x00\x1f\x01\xdf\x02\xaf\x02\x0f\x00\x10\x00\x43\x00\x44\x00\xe1\x02\x45\x00\x46\x00\x11\x00\x47\x00\x48\x00\x49\x00\x0d\x03\xd4\x02\xd5\x02\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x4a\x00\x4b\x00\x4c\x00\xe0\x02\x81\x01\x11\x00\x82\x01\x7c\x00\x7d\x00\xdb\x02\x2f\x05\xa5\x00\x4d\x00\x46\x00\x22\x01\x47\x00\xd9\x02\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf1\x01\x59\x01\xef\x01\xd3\x02\xd4\x02\xd5\x02\x00\x05\xfe\x04\xd0\x04\x86\x01\x87\x01\x44\x00\xca\x02\x74\x02\x46\x00\x75\x02\x47\x00\xce\x01\x9f\x01\x7a\x00\xcb\x02\x7b\x00\xef\x00\xf0\x00\xa4\x02\x5b\x04\x88\x01\xce\x00\x4c\x00\xf2\x00\xc7\x02\x1d\x04\x90\x00\x1e\x04\xc0\x02\xa6\x02\xd2\x00\xbf\x02\x4d\x00\x40\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xa7\x02\xa8\x02\xa9\x02\x61\x04\x74\x03\x72\x01\x73\x01\x74\x01\x41\x00\x75\x01\xe2\x03\xe3\x03\xe4\x03\x1e\x01\xb9\x01\x73\x00\x1f\x01\xce\x01\x9f\x01\x7a\x00\xed\x00\x7b\x00\x37\x00\x7e\x01\xb5\x01\xcf\x00\x0c\x05\xd4\x01\x4d\x02\xd5\x01\xe8\x02\x15\x04\xd6\x01\x16\x04\xc5\x02\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x20\x01\x7e\x01\x7f\x01\x21\x01\xa1\x00\xa2\x00\x7d\x01\x79\x01\x57\x02\x11\x00\xf7\xfc\x81\x01\x22\x01\x82\x01\xa3\x00\x72\x00\x4c\x02\xd9\x01\x73\x00\x74\x00\x21\x01\x47\x03\x48\x03\x49\x03\xbd\x02\xbb\x01\x11\x00\xe6\x03\x7c\x00\x7d\x00\x43\x00\x44\x00\xbc\x02\xd0\x03\x46\x00\xd1\x03\x47\x00\x69\x02\x40\x00\x07\x04\x08\x04\x09\x04\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x4a\x00\x40\x00\x4c\x00\x7b\x01\x79\x01\x11\x00\x41\x00\x7c\x00\x7d\x00\x78\x01\x79\x01\xa5\x00\x4d\x00\xbb\x02\x6d\x04\x41\x00\x6e\x04\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xec\x01\xef\x00\xf0\x00\xa4\x02\x64\x04\xce\x00\x3b\x02\x7a\x00\xf2\x00\x7b\x00\x4d\x04\x90\x00\x4e\x04\xb9\x02\xa6\x02\xd2\x00\xf0\x04\xd0\x01\xf1\x04\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xa7\x02\xa8\x02\xa9\x02\x7b\x04\x08\x04\x09\x04\x6e\x04\x08\x04\x09\x04\xc2\x04\x08\x04\x09\x04\x8e\x05\x08\x04\x09\x04\x93\x05\x08\x04\x09\x04\xe4\x04\xed\x00\xe5\x04\x8e\x02\x43\x00\x44\x00\xcf\x00\x45\x00\x46\x00\x8d\x02\x47\x00\x48\x00\x49\x00\x43\x00\x44\x00\xe9\x04\xa3\x04\x46\x00\xa4\x04\x47\x00\x4a\x00\x4b\x00\x4c\x00\x44\x01\x45\x01\xa1\x00\xa2\x00\x8f\x02\xf0\x04\x4a\x00\xf1\x04\x4c\x00\x4d\x00\x2d\x01\x2e\x01\xa3\x00\x72\x00\xfc\x02\xfd\x02\x73\x00\x74\x00\x4d\x00\x87\x00\x6d\x03\x6e\x03\x60\x02\x35\x01\xb9\x01\x89\x00\x90\x02\x49\x00\x88\x02\xbd\xfc\x7e\x01\x10\x04\xfa\x03\xfb\x03\x8b\x00\x80\x02\x56\x00\x5f\x04\x54\x03\x7d\x02\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x86\x02\x57\x00\x79\x02\x58\x00\x59\x00\x11\x00\x78\x02\x7c\x00\x7d\x00\x07\x01\x5b\x00\xa5\x00\x65\x05\x66\x05\x6a\x02\xfd\x04\xfe\x04\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xef\x00\xf0\x00\xa4\x02\xa5\x02\xce\x00\x71\x02\x70\x02\xf2\x00\x6f\x02\x6e\x02\x90\x00\x65\x00\x66\x00\xa6\x02\xd2\x00\x68\x00\x69\x00\x69\x02\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xa7\x02\xa8\x02\xa9\x02\x68\x02\xbb\x01\x60\x02\x50\x02\x4f\x02\x4d\x02\x4c\x02\x4a\x02\x49\x02\x48\x02\x39\x02\x38\x02\x35\x02\x2a\x02\x34\x02\x30\x02\xed\x00\x0e\x01\x2d\x02\x01\x02\xc8\x03\xcf\x00\xb8\x02\x72\x01\x73\x01\x74\x01\xc7\x03\x75\x01\x0f\x02\x37\x00\xe8\x04\x1e\x01\xc6\x03\x73\x00\x1f\x01\xc3\x03\xbc\x03\xe8\x02\xbd\x03\xbb\x03\xa1\x00\xa2\x00\x3a\x01\x3d\x00\x3e\x00\x3f\x00\xd8\xfc\xf6\xfc\xe1\xfc\xdf\xfc\xa3\x00\x72\x00\x1d\x01\xe0\xfc\x73\x00\x74\x00\x1e\x01\x20\x01\x73\x00\x1f\x01\x21\x01\xf5\xfc\xd9\xfc\xda\xfc\x3b\x02\x7a\x00\x11\x00\x7b\x00\xba\x03\x22\x01\x37\x02\xb9\x02\xb9\x03\xd4\x04\xb8\x03\xd0\x01\xb7\x03\xb4\x03\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x20\x01\xb3\x03\x40\x00\x21\x01\xb2\x03\x11\x00\xab\x03\x7c\x00\x7d\x00\x11\x00\xa1\x03\xa5\x00\x22\x01\x6d\x01\xc4\x02\x8f\x03\x41\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xef\x00\xf0\x00\xa4\x02\xa5\x02\xce\x00\x30\x02\x8d\x03\xf2\x00\x8b\x03\x8e\x03\x90\x00\x84\x03\x7f\x03\xa6\x02\xd2\x00\x7e\x03\x7d\x03\x7b\x03\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xa7\x02\xa8\x02\xa9\x02\x7a\x03\x7c\x03\x79\x03\x78\x03\x37\x00\x77\x03\x74\x03\x71\x03\x70\x03\x57\x03\x6a\x01\x62\x03\xd5\x04\x5f\x03\x0a\xfd\x52\x03\xed\x00\x3a\x01\x3d\x00\x3e\x00\x3f\x00\xcf\x00\x50\x03\x4e\x03\xd4\x01\x44\x03\xd5\x01\x2e\x03\x23\x03\xd6\x01\x43\x00\x44\x00\xd7\x01\x45\x00\x46\x00\x8b\x00\x47\x00\x48\x00\x49\x00\x30\x01\xa1\x00\xa2\x00\x22\x03\x29\x03\xd8\x01\x21\x03\x4a\x00\x4b\x00\x4c\x00\x0e\x01\xa3\x00\x72\x00\xf0\x03\xd9\x01\x73\x00\x74\x00\x21\x01\x81\x00\x4d\x00\x40\x00\xda\x01\x7a\x00\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x83\x00\x84\x00\x85\x00\x08\x05\x39\x04\x41\x00\xcd\x03\x86\x00\x3b\x04\x34\x04\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x2e\x04\x2c\x04\x2b\x04\x28\x04\x6c\x01\x11\x00\x01\xfd\x7c\x00\x7d\x00\x2a\x04\x6d\x01\xa5\x00\x00\xfd\x02\xfd\x26\x04\x8c\x00\x8d\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xef\x00\xf0\x00\xa4\x02\xf9\x03\x25\x04\x23\x04\x13\x04\xf2\x00\x19\x04\x5d\x03\x90\x00\x0d\x04\x0e\x04\xa6\x02\xd2\x00\x0b\x04\x07\x04\x03\x04\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xa7\x02\xa8\x02\xa9\x02\x03\x05\x01\x04\x37\x00\xc4\x02\xf5\x03\x43\x00\x44\x00\xff\x03\x45\x00\x46\x00\xe8\x02\x47\x00\x48\x00\x49\x00\x6a\x00\x3a\x01\x3d\x00\x3e\x00\x3f\x00\xe0\x03\xf0\x03\x4a\x00\x4b\x00\x4c\x00\xe7\x03\x75\x03\x74\x01\xe1\x03\x75\x01\x36\x02\xd8\x03\x08\x01\x1e\x01\x4d\x00\x73\x00\x1f\x01\x6d\x05\xd7\x03\xcd\x03\xa1\x04\xa1\x00\xa2\x00\x99\x04\x93\x04\x90\x04\x68\x02\x08\x01\x07\x01\x5d\x03\x8e\x04\xa3\x00\x72\x00\xbb\x01\x8a\x04\x73\x00\x74\x00\x41\x04\x40\x00\x20\x01\x84\x03\x37\x00\x21\x01\x82\x04\x81\x04\x80\x04\x0d\x04\x7f\x04\x11\x00\xe8\x02\x0b\x04\x22\x01\x41\x00\x0b\x04\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x07\x01\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x70\x01\x71\x01\x72\x01\x73\x01\x74\x01\x11\x00\x75\x01\x7c\x00\x7d\x00\x57\x04\x1e\x01\xa5\x00\x73\x00\x1f\x01\x37\x00\x51\x04\x4c\x04\xf4\x00\xf5\x00\xf6\x00\xf7\x00\x48\x04\xe8\x02\xcc\x02\x45\x04\x47\x04\x44\x04\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x43\x04\x42\x04\x40\x00\x41\x04\x21\x03\x20\x01\xec\x04\xeb\x04\x21\x01\xe7\x04\xe6\x04\xe0\x04\xdb\x04\x4a\x01\x11\x00\x08\x01\x41\x00\x22\x01\xc5\x04\x43\x00\x44\x00\x0b\x04\x45\x00\x46\x00\xbc\x04\x47\x00\x48\x00\x49\x00\x81\x00\x55\x01\xac\xfe\xbb\x04\x25\x05\xac\xfe\x33\x05\x4a\x00\x4b\x00\x4c\x00\x40\x00\x83\x00\x84\x00\x85\x00\x37\x00\xb1\x04\x1c\x01\x27\x05\x86\x00\x4d\x00\x4d\x01\x20\x05\x4e\x01\x1f\x05\x41\x00\x1e\x05\x14\x05\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x11\x05\x15\x05\x94\x01\x72\x00\x13\x05\x56\x01\x73\x00\x74\x00\x10\x05\x8c\x00\x8d\x00\x0f\x05\x0e\x05\x8f\x00\x90\x00\xf6\x04\x59\x01\x64\x05\x43\x00\x44\x00\x52\x03\x45\x00\x46\x00\x6a\x05\x47\x00\x48\x00\x49\x00\x63\x05\x66\x03\x5d\x05\x4d\x05\x95\x01\x0f\x00\x10\x00\x4a\x00\x4b\x00\x4c\x00\x08\x01\x40\x00\x11\x00\x4e\x05\x7c\x00\x7d\x00\x49\x05\x40\x05\x3f\x05\x4d\x00\x5b\x05\x37\x05\x80\x05\x3e\x05\x76\x05\x41\x00\x7d\x05\x43\x00\x44\x00\x3d\x05\x45\x00\x46\x00\x81\x05\x47\x00\x48\x00\x49\x00\xcd\x03\x07\x01\x72\x05\x59\xfe\x6d\x05\x0d\x04\x0b\x04\x4a\x00\x4b\x00\x4c\x00\x92\x05\xc6\x03\x8d\x05\xcd\x03\x37\x00\x99\x05\x98\x05\x96\x05\x0b\x04\x4d\x00\x67\x03\x93\x05\x68\x03\x9b\x05\x0c\x01\xcd\x01\xbc\x01\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xb4\x01\xb0\x01\x37\x00\x8e\x01\x84\x01\x56\x01\x3f\x01\x35\x01\x67\x03\x1a\x01\x68\x03\x13\x03\x0f\x03\x12\x03\x11\x03\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x43\x00\x44\x00\x07\x03\x45\x00\x46\x00\x01\x03\x47\x00\x48\x00\x49\x00\x0a\x03\xf3\x02\xcb\x02\xed\x02\xd9\x02\xe3\x01\x84\x02\x4a\x00\x4b\x00\x4c\x00\x40\x00\xbd\x02\x72\x02\x25\x03\x29\x01\x22\x02\x0a\x02\x66\x02\x1e\x01\x4d\x00\x73\x00\x1f\x01\xcd\x02\x9a\x02\x41\x00\x07\x02\x37\x00\xca\x03\x0f\x02\x40\x00\x55\x02\x9b\x02\xce\x02\xc9\x03\x3b\x00\x9d\x02\x18\x03\xc8\x03\x64\x02\xcf\x02\x3d\x00\x3e\x00\x3f\x00\x41\x00\x20\x01\xae\x03\x5f\x03\x21\x01\x5f\x03\x55\x03\xb5\x03\x50\x03\x4e\x03\x11\x00\x8f\x03\x85\x03\x22\x01\x84\x03\x4c\x03\x44\x03\x34\x03\x9a\x02\x29\x03\x2c\x03\x37\x00\x1f\x03\x27\x03\x1e\x03\x1b\x03\x9b\x02\x9c\x02\x3f\x04\x3e\x04\x9d\x02\x3b\x04\x3d\x04\x39\x04\x9e\x02\x3d\x00\x3e\x00\x3f\x00\x40\x00\x3c\x04\x2c\x04\x1e\x04\x43\x00\x44\x00\x21\x04\x45\x00\x46\x00\x1b\x04\x47\x00\x48\x00\x49\x00\x13\x04\x41\x00\x0b\x04\x0f\x04\x11\x04\xf5\x03\xee\x03\x4a\x00\x4b\x00\x4c\x00\x43\x00\x44\x00\xe7\x03\x45\x00\x46\x00\xce\x03\x47\x00\x48\x00\x49\x00\x4d\x00\xcd\x03\xcb\x03\x8e\x04\x64\x02\x8c\x04\x40\x00\x4a\x00\x4b\x00\x4c\x00\x7c\x04\x77\x04\x55\x04\x60\x04\x33\x03\xf1\x04\xee\x04\x37\x00\xed\x04\x4d\x00\x41\x00\xe2\x04\x9b\x02\x9c\x02\xd0\x02\x45\x04\x9d\x02\xe1\x04\x13\x00\xde\x04\x9e\x02\x3d\x00\x3e\x00\x3f\x00\xd9\x04\xe0\x04\x14\x00\xdb\x04\xc3\x04\xc9\x04\xca\x04\xb1\x04\xb9\x04\x43\x00\x44\x00\x31\x05\x45\x00\x46\x00\x15\x00\x47\x00\x48\x00\x49\x00\xa1\x04\x30\x05\x17\x00\x18\x00\x19\x00\x25\x05\x22\x05\x4a\x00\x4b\x00\x4c\x00\x9f\x02\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x21\x05\x09\x05\x24\x00\x4d\x00\x40\x00\x11\x05\x02\x05\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x43\x00\x44\x00\xa0\x02\x45\x00\x46\x00\x41\x00\x47\x00\x48\x00\x49\x00\xf9\x04\xf4\x04\x6a\x05\x60\x05\x81\x00\x64\x05\x5f\x05\x4a\x00\x4b\x00\x4c\x00\x5a\x05\xd2\x01\x47\x05\xd3\x01\x57\x05\x83\x00\x84\x00\x85\x00\xf7\x03\x4d\x00\x77\x05\x37\x00\x86\x00\x46\x05\x76\x05\x87\x05\x9b\x02\x9c\x02\x8f\x05\x8b\x05\x9d\x02\xa0\x02\x94\x05\x6c\x01\x9e\x02\x3d\x00\x3e\x00\x3f\x00\x9f\x02\x6d\x01\x9b\x05\x00\x00\x85\x05\x96\x05\x8c\x00\x8d\x00\x00\x00\x99\x05\x8f\x00\x90\x00\x00\x00\x18\x02\x19\x02\x8b\x05\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x1a\x02\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x40\x00\xe9\x01\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x00\x00\x4f\x04\x4d\x00\x00\x00\x37\x00\x5b\x00\x00\x00\x41\x00\x00\x00\x9b\x02\x9c\x02\x00\x00\x00\x00\x9d\x02\xa0\x02\x00\x00\x92\x02\x9e\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x6d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x66\x00\x00\x00\x00\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x04\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x02\x9c\x02\x9f\x02\x00\x00\x9d\x02\x00\x00\x00\x00\x00\x00\x9e\x02\x3d\x00\x3e\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x41\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x40\x00\xa7\x01\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x02\x59\x05\x00\x00\x41\x00\x37\x00\x00\x00\x00\x00\x9f\x02\x00\x00\x9b\x02\x9c\x02\x00\x00\x00\x00\x9d\x02\x00\x00\x00\x00\x00\x00\x9e\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x75\x02\x76\x02\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x9f\x02\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\xa0\x02\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x41\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x51\x05\x4d\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x02\x9c\x02\x00\x00\x00\x00\x9d\x02\xa0\x02\x00\x00\x00\x00\x9e\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x37\x00\x00\x00\x9f\x02\x00\x00\x00\x00\x00\x00\xc0\x04\x00\x00\xc1\x04\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x05\x4d\x00\x41\x00\x17\x05\x18\x05\x19\x05\x2a\x05\x40\x00\x1a\x05\x3f\x00\x00\x00\x00\x00\x00\x00\xa0\x02\x00\x00\x2b\x05\x00\x00\x83\x00\x84\x00\x85\x00\x00\x00\x41\x00\x00\x00\x37\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x05\x00\x00\x00\x00\x00\x00\x73\x05\x19\x05\x00\x00\x00\x00\x1a\x05\x3f\x00\x00\x00\x00\x00\x37\x00\x00\x00\x9f\x02\x00\x00\x8c\x00\x2c\x05\x40\x00\x00\x00\x8f\x00\x2d\x05\x00\x00\x00\x00\x4b\x05\x00\x00\x00\x00\x1a\x05\x3f\x00\x00\x00\x74\x05\x00\x00\x41\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x4a\x00\x4b\x00\x4c\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4d\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x81\x00\xa0\x02\x49\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x41\x00\x00\x00\x83\x00\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x01\x4a\x00\x4b\x00\x4c\x00\x8c\x00\x8d\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x1c\x05\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x37\x00\x1c\x05\x00\x00\x00\x00\x1e\x02\xf2\x03\xce\x02\x4d\x00\x3b\x00\x9d\x02\x00\x00\x00\x00\x81\x00\xcf\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x1c\x05\x00\x00\x00\x00\x83\x00\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x37\x00\x86\x00\x00\x00\x00\x00\x1d\x02\xf1\x03\xce\x02\x00\x00\x3b\x00\x9d\x02\x00\x00\x00\x00\x6c\x01\xcf\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x6d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x8d\x00\x00\x00\x40\x00\x8f\x00\x90\x00\x37\x00\x00\x00\x00\x00\x00\x00\xc4\x03\x6a\x04\xce\x02\x00\x00\x3b\x00\x9d\x02\x00\x00\x41\x00\x00\x00\xcf\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\xc6\x04\x50\x01\x40\x03\x9c\x02\x00\x00\x00\x00\x9d\x02\x00\x00\x41\x00\x00\x00\x9e\x02\x3d\x00\x3e\x00\x3f\x00\xc5\x01\xc7\x04\x52\x01\x53\x01\x00\x00\x00\x00\x00\x00\xd0\x02\x00\x00\x40\x00\x00\x00\x00\x00\x77\x00\x00\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x7e\x00\x7f\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\xd0\x02\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\xd0\x02\xa0\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x9f\x02\xa0\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\xa0\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x37\x00\x00\x00\x00\x00\xc6\x04\x00\x00\x40\x03\x9c\x02\x00\x00\x4d\x00\x9d\x02\x00\x00\x00\x00\x81\x00\x9e\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x4f\x05\x00\x00\xa0\x02\x00\x00\x00\x00\x83\x00\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x37\x00\x86\x00\x00\x00\x41\x03\x00\x00\x40\x03\x9c\x02\x00\x00\x00\x00\x9d\x02\x00\x00\x00\x00\x00\x00\x9e\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x56\x01\x00\x00\x00\x00\x00\x00\x8c\x00\x8d\x00\x00\x00\x40\x00\x8f\x00\x90\x00\x37\x00\x00\x00\x00\x00\x3f\x03\x00\x00\x40\x03\x9c\x02\x00\x00\x00\x00\x9d\x02\x00\x00\x41\x00\x00\x00\x9e\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x50\x01\xf2\x03\x9c\x02\x00\x00\x00\x00\x9d\x02\x00\x00\x41\x00\x00\x00\x9e\x02\x3d\x00\x3e\x00\x3f\x00\x51\x01\x00\x00\x52\x01\x53\x01\x00\x00\x00\x00\x00\x00\x9f\x02\x00\x00\x40\x00\x00\x00\x00\x00\x77\x00\x00\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x7e\x00\x7f\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x9f\x02\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x9f\x02\xa0\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x9f\x02\xa0\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\xa0\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x03\x9c\x02\x00\x00\x4d\x00\x9d\x02\x00\x00\x00\x00\x00\x00\x9e\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\xa0\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x04\x9c\x02\x00\x00\x00\x00\x9d\x02\x00\x00\x00\x00\x00\x00\x9e\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x04\x9c\x02\x00\x00\x00\x00\x9d\x02\x00\x00\x41\x00\x00\x00\x9e\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x50\x01\x6b\x04\x9c\x02\x00\x00\x00\x00\x9d\x02\x00\x00\x41\x00\x00\x00\x9e\x02\x3d\x00\x3e\x00\x3f\x00\xc8\x02\x00\x00\x52\x01\x53\x01\x00\x00\x00\x00\x00\x00\x9f\x02\x00\x00\x40\x00\x00\x00\x00\x00\x77\x00\x00\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x7e\x00\x7f\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x9f\x02\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x9f\x02\xa0\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x9f\x02\xa0\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\xa0\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\x3a\x02\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\xe0\x01\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x00\x00\x00\x00\xe1\x01\xe2\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x37\x00\x00\x00\xe5\x01\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x81\x00\x55\x01\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x83\x00\x84\x00\x85\x00\x40\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x56\x01\x00\x00\x00\x00\x00\x00\x8c\x00\x8d\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x02\x7a\x00\x4d\x00\x7b\x00\x00\x00\x00\x00\xcf\x01\x7f\x00\x50\x01\x00\x00\x00\x00\xd0\x01\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\xc5\x01\x00\x00\x52\x01\x53\x01\x42\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x77\x00\x00\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x4d\x00\x00\x00\x7e\x00\x7f\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\xe3\x01\x47\x00\xe6\x01\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\xe5\x01\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\xe7\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x02\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x55\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xe3\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x02\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x13\x00\x41\x00\x55\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x14\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xb1\x02\x00\x00\x00\x00\x00\x00\x40\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x42\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x41\x00\x47\x00\xe6\x01\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x70\x05\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\xe7\x01\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x4a\x00\x4b\x00\x4c\x00\x18\x02\x19\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x00\x00\x1a\x02\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x02\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\x00\x00\x00\x00\x55\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x1a\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x03\x00\x00\x00\x00\xff\x03\x37\x00\x00\x00\x00\x00\x00\x00\x55\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x03\x40\x00\x00\x00\xfd\x03\x37\x00\x00\x00\x00\x00\x00\x00\x55\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x03\x40\x00\x00\x00\xbf\x04\x37\x00\x00\x00\x00\x00\x00\x00\x55\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x02\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\x00\x00\x00\x00\x55\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x44\x02\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xdc\x02\x46\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x44\x02\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x45\x02\x46\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x44\x02\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\xc1\x03\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\x44\x02\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\xc0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\xbe\x03\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x03\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x44\x02\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\xbd\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x44\x02\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\xd8\x03\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\x23\x04\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x38\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\xea\x01\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x91\x01\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x54\x05\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\x00\x00\x00\x00\x1b\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x90\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x01\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x1c\x02\x37\x00\x00\x00\x23\x04\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x01\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x1b\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\xa1\x00\xa2\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x40\x00\x00\x00\x20\x04\x37\x00\x00\x00\x00\x00\x00\x00\x1b\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x42\x00\x00\x00\x40\x00\x11\x00\x19\x04\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\x00\x00\x00\x00\x1b\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x90\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\xa5\x01\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x05\x04\x37\x00\x00\x00\x00\x00\x00\x00\x1b\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\xd2\x03\x37\x00\x00\x00\x00\x00\x00\x00\x1b\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\xa1\x00\xa2\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x40\x00\x00\x00\x51\x04\x37\x00\x00\x00\xfa\x04\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x42\x00\x00\x00\x40\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\x00\x00\x00\x00\x1b\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x90\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x01\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x56\x05\x37\x00\x00\x00\x00\x00\x00\x00\x1e\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x1d\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\xa1\x00\xa2\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\xc4\x03\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x42\x00\x00\x00\x40\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\x00\x00\x00\x00\xd3\x03\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\xf6\x04\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\xe6\x02\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x02\x00\x00\x40\x00\x00\x00\x00\x00\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x37\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x02\x81\x00\xc7\x01\x42\x00\x00\x00\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x41\x00\x00\x00\x00\x00\x83\x00\x84\x00\x85\x00\xc8\x01\xc9\x01\xca\x01\xcb\x01\x86\x00\x00\x00\x40\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x41\x00\x00\x00\x56\x01\x4a\x00\x4b\x00\x4c\x00\x8c\x00\x8d\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x40\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x43\x00\x44\x00\x4d\x00\x45\x00\x46\x00\x1f\x02\x47\x00\x48\x00\x49\x00\x00\x00\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x43\x00\x44\x00\x4d\x00\x45\x00\x46\x00\x57\x03\x47\x00\x48\x00\x49\x00\x00\x00\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x40\x00\x00\x00\x4d\x00\x00\x00\x00\x00\x0e\x04\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x41\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x03\x00\x00\x40\x00\x00\x00\x00\x00\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x04\x00\x00\x40\x00\x00\x00\x00\x00\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x4d\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x4d\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x43\x00\x44\x00\x4d\x00\x45\x00\x46\x00\x52\x04\x47\x00\x48\x00\x49\x00\x00\x00\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x00\x00\x00\x00\x07\x05\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x05\x00\x00\x40\x00\x00\x00\x00\x00\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x81\x00\x07\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x37\x00\x00\x00\x83\x00\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x4a\x05\x86\x00\x40\x00\x00\x00\x00\x00\x3a\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x37\x00\x56\x01\x00\x00\x40\x00\x00\x00\x8c\x00\x8d\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x00\x00\x89\x03\x3d\x00\x3e\x00\x3f\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x4d\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x4d\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x4d\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x11\x02\xa7\x00\x13\x00\xa8\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x02\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xa8\x03\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\xd6\x00\xd7\x00\xd8\x00\xfd\x00\xd9\x00\x00\x00\xfe\x00\x00\x00\x15\x00\x00\x00\xff\x00\x00\x00\x16\x00\x00\x01\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x01\x01\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdb\x00\xdc\x00\xdd\x00\x00\x00\x02\x01\xb0\x00\xde\x00\xb2\x00\x03\x01\x04\x01\x00\x00\x00\x00\x05\x01\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x06\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x07\x01\x08\x01\x09\x01\x0a\x01\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x66\x04\x67\x04\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\xd6\x00\xd7\x00\xd8\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x68\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x01\x01\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdb\x00\xdc\x00\xdd\x00\x00\x00\x00\x00\xb0\x00\xde\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x06\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x07\x01\x08\x01\x09\x01\x0a\x01\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x5d\x04\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\xd6\x00\xd7\x00\xd8\x00\x00\x00\xd9\x00\x00\x00\xfe\x00\x00\x00\x15\x00\x00\x00\x5e\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x01\x01\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdb\x00\xdc\x00\xdd\x00\x00\x00\x00\x00\xb0\x00\xde\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x06\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x07\x01\x08\x01\x09\x01\x0a\x01\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x66\x04\x67\x04\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\xd6\x00\xd7\x00\xd8\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x68\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x01\x01\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdb\x00\xdc\x00\xdd\x00\x00\x00\x00\x00\xb0\x00\xde\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x06\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x07\x01\x08\x01\x09\x01\x0a\x01\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x5d\x04\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\xd6\x00\xd7\x00\xd8\x00\x00\x00\xd9\x00\x00\x00\xfe\x00\x00\x00\x15\x00\x00\x00\x5e\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x01\x01\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdb\x00\xdc\x00\xdd\x00\x00\x00\x00\x00\xb0\x00\xde\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x06\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x07\x01\x08\x01\x09\x01\x0a\x01\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\xd6\x00\xd7\x00\xd8\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x01\x01\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdb\x00\xdc\x00\xdd\x00\x00\x00\x00\x00\xb0\x00\xde\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x06\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x07\x01\x08\x01\x09\x01\x0a\x01\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x6a\x01\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x6b\x01\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x6c\x01\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x6d\x01\x6e\x01\xbb\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x6a\x01\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x9f\x01\xba\x00\x00\x00\x00\x00\x6d\x01\x6e\x01\xbb\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x6a\x01\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x6b\x01\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x6c\x01\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x6d\x01\x6e\x01\xbb\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x4b\x02\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x2f\x02\x6e\x01\xbb\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x4e\x02\xba\x00\x00\x00\x00\x00\x2f\x02\x6e\x01\xbb\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\xa4\x01\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x6e\x01\xbb\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xc4\x02\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x6e\x01\xbb\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x2f\x02\x6e\x01\xbb\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xd8\xfd\xd8\xfd\xd8\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xd8\xfd\x00\x00\xd8\xfd\xd8\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\xfd\x00\x00\x00\x00\x00\x00\xd8\xfd\x00\x00\x00\x00\x00\x00\xd8\xfd\x00\x00\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\x00\x00\xd8\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\x00\x00\xd8\xfd\x00\x00\x00\x00\x00\x00\xd8\xfd\x00\x00\xd8\xfd\xd8\xfd\xd8\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xd8\xfd\xd8\xfd\xd8\xfd\x00\x00\x00\x00\x00\x00\xd8\xfd\x00\x00\x00\x00\x00\x00\xd8\xfd\x00\x00\xd8\xfd\x00\x00\xd8\xfd\x00\x00\x00\x00\x00\x00\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\x00\x00\xd8\xfd\x00\x00\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd7\xfd\xd7\xfd\xd7\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xfd\x00\x00\xd7\xfd\xd7\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xfd\x00\x00\x00\x00\x00\x00\xd7\xfd\x00\x00\x00\x00\x00\x00\xd7\xfd\x00\x00\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\x00\x00\xd7\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\x00\x00\xd7\xfd\x00\x00\x00\x00\x00\x00\xd7\xfd\x00\x00\xd7\xfd\xd7\xfd\xd7\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xfd\xd7\xfd\xd7\xfd\x00\x00\x00\x00\x00\x00\xd7\xfd\x00\x00\x00\x00\x00\x00\xd7\xfd\x00\x00\xd7\xfd\x00\x00\xd7\xfd\x00\x00\x00\x00\x00\x00\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\x00\x00\xd7\xfd\x00\x00\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xd7\xfd\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\xd6\x00\xd7\x00\xd8\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\xda\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdb\x00\xdc\x00\xdd\x00\x00\x00\x00\x00\xb0\x00\xde\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x6e\x01\xbb\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x03\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xa8\x03\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\xae\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xbb\x01\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x01\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\xae\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x15\x00\x9e\x03\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xa8\x03\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\xae\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x15\x00\x9e\x03\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\xeb\x03\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\xaa\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\xab\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\xab\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xa7\x00\x13\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x14\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x94\x03\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xa7\x00\x13\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x14\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x2c\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x4f\x00\x13\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x14\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x63\x00\x50\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x01\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\xea\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x01\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x50\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\xe5\x01\x00\x00\x00\x00\x00\x00\x6d\x01\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x50\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x3e\x02\x3f\x02\x40\x02\x00\x00\x00\x00\x00\x00\x00\x00\x41\x02\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x6c\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x01\x61\x00\x62\x00\x63\x00\x64\x00\x42\x02\x43\x02\x00\x00\x67\x00\x68\x00\x44\x02\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xa2\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\xc9\x04\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x90\x00\x00\x00\x00\x00\x00\x00\xd2\x02\x07\x01\x00\x00\x14\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x50\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\xec\x01\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x3e\x01\x3f\x01\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\xa7\x01\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xd2\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x75\x02\xa1\x03\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x01\x00\x00\x14\x00\x00\x00\x00\x00\xb3\x01\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xa2\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x01\x00\x00\x14\x00\x00\x00\x00\x00\xaf\x01\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xd2\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x01\x00\x00\x14\x00\x00\x00\x00\x00\xa6\x01\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xa2\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x01\x00\x00\x14\x00\x00\x00\x00\x00\xa4\x01\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xd2\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x01\x00\x00\x14\x00\x00\x00\x00\x00\x59\x01\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xa2\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x01\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x04\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xea\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\xd8\x04\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x1c\x01\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xa2\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x01\x00\x00\x14\x00\x00\x00\x00\x00\x0c\x03\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x50\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x0b\x03\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xea\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x02\x05\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\xc1\x01\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xea\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x05\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x71\x02\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x50\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x5e\x02\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x50\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x56\x05\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x23\x03\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x88\xfe\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x01\x00\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xea\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x98\x01\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x6a\x03\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xea\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x6a\x03\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xea\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x13\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x14\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x01\x63\x00\x64\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x28\x02\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x2c\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x3d\x03\x17\x00\x18\x00\x19\x00\x3a\x03\x3b\x03\x3c\x03\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x03\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\xb7\x04\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x03\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x02\x19\x02\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x1a\x02\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x02\x19\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x83\x00\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x13\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x8a\x00\x00\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x84\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x01\xc2\x02\x13\x00\x00\x00\xdd\x01\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\xde\x01\x00\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x00\x00\x8e\x00\x00\x00\x90\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x04\x00\x00\x00\x00\x15\x00\x00\x00\xad\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\xae\x04\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\xac\x04\x00\x00\x00\x00\x15\x00\x00\x00\xad\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\xae\x04\xaf\x04\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xb0\x04\x00\x00\x00\x00\x2c\x00\x64\x00\x13\x00\x00\x00\x2d\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\xaf\x04\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x14\x00\x2c\x00\x64\x00\x00\x00\x00\x00\x2d\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xad\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x87\x00\x00\x00\x00\x00\x00\x00\x97\x01\x13\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x3c\x05\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\xaf\x04\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x14\x00\x2c\x00\x64\x00\x00\x00\x00\x00\x2d\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdc\x01\x13\x00\x00\x00\x00\x00\xdd\x01\x00\x00\x89\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x8e\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x8a\x01\x13\x00\x00\x00\x00\x00\x8b\x01\x00\x00\x8c\x01\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x64\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x8e\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x63\x00\x64\x00\x00\x00\x00\x00\x00\x00\x67\x00\x5d\x02\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x2b\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x90\x00\x5a\x01\x5b\x01\x2d\x00\x93\x00\x94\x00\x81\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x83\x00\x84\x00\x85\x00\x5c\x01\x5d\x01\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x00\x00\x00\x00\x77\x01\x6c\x01\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x01\x00\x00\x00\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x60\x01\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x62\x01\x63\x01\x9f\x01\x65\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x66\x01\x7f\x00\xa5\x00\x00\x00\x00\x00\x67\x01\x13\x00\x68\x01\x90\x00\x5a\x01\x5b\x01\x00\x00\x93\x00\x94\x00\x14\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x15\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x60\x01\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x62\x01\x63\x01\x64\x01\x65\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x66\x01\x7f\x00\xa5\x00\x00\x00\x63\x00\x67\x01\x00\x00\x68\x01\x90\x00\x5a\x01\x5b\x01\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x01\x9a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x60\x01\x00\x00\x61\x01\x00\x00\x00\x00\x13\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x62\x01\x9b\x01\x14\x00\x9c\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x24\x01\x00\x00\x9d\x01\x15\x00\x68\x01\x25\x01\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x87\x00\x00\x00\x00\x00\x00\x00\x26\x01\x13\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x87\x00\x00\x00\x24\x00\x00\x00\x77\x01\x13\x00\x89\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x87\x00\x00\x00\x00\x00\x00\x00\x35\x01\x13\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x87\x00\x00\x00\x24\x00\x00\x00\x26\x01\x13\x00\x89\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x87\x00\x00\x00\x00\x00\x00\x00\x77\x01\x13\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x87\x00\x00\x00\x24\x00\x00\x00\x26\x01\x13\x00\x89\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x2c\x00\x8b\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x02\x19\x02\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\xff\x14\x00\x00\x00\x00\x00\x03\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\xfa\x02\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xc0\x02\x00\x00\x24\x00\x2c\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x2c\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x2c\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xe1\x00\x92\x00\x63\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x03\xa3\x03\xa4\x03\x00\x00\x00\x00\xf9\x01\x00\x00\x00\x00\xa5\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x90\x00\x5a\x01\x5b\x01\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\xa4\x00\x0f\x00\x10\x00\xa1\x01\xa2\x01\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\xa6\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x60\x01\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x62\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x90\x00\x5a\x01\x5b\x01\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x02\x00\x00\x00\x00\x7e\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x60\x01\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x62\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x90\x00\x5a\x01\x5b\x01\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x02\x00\x00\x00\x00\x94\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x60\x01\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x62\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x90\x00\x5a\x01\x5b\x01\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x60\x01\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x62\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x90\x00\x5a\x01\x5b\x01\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x60\x01\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x62\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x90\x00\x96\x03\x5b\x01\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x60\x01\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x62\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x90\x00\x5a\x01\x5b\x01\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x60\x01\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x62\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x90\x00\x5a\x01\x5b\x01\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x60\x01\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x62\x01\x9b\x01\x00\x00\x9c\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x03\x99\x03\x9a\x03\x9b\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x86\x04\x9a\x03\x9b\x03\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x0b\x01\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x6c\x02\x00\x00\x00\x00\x6b\x02\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x6a\x02\x00\x00\x00\x00\x6b\x02\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x61\x02\x62\x02\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xe1\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\xa8\x03\xa3\x03\xa4\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x58\x03\x62\x02\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xe1\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\xe1\x03\xa3\x03\xa4\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xb6\x01\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\xb7\x01\xb8\x01\xb9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x03\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x84\x04\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xe1\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x8a\x04\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\xa5\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xe1\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xe1\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x2f\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xe1\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x2e\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xe4\x00\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xd3\x01\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xc4\x01\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xc3\x01\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xbd\x01\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x93\x01\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x8d\x01\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x8c\x01\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x5d\x02\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x53\x02\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x52\x02\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x51\x02\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x50\x02\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xb0\x03\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xaf\x03\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xab\x03\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x9e\x03\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x59\x03\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xf8\x03\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xe9\x03\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xe8\x03\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xdd\x03\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xdb\x03\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x8b\x04\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x83\x04\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x69\x04\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xec\x04\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xbe\x04\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xbd\x04\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\xbc\x04\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x20\x05\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x49\x05\x92\x00\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x00\x00\x92\x01\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x00\x00\xc5\x02\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x00\x00\x32\x04\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x90\x00\x00\x00\xd8\x04\x00\x00\x93\x00\x94\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x90\x00\x00\x00\x73\x00\x74\x00\x93\x00\x56\x02\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x91\x03\x00\x00\x9b\x00\x9c\x00\x11\x00\x92\x03\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x01\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# happyReduceArr = Happy_Data_Array.array (13, 834) [ (13 , happyReduce_13), (14 , happyReduce_14), (15 , happyReduce_15), (16 , happyReduce_16), (17 , happyReduce_17), (18 , happyReduce_18), (19 , happyReduce_19), (20 , happyReduce_20), (21 , happyReduce_21), (22 , happyReduce_22), (23 , happyReduce_23), (24 , happyReduce_24), (25 , happyReduce_25), (26 , happyReduce_26), (27 , happyReduce_27), (28 , happyReduce_28), (29 , happyReduce_29), (30 , happyReduce_30), (31 , happyReduce_31), (32 , happyReduce_32), (33 , happyReduce_33), (34 , happyReduce_34), (35 , happyReduce_35), (36 , happyReduce_36), (37 , happyReduce_37), (38 , happyReduce_38), (39 , happyReduce_39), (40 , happyReduce_40), (41 , happyReduce_41), (42 , happyReduce_42), (43 , happyReduce_43), (44 , happyReduce_44), (45 , happyReduce_45), (46 , happyReduce_46), (47 , happyReduce_47), (48 , happyReduce_48), (49 , happyReduce_49), (50 , happyReduce_50), (51 , happyReduce_51), (52 , happyReduce_52), (53 , happyReduce_53), (54 , happyReduce_54), (55 , happyReduce_55), (56 , happyReduce_56), (57 , happyReduce_57), (58 , happyReduce_58), (59 , happyReduce_59), (60 , happyReduce_60), (61 , happyReduce_61), (62 , happyReduce_62), (63 , happyReduce_63), (64 , happyReduce_64), (65 , happyReduce_65), (66 , happyReduce_66), (67 , happyReduce_67), (68 , happyReduce_68), (69 , happyReduce_69), (70 , happyReduce_70), (71 , happyReduce_71), (72 , happyReduce_72), (73 , happyReduce_73), (74 , happyReduce_74), (75 , happyReduce_75), (76 , happyReduce_76), (77 , happyReduce_77), (78 , happyReduce_78), (79 , happyReduce_79), (80 , happyReduce_80), (81 , happyReduce_81), (82 , happyReduce_82), (83 , happyReduce_83), (84 , happyReduce_84), (85 , happyReduce_85), (86 , happyReduce_86), (87 , happyReduce_87), (88 , happyReduce_88), (89 , happyReduce_89), (90 , happyReduce_90), (91 , happyReduce_91), (92 , happyReduce_92), (93 , happyReduce_93), (94 , happyReduce_94), (95 , happyReduce_95), (96 , happyReduce_96), (97 , happyReduce_97), (98 , happyReduce_98), (99 , happyReduce_99), (100 , happyReduce_100), (101 , happyReduce_101), (102 , happyReduce_102), (103 , happyReduce_103), (104 , happyReduce_104), (105 , happyReduce_105), (106 , happyReduce_106), (107 , happyReduce_107), (108 , happyReduce_108), (109 , happyReduce_109), (110 , happyReduce_110), (111 , happyReduce_111), (112 , happyReduce_112), (113 , happyReduce_113), (114 , happyReduce_114), (115 , happyReduce_115), (116 , happyReduce_116), (117 , happyReduce_117), (118 , happyReduce_118), (119 , happyReduce_119), (120 , happyReduce_120), (121 , happyReduce_121), (122 , happyReduce_122), (123 , happyReduce_123), (124 , happyReduce_124), (125 , happyReduce_125), (126 , happyReduce_126), (127 , happyReduce_127), (128 , happyReduce_128), (129 , happyReduce_129), (130 , happyReduce_130), (131 , happyReduce_131), (132 , happyReduce_132), (133 , happyReduce_133), (134 , happyReduce_134), (135 , happyReduce_135), (136 , happyReduce_136), (137 , happyReduce_137), (138 , happyReduce_138), (139 , happyReduce_139), (140 , happyReduce_140), (141 , happyReduce_141), (142 , happyReduce_142), (143 , happyReduce_143), (144 , happyReduce_144), (145 , happyReduce_145), (146 , happyReduce_146), (147 , happyReduce_147), (148 , happyReduce_148), (149 , happyReduce_149), (150 , happyReduce_150), (151 , happyReduce_151), (152 , happyReduce_152), (153 , happyReduce_153), (154 , happyReduce_154), (155 , happyReduce_155), (156 , happyReduce_156), (157 , happyReduce_157), (158 , happyReduce_158), (159 , happyReduce_159), (160 , happyReduce_160), (161 , happyReduce_161), (162 , happyReduce_162), (163 , happyReduce_163), (164 , happyReduce_164), (165 , happyReduce_165), (166 , happyReduce_166), (167 , happyReduce_167), (168 , happyReduce_168), (169 , happyReduce_169), (170 , happyReduce_170), (171 , happyReduce_171), (172 , happyReduce_172), (173 , happyReduce_173), (174 , happyReduce_174), (175 , happyReduce_175), (176 , happyReduce_176), (177 , happyReduce_177), (178 , happyReduce_178), (179 , happyReduce_179), (180 , happyReduce_180), (181 , happyReduce_181), (182 , happyReduce_182), (183 , happyReduce_183), (184 , happyReduce_184), (185 , happyReduce_185), (186 , happyReduce_186), (187 , happyReduce_187), (188 , happyReduce_188), (189 , happyReduce_189), (190 , happyReduce_190), (191 , happyReduce_191), (192 , happyReduce_192), (193 , happyReduce_193), (194 , happyReduce_194), (195 , happyReduce_195), (196 , happyReduce_196), (197 , happyReduce_197), (198 , happyReduce_198), (199 , happyReduce_199), (200 , happyReduce_200), (201 , happyReduce_201), (202 , happyReduce_202), (203 , happyReduce_203), (204 , happyReduce_204), (205 , happyReduce_205), (206 , happyReduce_206), (207 , happyReduce_207), (208 , happyReduce_208), (209 , happyReduce_209), (210 , happyReduce_210), (211 , happyReduce_211), (212 , happyReduce_212), (213 , happyReduce_213), (214 , happyReduce_214), (215 , happyReduce_215), (216 , happyReduce_216), (217 , happyReduce_217), (218 , happyReduce_218), (219 , happyReduce_219), (220 , happyReduce_220), (221 , happyReduce_221), (222 , happyReduce_222), (223 , happyReduce_223), (224 , happyReduce_224), (225 , happyReduce_225), (226 , happyReduce_226), (227 , happyReduce_227), (228 , happyReduce_228), (229 , happyReduce_229), (230 , happyReduce_230), (231 , happyReduce_231), (232 , happyReduce_232), (233 , happyReduce_233), (234 , happyReduce_234), (235 , happyReduce_235), (236 , happyReduce_236), (237 , happyReduce_237), (238 , happyReduce_238), (239 , happyReduce_239), (240 , happyReduce_240), (241 , happyReduce_241), (242 , happyReduce_242), (243 , happyReduce_243), (244 , happyReduce_244), (245 , happyReduce_245), (246 , happyReduce_246), (247 , happyReduce_247), (248 , happyReduce_248), (249 , happyReduce_249), (250 , happyReduce_250), (251 , happyReduce_251), (252 , happyReduce_252), (253 , happyReduce_253), (254 , happyReduce_254), (255 , happyReduce_255), (256 , happyReduce_256), (257 , happyReduce_257), (258 , happyReduce_258), (259 , happyReduce_259), (260 , happyReduce_260), (261 , happyReduce_261), (262 , happyReduce_262), (263 , happyReduce_263), (264 , happyReduce_264), (265 , happyReduce_265), (266 , happyReduce_266), (267 , happyReduce_267), (268 , happyReduce_268), (269 , happyReduce_269), (270 , happyReduce_270), (271 , happyReduce_271), (272 , happyReduce_272), (273 , happyReduce_273), (274 , happyReduce_274), (275 , happyReduce_275), (276 , happyReduce_276), (277 , happyReduce_277), (278 , happyReduce_278), (279 , happyReduce_279), (280 , happyReduce_280), (281 , happyReduce_281), (282 , happyReduce_282), (283 , happyReduce_283), (284 , happyReduce_284), (285 , happyReduce_285), (286 , happyReduce_286), (287 , happyReduce_287), (288 , happyReduce_288), (289 , happyReduce_289), (290 , happyReduce_290), (291 , happyReduce_291), (292 , happyReduce_292), (293 , happyReduce_293), (294 , happyReduce_294), (295 , happyReduce_295), (296 , happyReduce_296), (297 , happyReduce_297), (298 , happyReduce_298), (299 , happyReduce_299), (300 , happyReduce_300), (301 , happyReduce_301), (302 , happyReduce_302), (303 , happyReduce_303), (304 , happyReduce_304), (305 , happyReduce_305), (306 , happyReduce_306), (307 , happyReduce_307), (308 , happyReduce_308), (309 , happyReduce_309), (310 , happyReduce_310), (311 , happyReduce_311), (312 , happyReduce_312), (313 , happyReduce_313), (314 , happyReduce_314), (315 , happyReduce_315), (316 , happyReduce_316), (317 , happyReduce_317), (318 , happyReduce_318), (319 , happyReduce_319), (320 , happyReduce_320), (321 , happyReduce_321), (322 , happyReduce_322), (323 , happyReduce_323), (324 , happyReduce_324), (325 , happyReduce_325), (326 , happyReduce_326), (327 , happyReduce_327), (328 , happyReduce_328), (329 , happyReduce_329), (330 , happyReduce_330), (331 , happyReduce_331), (332 , happyReduce_332), (333 , happyReduce_333), (334 , happyReduce_334), (335 , happyReduce_335), (336 , happyReduce_336), (337 , happyReduce_337), (338 , happyReduce_338), (339 , happyReduce_339), (340 , happyReduce_340), (341 , happyReduce_341), (342 , happyReduce_342), (343 , happyReduce_343), (344 , happyReduce_344), (345 , happyReduce_345), (346 , happyReduce_346), (347 , happyReduce_347), (348 , happyReduce_348), (349 , happyReduce_349), (350 , happyReduce_350), (351 , happyReduce_351), (352 , happyReduce_352), (353 , happyReduce_353), (354 , happyReduce_354), (355 , happyReduce_355), (356 , happyReduce_356), (357 , happyReduce_357), (358 , happyReduce_358), (359 , happyReduce_359), (360 , happyReduce_360), (361 , happyReduce_361), (362 , happyReduce_362), (363 , happyReduce_363), (364 , happyReduce_364), (365 , happyReduce_365), (366 , happyReduce_366), (367 , happyReduce_367), (368 , happyReduce_368), (369 , happyReduce_369), (370 , happyReduce_370), (371 , happyReduce_371), (372 , happyReduce_372), (373 , happyReduce_373), (374 , happyReduce_374), (375 , happyReduce_375), (376 , happyReduce_376), (377 , happyReduce_377), (378 , happyReduce_378), (379 , happyReduce_379), (380 , happyReduce_380), (381 , happyReduce_381), (382 , happyReduce_382), (383 , happyReduce_383), (384 , happyReduce_384), (385 , happyReduce_385), (386 , happyReduce_386), (387 , happyReduce_387), (388 , happyReduce_388), (389 , happyReduce_389), (390 , happyReduce_390), (391 , happyReduce_391), (392 , happyReduce_392), (393 , happyReduce_393), (394 , happyReduce_394), (395 , happyReduce_395), (396 , happyReduce_396), (397 , happyReduce_397), (398 , happyReduce_398), (399 , happyReduce_399), (400 , happyReduce_400), (401 , happyReduce_401), (402 , happyReduce_402), (403 , happyReduce_403), (404 , happyReduce_404), (405 , happyReduce_405), (406 , happyReduce_406), (407 , happyReduce_407), (408 , happyReduce_408), (409 , happyReduce_409), (410 , happyReduce_410), (411 , happyReduce_411), (412 , happyReduce_412), (413 , happyReduce_413), (414 , happyReduce_414), (415 , happyReduce_415), (416 , happyReduce_416), (417 , happyReduce_417), (418 , happyReduce_418), (419 , happyReduce_419), (420 , happyReduce_420), (421 , happyReduce_421), (422 , happyReduce_422), (423 , happyReduce_423), (424 , happyReduce_424), (425 , happyReduce_425), (426 , happyReduce_426), (427 , happyReduce_427), (428 , happyReduce_428), (429 , happyReduce_429), (430 , happyReduce_430), (431 , happyReduce_431), (432 , happyReduce_432), (433 , happyReduce_433), (434 , happyReduce_434), (435 , happyReduce_435), (436 , happyReduce_436), (437 , happyReduce_437), (438 , happyReduce_438), (439 , happyReduce_439), (440 , happyReduce_440), (441 , happyReduce_441), (442 , happyReduce_442), (443 , happyReduce_443), (444 , happyReduce_444), (445 , happyReduce_445), (446 , happyReduce_446), (447 , happyReduce_447), (448 , happyReduce_448), (449 , happyReduce_449), (450 , happyReduce_450), (451 , happyReduce_451), (452 , happyReduce_452), (453 , happyReduce_453), (454 , happyReduce_454), (455 , happyReduce_455), (456 , happyReduce_456), (457 , happyReduce_457), (458 , happyReduce_458), (459 , happyReduce_459), (460 , happyReduce_460), (461 , happyReduce_461), (462 , happyReduce_462), (463 , happyReduce_463), (464 , happyReduce_464), (465 , happyReduce_465), (466 , happyReduce_466), (467 , happyReduce_467), (468 , happyReduce_468), (469 , happyReduce_469), (470 , happyReduce_470), (471 , happyReduce_471), (472 , happyReduce_472), (473 , happyReduce_473), (474 , happyReduce_474), (475 , happyReduce_475), (476 , happyReduce_476), (477 , happyReduce_477), (478 , happyReduce_478), (479 , happyReduce_479), (480 , happyReduce_480), (481 , happyReduce_481), (482 , happyReduce_482), (483 , happyReduce_483), (484 , happyReduce_484), (485 , happyReduce_485), (486 , happyReduce_486), (487 , happyReduce_487), (488 , happyReduce_488), (489 , happyReduce_489), (490 , happyReduce_490), (491 , happyReduce_491), (492 , happyReduce_492), (493 , happyReduce_493), (494 , happyReduce_494), (495 , happyReduce_495), (496 , happyReduce_496), (497 , happyReduce_497), (498 , happyReduce_498), (499 , happyReduce_499), (500 , happyReduce_500), (501 , happyReduce_501), (502 , happyReduce_502), (503 , happyReduce_503), (504 , happyReduce_504), (505 , happyReduce_505), (506 , happyReduce_506), (507 , happyReduce_507), (508 , happyReduce_508), (509 , happyReduce_509), (510 , happyReduce_510), (511 , happyReduce_511), (512 , happyReduce_512), (513 , happyReduce_513), (514 , happyReduce_514), (515 , happyReduce_515), (516 , happyReduce_516), (517 , happyReduce_517), (518 , happyReduce_518), (519 , happyReduce_519), (520 , happyReduce_520), (521 , happyReduce_521), (522 , happyReduce_522), (523 , happyReduce_523), (524 , happyReduce_524), (525 , happyReduce_525), (526 , happyReduce_526), (527 , happyReduce_527), (528 , happyReduce_528), (529 , happyReduce_529), (530 , happyReduce_530), (531 , happyReduce_531), (532 , happyReduce_532), (533 , happyReduce_533), (534 , happyReduce_534), (535 , happyReduce_535), (536 , happyReduce_536), (537 , happyReduce_537), (538 , happyReduce_538), (539 , happyReduce_539), (540 , happyReduce_540), (541 , happyReduce_541), (542 , happyReduce_542), (543 , happyReduce_543), (544 , happyReduce_544), (545 , happyReduce_545), (546 , happyReduce_546), (547 , happyReduce_547), (548 , happyReduce_548), (549 , happyReduce_549), (550 , happyReduce_550), (551 , happyReduce_551), (552 , happyReduce_552), (553 , happyReduce_553), (554 , happyReduce_554), (555 , happyReduce_555), (556 , happyReduce_556), (557 , happyReduce_557), (558 , happyReduce_558), (559 , happyReduce_559), (560 , happyReduce_560), (561 , happyReduce_561), (562 , happyReduce_562), (563 , happyReduce_563), (564 , happyReduce_564), (565 , happyReduce_565), (566 , happyReduce_566), (567 , happyReduce_567), (568 , happyReduce_568), (569 , happyReduce_569), (570 , happyReduce_570), (571 , happyReduce_571), (572 , happyReduce_572), (573 , happyReduce_573), (574 , happyReduce_574), (575 , happyReduce_575), (576 , happyReduce_576), (577 , happyReduce_577), (578 , happyReduce_578), (579 , happyReduce_579), (580 , happyReduce_580), (581 , happyReduce_581), (582 , happyReduce_582), (583 , happyReduce_583), (584 , happyReduce_584), (585 , happyReduce_585), (586 , happyReduce_586), (587 , happyReduce_587), (588 , happyReduce_588), (589 , happyReduce_589), (590 , happyReduce_590), (591 , happyReduce_591), (592 , happyReduce_592), (593 , happyReduce_593), (594 , happyReduce_594), (595 , happyReduce_595), (596 , happyReduce_596), (597 , happyReduce_597), (598 , happyReduce_598), (599 , happyReduce_599), (600 , happyReduce_600), (601 , happyReduce_601), (602 , happyReduce_602), (603 , happyReduce_603), (604 , happyReduce_604), (605 , happyReduce_605), (606 , happyReduce_606), (607 , happyReduce_607), (608 , happyReduce_608), (609 , happyReduce_609), (610 , happyReduce_610), (611 , happyReduce_611), (612 , happyReduce_612), (613 , happyReduce_613), (614 , happyReduce_614), (615 , happyReduce_615), (616 , happyReduce_616), (617 , happyReduce_617), (618 , happyReduce_618), (619 , happyReduce_619), (620 , happyReduce_620), (621 , happyReduce_621), (622 , happyReduce_622), (623 , happyReduce_623), (624 , happyReduce_624), (625 , happyReduce_625), (626 , happyReduce_626), (627 , happyReduce_627), (628 , happyReduce_628), (629 , happyReduce_629), (630 , happyReduce_630), (631 , happyReduce_631), (632 , happyReduce_632), (633 , happyReduce_633), (634 , happyReduce_634), (635 , happyReduce_635), (636 , happyReduce_636), (637 , happyReduce_637), (638 , happyReduce_638), (639 , happyReduce_639), (640 , happyReduce_640), (641 , happyReduce_641), (642 , happyReduce_642), (643 , happyReduce_643), (644 , happyReduce_644), (645 , happyReduce_645), (646 , happyReduce_646), (647 , happyReduce_647), (648 , happyReduce_648), (649 , happyReduce_649), (650 , happyReduce_650), (651 , happyReduce_651), (652 , happyReduce_652), (653 , happyReduce_653), (654 , happyReduce_654), (655 , happyReduce_655), (656 , happyReduce_656), (657 , happyReduce_657), (658 , happyReduce_658), (659 , happyReduce_659), (660 , happyReduce_660), (661 , happyReduce_661), (662 , happyReduce_662), (663 , happyReduce_663), (664 , happyReduce_664), (665 , happyReduce_665), (666 , happyReduce_666), (667 , happyReduce_667), (668 , happyReduce_668), (669 , happyReduce_669), (670 , happyReduce_670), (671 , happyReduce_671), (672 , happyReduce_672), (673 , happyReduce_673), (674 , happyReduce_674), (675 , happyReduce_675), (676 , happyReduce_676), (677 , happyReduce_677), (678 , happyReduce_678), (679 , happyReduce_679), (680 , happyReduce_680), (681 , happyReduce_681), (682 , happyReduce_682), (683 , happyReduce_683), (684 , happyReduce_684), (685 , happyReduce_685), (686 , happyReduce_686), (687 , happyReduce_687), (688 , happyReduce_688), (689 , happyReduce_689), (690 , happyReduce_690), (691 , happyReduce_691), (692 , happyReduce_692), (693 , happyReduce_693), (694 , happyReduce_694), (695 , happyReduce_695), (696 , happyReduce_696), (697 , happyReduce_697), (698 , happyReduce_698), (699 , happyReduce_699), (700 , happyReduce_700), (701 , happyReduce_701), (702 , happyReduce_702), (703 , happyReduce_703), (704 , happyReduce_704), (705 , happyReduce_705), (706 , happyReduce_706), (707 , happyReduce_707), (708 , happyReduce_708), (709 , happyReduce_709), (710 , happyReduce_710), (711 , happyReduce_711), (712 , happyReduce_712), (713 , happyReduce_713), (714 , happyReduce_714), (715 , happyReduce_715), (716 , happyReduce_716), (717 , happyReduce_717), (718 , happyReduce_718), (719 , happyReduce_719), (720 , happyReduce_720), (721 , happyReduce_721), (722 , happyReduce_722), (723 , happyReduce_723), (724 , happyReduce_724), (725 , happyReduce_725), (726 , happyReduce_726), (727 , happyReduce_727), (728 , happyReduce_728), (729 , happyReduce_729), (730 , happyReduce_730), (731 , happyReduce_731), (732 , happyReduce_732), (733 , happyReduce_733), (734 , happyReduce_734), (735 , happyReduce_735), (736 , happyReduce_736), (737 , happyReduce_737), (738 , happyReduce_738), (739 , happyReduce_739), (740 , happyReduce_740), (741 , happyReduce_741), (742 , happyReduce_742), (743 , happyReduce_743), (744 , happyReduce_744), (745 , happyReduce_745), (746 , happyReduce_746), (747 , happyReduce_747), (748 , happyReduce_748), (749 , happyReduce_749), (750 , happyReduce_750), (751 , happyReduce_751), (752 , happyReduce_752), (753 , happyReduce_753), (754 , happyReduce_754), (755 , happyReduce_755), (756 , happyReduce_756), (757 , happyReduce_757), (758 , happyReduce_758), (759 , happyReduce_759), (760 , happyReduce_760), (761 , happyReduce_761), (762 , happyReduce_762), (763 , happyReduce_763), (764 , happyReduce_764), (765 , happyReduce_765), (766 , happyReduce_766), (767 , happyReduce_767), (768 , happyReduce_768), (769 , happyReduce_769), (770 , happyReduce_770), (771 , happyReduce_771), (772 , happyReduce_772), (773 , happyReduce_773), (774 , happyReduce_774), (775 , happyReduce_775), (776 , happyReduce_776), (777 , happyReduce_777), (778 , happyReduce_778), (779 , happyReduce_779), (780 , happyReduce_780), (781 , happyReduce_781), (782 , happyReduce_782), (783 , happyReduce_783), (784 , happyReduce_784), (785 , happyReduce_785), (786 , happyReduce_786), (787 , happyReduce_787), (788 , happyReduce_788), (789 , happyReduce_789), (790 , happyReduce_790), (791 , happyReduce_791), (792 , happyReduce_792), (793 , happyReduce_793), (794 , happyReduce_794), (795 , happyReduce_795), (796 , happyReduce_796), (797 , happyReduce_797), (798 , happyReduce_798), (799 , happyReduce_799), (800 , happyReduce_800), (801 , happyReduce_801), (802 , happyReduce_802), (803 , happyReduce_803), (804 , happyReduce_804), (805 , happyReduce_805), (806 , happyReduce_806), (807 , happyReduce_807), (808 , happyReduce_808), (809 , happyReduce_809), (810 , happyReduce_810), (811 , happyReduce_811), (812 , happyReduce_812), (813 , happyReduce_813), (814 , happyReduce_814), (815 , happyReduce_815), (816 , happyReduce_816), (817 , happyReduce_817), (818 , happyReduce_818), (819 , happyReduce_819), (820 , happyReduce_820), (821 , happyReduce_821), (822 , happyReduce_822), (823 , happyReduce_823), (824 , happyReduce_824), (825 , happyReduce_825), (826 , happyReduce_826), (827 , happyReduce_827), (828 , happyReduce_828), (829 , happyReduce_829), (830 , happyReduce_830), (831 , happyReduce_831), (832 , happyReduce_832), (833 , happyReduce_833), (834 , happyReduce_834) ] happy_n_terms = 154 :: Int happy_n_nonterms = 314 :: Int happyReduce_13 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_13 = happySpecReduce_1 0# happyReduction_13 happyReduction_13 happy_x_1 = case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> happyIn16 (happy_var_1 )} happyReduce_14 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_14 = happySpecReduce_1 0# happyReduction_14 happyReduction_14 happy_x_1 = case happyOut274 happy_x_1 of { (HappyWrap274 happy_var_1) -> happyIn16 (happy_var_1 )} happyReduce_15 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_15 = happySpecReduce_1 0# happyReduction_15 happyReduction_15 happy_x_1 = case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> happyIn16 (happy_var_1 )} happyReduce_16 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_16 = happySpecReduce_1 0# happyReduction_16 happyReduction_16 happy_x_1 = case happyOut281 happy_x_1 of { (HappyWrap281 happy_var_1) -> happyIn16 (happy_var_1 )} happyReduce_17 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_17 = happyMonadReduce 3# 0# happyReduction_17 happyReduction_17 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ getRdrName funTyCon) [mop happy_var_1,mu AnnRarrow happy_var_2,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn16 r)) happyReduce_18 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_18 = happyMonadReduce 1# 0# happyReduction_18 happyReduction_18 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( ams (sLL happy_var_1 happy_var_1 $ getRdrName funTyCon) [mu AnnRarrow happy_var_1])}) ) (\r -> happyReturn (happyIn16 r)) happyReduce_19 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_19 = happyMonadReduce 3# 0# happyReduction_19 happyReduction_19 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ eqTyCon_RDR) [mop happy_var_1,mj AnnTilde happy_var_2,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn16 r)) happyReduce_20 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_20 = happySpecReduce_3 1# happyReduction_20 happyReduction_20 happy_x_3 happy_x_2 happy_x_1 = case happyOut18 happy_x_2 of { (HappyWrap18 happy_var_2) -> happyIn17 (fromOL happy_var_2 )} happyReduce_21 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_21 = happySpecReduce_3 1# happyReduction_21 happyReduction_21 happy_x_3 happy_x_2 happy_x_1 = case happyOut18 happy_x_2 of { (HappyWrap18 happy_var_2) -> happyIn17 (fromOL happy_var_2 )} happyReduce_22 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_22 = happySpecReduce_3 2# happyReduction_22 happyReduction_22 happy_x_3 happy_x_2 happy_x_1 = case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> case happyOut19 happy_x_3 of { (HappyWrap19 happy_var_3) -> happyIn18 (happy_var_1 `appOL` unitOL happy_var_3 )}} happyReduce_23 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_23 = happySpecReduce_2 2# happyReduction_23 happyReduction_23 happy_x_2 happy_x_1 = case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> happyIn18 (happy_var_1 )} happyReduce_24 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_24 = happySpecReduce_1 2# happyReduction_24 happyReduction_24 happy_x_1 = case happyOut19 happy_x_1 of { (HappyWrap19 happy_var_1) -> happyIn18 (unitOL happy_var_1 )} happyReduce_25 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_25 = happyReduce 4# 3# happyReduction_25 happyReduction_25 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut24 happy_x_2 of { (HappyWrap24 happy_var_2) -> case happyOut30 happy_x_4 of { (HappyWrap30 happy_var_4) -> happyIn19 (sL1 happy_var_1 $ HsUnit { hsunitName = happy_var_2 , hsunitBody = fromOL happy_var_4 } ) `HappyStk` happyRest}}} happyReduce_26 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_26 = happySpecReduce_1 4# happyReduction_26 happyReduction_26 happy_x_1 = case happyOut24 happy_x_1 of { (HappyWrap24 happy_var_1) -> happyIn20 (sL1 happy_var_1 $ HsUnitId happy_var_1 [] )} happyReduce_27 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_27 = happyReduce 4# 4# happyReduction_27 happyReduction_27 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOut24 happy_x_1 of { (HappyWrap24 happy_var_1) -> case happyOut21 happy_x_3 of { (HappyWrap21 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> happyIn20 (sLL happy_var_1 happy_var_4 $ HsUnitId happy_var_1 (fromOL happy_var_3) ) `HappyStk` happyRest}}} happyReduce_28 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_28 = happySpecReduce_3 5# happyReduction_28 happyReduction_28 happy_x_3 happy_x_2 happy_x_1 = case happyOut21 happy_x_1 of { (HappyWrap21 happy_var_1) -> case happyOut22 happy_x_3 of { (HappyWrap22 happy_var_3) -> happyIn21 (happy_var_1 `appOL` unitOL happy_var_3 )}} happyReduce_29 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_29 = happySpecReduce_2 5# happyReduction_29 happyReduction_29 happy_x_2 happy_x_1 = case happyOut21 happy_x_1 of { (HappyWrap21 happy_var_1) -> happyIn21 (happy_var_1 )} happyReduce_30 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_30 = happySpecReduce_1 5# happyReduction_30 happyReduction_30 happy_x_1 = case happyOut22 happy_x_1 of { (HappyWrap22 happy_var_1) -> happyIn21 (unitOL happy_var_1 )} happyReduce_31 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_31 = happySpecReduce_3 6# happyReduction_31 happyReduction_31 happy_x_3 happy_x_2 happy_x_1 = case happyOut319 happy_x_1 of { (HappyWrap319 happy_var_1) -> case happyOut23 happy_x_3 of { (HappyWrap23 happy_var_3) -> happyIn22 (sLL happy_var_1 happy_var_3 $ (happy_var_1, happy_var_3) )}} happyReduce_32 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_32 = happyReduce 4# 6# happyReduction_32 happyReduction_32 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOut319 happy_x_1 of { (HappyWrap319 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut319 happy_x_3 of { (HappyWrap319 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> happyIn22 (sLL happy_var_1 happy_var_4 $ (happy_var_1, sLL happy_var_2 happy_var_4 $ HsModuleVar happy_var_3) ) `HappyStk` happyRest}}}} happyReduce_33 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_33 = happySpecReduce_3 7# happyReduction_33 happyReduction_33 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut319 happy_x_2 of { (HappyWrap319 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn23 (sLL happy_var_1 happy_var_3 $ HsModuleVar happy_var_2 )}}} happyReduce_34 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_34 = happySpecReduce_3 7# happyReduction_34 happyReduction_34 happy_x_3 happy_x_2 happy_x_1 = case happyOut20 happy_x_1 of { (HappyWrap20 happy_var_1) -> case happyOut319 happy_x_3 of { (HappyWrap319 happy_var_3) -> happyIn23 (sLL happy_var_1 happy_var_3 $ HsModuleId happy_var_1 happy_var_3 )}} happyReduce_35 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_35 = happySpecReduce_1 8# happyReduction_35 happyReduction_35 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn24 (sL1 happy_var_1 $ PackageName (getSTRING happy_var_1) )} happyReduce_36 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_36 = happySpecReduce_1 8# happyReduction_36 happyReduction_36 happy_x_1 = case happyOut26 happy_x_1 of { (HappyWrap26 happy_var_1) -> happyIn24 (sL1 happy_var_1 $ PackageName (unLoc happy_var_1) )} happyReduce_37 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_37 = happySpecReduce_1 9# happyReduction_37 happyReduction_37 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn25 (sL1 happy_var_1 $ getVARID happy_var_1 )} happyReduce_38 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_38 = happySpecReduce_1 9# happyReduction_38 happyReduction_38 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn25 (sL1 happy_var_1 $ getCONID happy_var_1 )} happyReduce_39 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_39 = happySpecReduce_1 9# happyReduction_39 happyReduction_39 happy_x_1 = case happyOut311 happy_x_1 of { (HappyWrap311 happy_var_1) -> happyIn25 (happy_var_1 )} happyReduce_40 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_40 = happySpecReduce_1 10# happyReduction_40 happyReduction_40 happy_x_1 = case happyOut25 happy_x_1 of { (HappyWrap25 happy_var_1) -> happyIn26 (happy_var_1 )} happyReduce_41 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_41 = happySpecReduce_3 10# happyReduction_41 happyReduction_41 happy_x_3 happy_x_2 happy_x_1 = case happyOut25 happy_x_1 of { (HappyWrap25 happy_var_1) -> case happyOut26 happy_x_3 of { (HappyWrap26 happy_var_3) -> happyIn26 (sLL happy_var_1 happy_var_3 $ appendFS (unLoc happy_var_1) (consFS '-' (unLoc happy_var_3)) )}} happyReduce_42 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_42 = happySpecReduce_0 11# happyReduction_42 happyReduction_42 = happyIn27 (Nothing ) happyReduce_43 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_43 = happySpecReduce_3 11# happyReduction_43 happyReduction_43 happy_x_3 happy_x_2 happy_x_1 = case happyOut28 happy_x_2 of { (HappyWrap28 happy_var_2) -> happyIn27 (Just (fromOL happy_var_2) )} happyReduce_44 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_44 = happySpecReduce_3 12# happyReduction_44 happyReduction_44 happy_x_3 happy_x_2 happy_x_1 = case happyOut28 happy_x_1 of { (HappyWrap28 happy_var_1) -> case happyOut29 happy_x_3 of { (HappyWrap29 happy_var_3) -> happyIn28 (happy_var_1 `appOL` unitOL happy_var_3 )}} happyReduce_45 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_45 = happySpecReduce_2 12# happyReduction_45 happyReduction_45 happy_x_2 happy_x_1 = case happyOut28 happy_x_1 of { (HappyWrap28 happy_var_1) -> happyIn28 (happy_var_1 )} happyReduce_46 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_46 = happySpecReduce_1 12# happyReduction_46 happyReduction_46 happy_x_1 = case happyOut29 happy_x_1 of { (HappyWrap29 happy_var_1) -> happyIn28 (unitOL happy_var_1 )} happyReduce_47 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_47 = happySpecReduce_3 13# happyReduction_47 happyReduction_47 happy_x_3 happy_x_2 happy_x_1 = case happyOut319 happy_x_1 of { (HappyWrap319 happy_var_1) -> case happyOut319 happy_x_3 of { (HappyWrap319 happy_var_3) -> happyIn29 (sLL happy_var_1 happy_var_3 $ Renaming happy_var_1 (Just happy_var_3) )}} happyReduce_48 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_48 = happySpecReduce_1 13# happyReduction_48 happyReduction_48 happy_x_1 = case happyOut319 happy_x_1 of { (HappyWrap319 happy_var_1) -> happyIn29 (sL1 happy_var_1 $ Renaming happy_var_1 Nothing )} happyReduce_49 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_49 = happySpecReduce_3 14# happyReduction_49 happyReduction_49 happy_x_3 happy_x_2 happy_x_1 = case happyOut31 happy_x_2 of { (HappyWrap31 happy_var_2) -> happyIn30 (happy_var_2 )} happyReduce_50 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_50 = happySpecReduce_3 14# happyReduction_50 happyReduction_50 happy_x_3 happy_x_2 happy_x_1 = case happyOut31 happy_x_2 of { (HappyWrap31 happy_var_2) -> happyIn30 (happy_var_2 )} happyReduce_51 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_51 = happySpecReduce_3 15# happyReduction_51 happyReduction_51 happy_x_3 happy_x_2 happy_x_1 = case happyOut31 happy_x_1 of { (HappyWrap31 happy_var_1) -> case happyOut32 happy_x_3 of { (HappyWrap32 happy_var_3) -> happyIn31 (happy_var_1 `appOL` unitOL happy_var_3 )}} happyReduce_52 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_52 = happySpecReduce_2 15# happyReduction_52 happyReduction_52 happy_x_2 happy_x_1 = case happyOut31 happy_x_1 of { (HappyWrap31 happy_var_1) -> happyIn31 (happy_var_1 )} happyReduce_53 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_53 = happySpecReduce_1 15# happyReduction_53 happyReduction_53 happy_x_1 = case happyOut32 happy_x_1 of { (HappyWrap32 happy_var_1) -> happyIn31 (unitOL happy_var_1 )} happyReduce_54 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_54 = happyReduce 8# 16# happyReduction_54 happyReduction_54 (happy_x_8 `HappyStk` happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOut35 happy_x_1 of { (HappyWrap35 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut65 happy_x_3 of { (HappyWrap65 happy_var_3) -> case happyOut319 happy_x_4 of { (HappyWrap319 happy_var_4) -> case happyOut38 happy_x_5 of { (HappyWrap38 happy_var_5) -> case happyOut48 happy_x_6 of { (HappyWrap48 happy_var_6) -> case happyOut39 happy_x_8 of { (HappyWrap39 happy_var_8) -> happyIn32 (sL1 happy_var_2 $ DeclD (case snd happy_var_3 of False -> HsSrcFile True -> HsBootFile) happy_var_4 (Just $ sL1 happy_var_2 (HsModule (Just happy_var_4) happy_var_6 (fst $ snd happy_var_8) (snd $ snd happy_var_8) happy_var_5 happy_var_1)) ) `HappyStk` happyRest}}}}}}} happyReduce_55 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_55 = happyReduce 7# 16# happyReduction_55 happyReduction_55 (happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOut35 happy_x_1 of { (HappyWrap35 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut319 happy_x_3 of { (HappyWrap319 happy_var_3) -> case happyOut38 happy_x_4 of { (HappyWrap38 happy_var_4) -> case happyOut48 happy_x_5 of { (HappyWrap48 happy_var_5) -> case happyOut39 happy_x_7 of { (HappyWrap39 happy_var_7) -> happyIn32 (sL1 happy_var_2 $ DeclD HsigFile happy_var_3 (Just $ sL1 happy_var_2 (HsModule (Just happy_var_3) happy_var_5 (fst $ snd happy_var_7) (snd $ snd happy_var_7) happy_var_4 happy_var_1)) ) `HappyStk` happyRest}}}}}} happyReduce_56 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_56 = happyReduce 4# 16# happyReduction_56 happyReduction_56 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut65 happy_x_3 of { (HappyWrap65 happy_var_3) -> case happyOut319 happy_x_4 of { (HappyWrap319 happy_var_4) -> happyIn32 (sL1 happy_var_2 $ DeclD (case snd happy_var_3 of False -> HsSrcFile True -> HsBootFile) happy_var_4 Nothing ) `HappyStk` happyRest}}} happyReduce_57 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_57 = happySpecReduce_3 16# happyReduction_57 happyReduction_57 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut319 happy_x_3 of { (HappyWrap319 happy_var_3) -> happyIn32 (sL1 happy_var_2 $ DeclD HsigFile happy_var_3 Nothing )}} happyReduce_58 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_58 = happySpecReduce_3 16# happyReduction_58 happyReduction_58 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut20 happy_x_2 of { (HappyWrap20 happy_var_2) -> case happyOut27 happy_x_3 of { (HappyWrap27 happy_var_3) -> happyIn32 (sL1 happy_var_1 $ IncludeD (IncludeDecl { idUnitId = happy_var_2 , idModRenaming = happy_var_3 , idSignatureInclude = False }) )}}} happyReduce_59 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_59 = happySpecReduce_3 16# happyReduction_59 happyReduction_59 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut20 happy_x_3 of { (HappyWrap20 happy_var_3) -> happyIn32 (sL1 happy_var_1 $ IncludeD (IncludeDecl { idUnitId = happy_var_3 , idModRenaming = Nothing , idSignatureInclude = True }) )}} happyReduce_60 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_60 = happyMonadReduce 7# 17# happyReduction_60 happyReduction_60 (happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut35 happy_x_1 of { (HappyWrap35 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut319 happy_x_3 of { (HappyWrap319 happy_var_3) -> case happyOut38 happy_x_4 of { (HappyWrap38 happy_var_4) -> case happyOut48 happy_x_5 of { (HappyWrap48 happy_var_5) -> case happyOutTok happy_x_6 of { happy_var_6 -> case happyOut39 happy_x_7 of { (HappyWrap39 happy_var_7) -> ( fileSrcSpan >>= \ loc -> ams (cL loc (HsModule (Just happy_var_3) happy_var_5 (fst $ snd happy_var_7) (snd $ snd happy_var_7) happy_var_4 happy_var_1) ) ([mj AnnSignature happy_var_2, mj AnnWhere happy_var_6] ++ fst happy_var_7))}}}}}}}) ) (\r -> happyReturn (happyIn33 r)) happyReduce_61 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_61 = happyMonadReduce 7# 18# happyReduction_61 happyReduction_61 (happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut35 happy_x_1 of { (HappyWrap35 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut319 happy_x_3 of { (HappyWrap319 happy_var_3) -> case happyOut38 happy_x_4 of { (HappyWrap38 happy_var_4) -> case happyOut48 happy_x_5 of { (HappyWrap48 happy_var_5) -> case happyOutTok happy_x_6 of { happy_var_6 -> case happyOut39 happy_x_7 of { (HappyWrap39 happy_var_7) -> ( fileSrcSpan >>= \ loc -> ams (cL loc (HsModule (Just happy_var_3) happy_var_5 (fst $ snd happy_var_7) (snd $ snd happy_var_7) happy_var_4 happy_var_1) ) ([mj AnnModule happy_var_2, mj AnnWhere happy_var_6] ++ fst happy_var_7))}}}}}}}) ) (\r -> happyReturn (happyIn34 r)) happyReduce_62 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_62 = happyMonadReduce 1# 18# happyReduction_62 happyReduction_62 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut40 happy_x_1 of { (HappyWrap40 happy_var_1) -> ( fileSrcSpan >>= \ loc -> ams (cL loc (HsModule Nothing Nothing (fst $ snd happy_var_1) (snd $ snd happy_var_1) Nothing Nothing)) (fst happy_var_1))}) ) (\r -> happyReturn (happyIn34 r)) happyReduce_63 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_63 = happySpecReduce_1 19# happyReduction_63 happyReduction_63 happy_x_1 = case happyOut327 happy_x_1 of { (HappyWrap327 happy_var_1) -> happyIn35 (happy_var_1 )} happyReduce_64 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_64 = happySpecReduce_0 19# happyReduction_64 happyReduction_64 = happyIn35 (Nothing ) happyReduce_65 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_65 = happyMonadReduce 0# 20# happyReduction_65 happyReduction_65 (happyRest) tk = happyThen ((( pushModuleContext)) ) (\r -> happyReturn (happyIn36 r)) happyReduce_66 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_66 = happyMonadReduce 0# 21# happyReduction_66 happyReduction_66 (happyRest) tk = happyThen ((( pushModuleContext)) ) (\r -> happyReturn (happyIn37 r)) happyReduce_67 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_67 = happyMonadReduce 3# 22# happyReduction_67 happyReduction_67 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut140 happy_x_2 of { (HappyWrap140 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ajs (sLL happy_var_1 happy_var_3 $ DeprecatedTxt (sL1 happy_var_1 (getDEPRECATED_PRAGs happy_var_1)) (snd $ unLoc happy_var_2)) (mo happy_var_1:mc happy_var_3: (fst $ unLoc happy_var_2)))}}}) ) (\r -> happyReturn (happyIn38 r)) happyReduce_68 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_68 = happyMonadReduce 3# 22# happyReduction_68 happyReduction_68 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut140 happy_x_2 of { (HappyWrap140 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ajs (sLL happy_var_1 happy_var_3 $ WarningTxt (sL1 happy_var_1 (getWARNING_PRAGs happy_var_1)) (snd $ unLoc happy_var_2)) (mo happy_var_1:mc happy_var_3 : (fst $ unLoc happy_var_2)))}}}) ) (\r -> happyReturn (happyIn38 r)) happyReduce_69 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_69 = happySpecReduce_0 22# happyReduction_69 happyReduction_69 = happyIn38 (Nothing ) happyReduce_70 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_70 = happySpecReduce_3 23# happyReduction_70 happyReduction_70 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn39 ((moc happy_var_1:mcc happy_var_3:(fst happy_var_2) , snd happy_var_2) )}}} happyReduce_71 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_71 = happySpecReduce_3 23# happyReduction_71 happyReduction_71 happy_x_3 happy_x_2 happy_x_1 = case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> happyIn39 ((fst happy_var_2, snd happy_var_2) )} happyReduce_72 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_72 = happySpecReduce_3 24# happyReduction_72 happyReduction_72 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn40 ((moc happy_var_1:mcc happy_var_3 :(fst happy_var_2), snd happy_var_2) )}}} happyReduce_73 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_73 = happySpecReduce_3 24# happyReduction_73 happyReduction_73 happy_x_3 happy_x_2 happy_x_1 = case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> happyIn40 (([],snd happy_var_2) )} happyReduce_74 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_74 = happySpecReduce_2 25# happyReduction_74 happyReduction_74 happy_x_2 happy_x_1 = case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> case happyOut42 happy_x_2 of { (HappyWrap42 happy_var_2) -> happyIn41 ((happy_var_1, happy_var_2) )}} happyReduce_75 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_75 = happySpecReduce_2 26# happyReduction_75 happyReduction_75 happy_x_2 happy_x_1 = case happyOut63 happy_x_1 of { (HappyWrap63 happy_var_1) -> case happyOut76 happy_x_2 of { (HappyWrap76 happy_var_2) -> happyIn42 ((reverse happy_var_1, cvTopDecls happy_var_2) )}} happyReduce_76 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_76 = happySpecReduce_2 26# happyReduction_76 happyReduction_76 happy_x_2 happy_x_1 = case happyOut63 happy_x_1 of { (HappyWrap63 happy_var_1) -> case happyOut75 happy_x_2 of { (HappyWrap75 happy_var_2) -> happyIn42 ((reverse happy_var_1, cvTopDecls happy_var_2) )}} happyReduce_77 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_77 = happySpecReduce_1 26# happyReduction_77 happyReduction_77 happy_x_1 = case happyOut62 happy_x_1 of { (HappyWrap62 happy_var_1) -> happyIn42 ((reverse happy_var_1, []) )} happyReduce_78 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_78 = happyMonadReduce 7# 27# happyReduction_78 happyReduction_78 (happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut35 happy_x_1 of { (HappyWrap35 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut319 happy_x_3 of { (HappyWrap319 happy_var_3) -> case happyOut38 happy_x_4 of { (HappyWrap38 happy_var_4) -> case happyOut48 happy_x_5 of { (HappyWrap48 happy_var_5) -> case happyOutTok happy_x_6 of { happy_var_6 -> case happyOut44 happy_x_7 of { (HappyWrap44 happy_var_7) -> ( fileSrcSpan >>= \ loc -> ams (cL loc (HsModule (Just happy_var_3) happy_var_5 happy_var_7 [] happy_var_4 happy_var_1 )) [mj AnnModule happy_var_2,mj AnnWhere happy_var_6])}}}}}}}) ) (\r -> happyReturn (happyIn43 r)) happyReduce_79 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_79 = happyMonadReduce 7# 27# happyReduction_79 happyReduction_79 (happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut35 happy_x_1 of { (HappyWrap35 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut319 happy_x_3 of { (HappyWrap319 happy_var_3) -> case happyOut38 happy_x_4 of { (HappyWrap38 happy_var_4) -> case happyOut48 happy_x_5 of { (HappyWrap48 happy_var_5) -> case happyOutTok happy_x_6 of { happy_var_6 -> case happyOut44 happy_x_7 of { (HappyWrap44 happy_var_7) -> ( fileSrcSpan >>= \ loc -> ams (cL loc (HsModule (Just happy_var_3) happy_var_5 happy_var_7 [] happy_var_4 happy_var_1 )) [mj AnnModule happy_var_2,mj AnnWhere happy_var_6])}}}}}}}) ) (\r -> happyReturn (happyIn43 r)) happyReduce_80 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_80 = happyMonadReduce 1# 27# happyReduction_80 happyReduction_80 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut45 happy_x_1 of { (HappyWrap45 happy_var_1) -> ( fileSrcSpan >>= \ loc -> return (cL loc (HsModule Nothing Nothing happy_var_1 [] Nothing Nothing)))}) ) (\r -> happyReturn (happyIn43 r)) happyReduce_81 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_81 = happySpecReduce_2 28# happyReduction_81 happyReduction_81 happy_x_2 happy_x_1 = case happyOut46 happy_x_2 of { (HappyWrap46 happy_var_2) -> happyIn44 (happy_var_2 )} happyReduce_82 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_82 = happySpecReduce_2 28# happyReduction_82 happyReduction_82 happy_x_2 happy_x_1 = case happyOut46 happy_x_2 of { (HappyWrap46 happy_var_2) -> happyIn44 (happy_var_2 )} happyReduce_83 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_83 = happySpecReduce_2 29# happyReduction_83 happyReduction_83 happy_x_2 happy_x_1 = case happyOut46 happy_x_2 of { (HappyWrap46 happy_var_2) -> happyIn45 (happy_var_2 )} happyReduce_84 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_84 = happySpecReduce_2 29# happyReduction_84 happyReduction_84 happy_x_2 happy_x_1 = case happyOut46 happy_x_2 of { (HappyWrap46 happy_var_2) -> happyIn45 (happy_var_2 )} happyReduce_85 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_85 = happySpecReduce_2 30# happyReduction_85 happyReduction_85 happy_x_2 happy_x_1 = case happyOut47 happy_x_2 of { (HappyWrap47 happy_var_2) -> happyIn46 (happy_var_2 )} happyReduce_86 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_86 = happySpecReduce_1 31# happyReduction_86 happyReduction_86 happy_x_1 = case happyOut63 happy_x_1 of { (HappyWrap63 happy_var_1) -> happyIn47 (happy_var_1 )} happyReduce_87 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_87 = happySpecReduce_1 31# happyReduction_87 happyReduction_87 happy_x_1 = case happyOut62 happy_x_1 of { (HappyWrap62 happy_var_1) -> happyIn47 (happy_var_1 )} happyReduce_88 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_88 = happyMonadReduce 3# 32# happyReduction_88 happyReduction_88 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut49 happy_x_2 of { (HappyWrap49 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( amsL (comb2 happy_var_1 happy_var_3) [mop happy_var_1,mcp happy_var_3] >> return (Just (sLL happy_var_1 happy_var_3 (fromOL happy_var_2))))}}}) ) (\r -> happyReturn (happyIn48 r)) happyReduce_89 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_89 = happySpecReduce_0 32# happyReduction_89 happyReduction_89 = happyIn48 (Nothing ) happyReduce_90 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_90 = happyMonadReduce 3# 33# happyReduction_90 happyReduction_90 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut51 happy_x_1 of { (HappyWrap51 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut51 happy_x_3 of { (HappyWrap51 happy_var_3) -> ( addAnnotation (oll happy_var_1) AnnComma (gl happy_var_2) >> return (happy_var_1 `appOL` happy_var_3))}}}) ) (\r -> happyReturn (happyIn49 r)) happyReduce_91 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_91 = happySpecReduce_1 33# happyReduction_91 happyReduction_91 happy_x_1 = case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> happyIn49 (happy_var_1 )} happyReduce_92 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_92 = happyMonadReduce 5# 34# happyReduction_92 happyReduction_92 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut51 happy_x_1 of { (HappyWrap51 happy_var_1) -> case happyOut53 happy_x_2 of { (HappyWrap53 happy_var_2) -> case happyOut51 happy_x_3 of { (HappyWrap51 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> case happyOut50 happy_x_5 of { (HappyWrap50 happy_var_5) -> ( (addAnnotation (oll (happy_var_1 `appOL` happy_var_2 `appOL` happy_var_3)) AnnComma (gl happy_var_4) ) >> return (happy_var_1 `appOL` happy_var_2 `appOL` happy_var_3 `appOL` happy_var_5))}}}}}) ) (\r -> happyReturn (happyIn50 r)) happyReduce_93 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_93 = happySpecReduce_3 34# happyReduction_93 happyReduction_93 happy_x_3 happy_x_2 happy_x_1 = case happyOut51 happy_x_1 of { (HappyWrap51 happy_var_1) -> case happyOut53 happy_x_2 of { (HappyWrap53 happy_var_2) -> case happyOut51 happy_x_3 of { (HappyWrap51 happy_var_3) -> happyIn50 (happy_var_1 `appOL` happy_var_2 `appOL` happy_var_3 )}}} happyReduce_94 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_94 = happySpecReduce_1 34# happyReduction_94 happyReduction_94 happy_x_1 = case happyOut51 happy_x_1 of { (HappyWrap51 happy_var_1) -> happyIn50 (happy_var_1 )} happyReduce_95 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_95 = happySpecReduce_2 35# happyReduction_95 happyReduction_95 happy_x_2 happy_x_1 = case happyOut52 happy_x_1 of { (HappyWrap52 happy_var_1) -> case happyOut51 happy_x_2 of { (HappyWrap51 happy_var_2) -> happyIn51 (happy_var_1 `appOL` happy_var_2 )}} happyReduce_96 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_96 = happySpecReduce_0 35# happyReduction_96 happyReduction_96 = happyIn51 (nilOL ) happyReduce_97 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_97 = happySpecReduce_1 36# happyReduction_97 happyReduction_97 happy_x_1 = case happyOut326 happy_x_1 of { (HappyWrap326 happy_var_1) -> happyIn52 (unitOL (sL1 happy_var_1 (case (unLoc happy_var_1) of (n, doc) -> IEGroup noExtField n doc)) )} happyReduce_98 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_98 = happySpecReduce_1 36# happyReduction_98 happyReduction_98 happy_x_1 = case happyOut325 happy_x_1 of { (HappyWrap325 happy_var_1) -> happyIn52 (unitOL (sL1 happy_var_1 (IEDocNamed noExtField ((fst . unLoc) happy_var_1))) )} happyReduce_99 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_99 = happySpecReduce_1 36# happyReduction_99 happyReduction_99 happy_x_1 = case happyOut323 happy_x_1 of { (HappyWrap323 happy_var_1) -> happyIn52 (unitOL (sL1 happy_var_1 (IEDoc noExtField (unLoc happy_var_1))) )} happyReduce_100 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_100 = happyMonadReduce 2# 37# happyReduction_100 happyReduction_100 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> case happyOut54 happy_x_2 of { (HappyWrap54 happy_var_2) -> ( mkModuleImpExp happy_var_1 (snd $ unLoc happy_var_2) >>= \ie -> amsu (sLL happy_var_1 happy_var_2 ie) (fst $ unLoc happy_var_2))}}) ) (\r -> happyReturn (happyIn53 r)) happyReduce_101 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_101 = happyMonadReduce 2# 37# happyReduction_101 happyReduction_101 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut319 happy_x_2 of { (HappyWrap319 happy_var_2) -> ( amsu (sLL happy_var_1 happy_var_2 (IEModuleContents noExtField happy_var_2)) [mj AnnModule happy_var_1])}}) ) (\r -> happyReturn (happyIn53 r)) happyReduce_102 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_102 = happyMonadReduce 2# 37# happyReduction_102 happyReduction_102 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut274 happy_x_2 of { (HappyWrap274 happy_var_2) -> ( amsu (sLL happy_var_1 happy_var_2 (IEVar noExtField (sLL happy_var_1 happy_var_2 (IEPattern happy_var_2)))) [mj AnnPattern happy_var_1])}}) ) (\r -> happyReturn (happyIn53 r)) happyReduce_103 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_103 = happySpecReduce_0 38# happyReduction_103 happyReduction_103 = happyIn54 (sL0 ([],ImpExpAbs) ) happyReduce_104 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_104 = happyMonadReduce 3# 38# happyReduction_104 happyReduction_104 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut55 happy_x_2 of { (HappyWrap55 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( mkImpExpSubSpec (reverse (snd happy_var_2)) >>= \(as,ie) -> return $ sLL happy_var_1 happy_var_3 (as ++ [mop happy_var_1,mcp happy_var_3] ++ fst happy_var_2, ie))}}}) ) (\r -> happyReturn (happyIn54 r)) happyReduce_105 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_105 = happySpecReduce_0 39# happyReduction_105 happyReduction_105 = happyIn55 (([],[]) ) happyReduce_106 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_106 = happySpecReduce_1 39# happyReduction_106 happyReduction_106 happy_x_1 = case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> happyIn55 (happy_var_1 )} happyReduce_107 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_107 = happyMonadReduce 3# 40# happyReduction_107 happyReduction_107 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut57 happy_x_3 of { (HappyWrap57 happy_var_3) -> ( case (head (snd happy_var_1)) of l@(dL->L _ ImpExpQcWildcard) -> return ([mj AnnComma happy_var_2, mj AnnDotdot l] ,(snd (unLoc happy_var_3) : snd happy_var_1)) l -> (ams (head (snd happy_var_1)) [mj AnnComma happy_var_2] >> return (fst happy_var_1 ++ fst (unLoc happy_var_3), snd (unLoc happy_var_3) : snd happy_var_1)))}}}) ) (\r -> happyReturn (happyIn56 r)) happyReduce_108 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_108 = happySpecReduce_1 40# happyReduction_108 happyReduction_108 happy_x_1 = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> happyIn56 ((fst (unLoc happy_var_1),[snd (unLoc happy_var_1)]) )} happyReduce_109 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_109 = happySpecReduce_1 41# happyReduction_109 happyReduction_109 happy_x_1 = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> happyIn57 (sL1 happy_var_1 ([],happy_var_1) )} happyReduce_110 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_110 = happySpecReduce_1 41# happyReduction_110 happyReduction_110 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn57 (sL1 happy_var_1 ([mj AnnDotdot happy_var_1], sL1 happy_var_1 ImpExpQcWildcard) )} happyReduce_111 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_111 = happySpecReduce_1 42# happyReduction_111 happyReduction_111 happy_x_1 = case happyOut59 happy_x_1 of { (HappyWrap59 happy_var_1) -> happyIn58 (sL1 happy_var_1 (ImpExpQcName happy_var_1) )} happyReduce_112 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_112 = happyMonadReduce 2# 42# happyReduction_112 happyReduction_112 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut284 happy_x_2 of { (HappyWrap284 happy_var_2) -> ( do { n <- mkTypeImpExp happy_var_2 ; ams (sLL happy_var_1 happy_var_2 (ImpExpQcType n)) [mj AnnType happy_var_1] })}}) ) (\r -> happyReturn (happyIn58 r)) happyReduce_113 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_113 = happySpecReduce_1 43# happyReduction_113 happyReduction_113 happy_x_1 = case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> happyIn59 (happy_var_1 )} happyReduce_114 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_114 = happySpecReduce_1 43# happyReduction_114 happyReduction_114 happy_x_1 = case happyOut285 happy_x_1 of { (HappyWrap285 happy_var_1) -> happyIn59 (happy_var_1 )} happyReduce_115 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_115 = happySpecReduce_2 44# happyReduction_115 happyReduction_115 happy_x_2 happy_x_1 = case happyOut60 happy_x_1 of { (HappyWrap60 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> happyIn60 (mj AnnSemi happy_var_2 : happy_var_1 )}} happyReduce_116 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_116 = happySpecReduce_1 44# happyReduction_116 happyReduction_116 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn60 ([mj AnnSemi happy_var_1] )} happyReduce_117 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_117 = happySpecReduce_2 45# happyReduction_117 happyReduction_117 happy_x_2 happy_x_1 = case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> happyIn61 (mj AnnSemi happy_var_2 : happy_var_1 )}} happyReduce_118 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_118 = happySpecReduce_0 45# happyReduction_118 happyReduction_118 = happyIn61 ([] ) happyReduce_119 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_119 = happySpecReduce_2 46# happyReduction_119 happyReduction_119 happy_x_2 happy_x_1 = case happyOut63 happy_x_1 of { (HappyWrap63 happy_var_1) -> case happyOut64 happy_x_2 of { (HappyWrap64 happy_var_2) -> happyIn62 (happy_var_2 : happy_var_1 )}} happyReduce_120 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_120 = happyMonadReduce 3# 47# happyReduction_120 happyReduction_120 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut63 happy_x_1 of { (HappyWrap63 happy_var_1) -> case happyOut64 happy_x_2 of { (HappyWrap64 happy_var_2) -> case happyOut60 happy_x_3 of { (HappyWrap60 happy_var_3) -> ( ams happy_var_2 happy_var_3 >> return (happy_var_2 : happy_var_1))}}}) ) (\r -> happyReturn (happyIn63 r)) happyReduce_121 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_121 = happySpecReduce_0 47# happyReduction_121 happyReduction_121 = happyIn63 ([] ) happyReduce_122 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_122 = happyMonadReduce 9# 48# happyReduction_122 happyReduction_122 (happy_x_9 `HappyStk` happy_x_8 `HappyStk` happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut65 happy_x_2 of { (HappyWrap65 happy_var_2) -> case happyOut66 happy_x_3 of { (HappyWrap66 happy_var_3) -> case happyOut68 happy_x_4 of { (HappyWrap68 happy_var_4) -> case happyOut67 happy_x_5 of { (HappyWrap67 happy_var_5) -> case happyOut319 happy_x_6 of { (HappyWrap319 happy_var_6) -> case happyOut68 happy_x_7 of { (HappyWrap68 happy_var_7) -> case happyOut69 happy_x_8 of { (HappyWrap69 happy_var_8) -> case happyOut70 happy_x_9 of { (HappyWrap70 happy_var_9) -> ( do { ; checkImportDecl happy_var_4 happy_var_7 ; ams (cL (comb4 happy_var_1 happy_var_6 (snd happy_var_8) happy_var_9) $ ImportDecl { ideclExt = noExtField , ideclSourceSrc = snd $ fst happy_var_2 , ideclName = happy_var_6, ideclPkgQual = snd happy_var_5 , ideclSource = snd happy_var_2, ideclSafe = snd happy_var_3 , ideclQualified = importDeclQualifiedStyle happy_var_4 happy_var_7 , ideclImplicit = False , ideclAs = unLoc (snd happy_var_8) , ideclHiding = unLoc happy_var_9 }) (mj AnnImport happy_var_1 : fst (fst happy_var_2) ++ fst happy_var_3 ++ fmap (mj AnnQualified) (maybeToList happy_var_4) ++ fst happy_var_5 ++ fmap (mj AnnQualified) (maybeToList happy_var_7) ++ fst happy_var_8) })}}}}}}}}}) ) (\r -> happyReturn (happyIn64 r)) happyReduce_123 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_123 = happySpecReduce_2 49# happyReduction_123 happyReduction_123 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> happyIn65 ((([mo happy_var_1,mc happy_var_2],getSOURCE_PRAGs happy_var_1) , True) )}} happyReduce_124 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_124 = happySpecReduce_0 49# happyReduction_124 happyReduction_124 = happyIn65 ((([],NoSourceText),False) ) happyReduce_125 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_125 = happySpecReduce_1 50# happyReduction_125 happyReduction_125 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn66 (([mj AnnSafe happy_var_1],True) )} happyReduce_126 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_126 = happySpecReduce_0 50# happyReduction_126 happyReduction_126 = happyIn66 (([],False) ) happyReduce_127 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_127 = happyMonadReduce 1# 51# happyReduction_127 happyReduction_127 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( do { let { pkgFS = getSTRING happy_var_1 } ; unless (looksLikePackageName (unpackFS pkgFS)) $ addError (getLoc happy_var_1) $ vcat [ text "Parse error" <> colon <+> quotes (ppr pkgFS), text "Version number or non-alphanumeric" <+> text "character in package name"] ; return ([mj AnnPackageName happy_var_1], Just (StringLiteral (getSTRINGs happy_var_1) pkgFS)) })}) ) (\r -> happyReturn (happyIn67 r)) happyReduce_128 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_128 = happySpecReduce_0 51# happyReduction_128 happyReduction_128 = happyIn67 (([],Nothing) ) happyReduce_129 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_129 = happySpecReduce_1 52# happyReduction_129 happyReduction_129 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn68 (Just happy_var_1 )} happyReduce_130 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_130 = happySpecReduce_0 52# happyReduction_130 happyReduction_130 = happyIn68 (Nothing ) happyReduce_131 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_131 = happySpecReduce_2 53# happyReduction_131 happyReduction_131 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut319 happy_x_2 of { (HappyWrap319 happy_var_2) -> happyIn69 (([mj AnnAs happy_var_1] ,sLL happy_var_1 happy_var_2 (Just happy_var_2)) )}} happyReduce_132 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_132 = happySpecReduce_0 53# happyReduction_132 happyReduction_132 = happyIn69 (([],noLoc Nothing) ) happyReduce_133 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_133 = happyMonadReduce 1# 54# happyReduction_133 happyReduction_133 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut71 happy_x_1 of { (HappyWrap71 happy_var_1) -> ( let (b, ie) = unLoc happy_var_1 in checkImportSpec ie >>= \checkedIe -> return (cL (gl happy_var_1) (Just (b, checkedIe))))}) ) (\r -> happyReturn (happyIn70 r)) happyReduce_134 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_134 = happySpecReduce_0 54# happyReduction_134 happyReduction_134 = happyIn70 (noLoc Nothing ) happyReduce_135 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_135 = happyMonadReduce 3# 55# happyReduction_135 happyReduction_135 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut49 happy_x_2 of { (HappyWrap49 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (False, sLL happy_var_1 happy_var_3 $ fromOL happy_var_2)) [mop happy_var_1,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn71 r)) happyReduce_136 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_136 = happyMonadReduce 4# 55# happyReduction_136 happyReduction_136 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut49 happy_x_3 of { (HappyWrap49 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> ( ams (sLL happy_var_1 happy_var_4 (True, sLL happy_var_1 happy_var_4 $ fromOL happy_var_3)) [mj AnnHiding happy_var_1,mop happy_var_2,mcp happy_var_4])}}}}) ) (\r -> happyReturn (happyIn71 r)) happyReduce_137 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_137 = happySpecReduce_0 56# happyReduction_137 happyReduction_137 = happyIn72 (noLoc (NoSourceText,9) ) happyReduce_138 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_138 = happySpecReduce_1 56# happyReduction_138 happyReduction_138 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn72 (sL1 happy_var_1 (getINTEGERs happy_var_1,fromInteger (il_value (getINTEGER happy_var_1))) )} happyReduce_139 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_139 = happySpecReduce_1 57# happyReduction_139 happyReduction_139 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn73 (sL1 happy_var_1 InfixN )} happyReduce_140 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_140 = happySpecReduce_1 57# happyReduction_140 happyReduction_140 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn73 (sL1 happy_var_1 InfixL )} happyReduce_141 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_141 = happySpecReduce_1 57# happyReduction_141 happyReduction_141 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn73 (sL1 happy_var_1 InfixR )} happyReduce_142 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_142 = happyMonadReduce 3# 58# happyReduction_142 happyReduction_142 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut74 happy_x_1 of { (HappyWrap74 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut292 happy_x_3 of { (HappyWrap292 happy_var_3) -> ( addAnnotation (oll $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> return (sLL happy_var_1 happy_var_3 ((unLoc happy_var_1) `appOL` unitOL happy_var_3)))}}}) ) (\r -> happyReturn (happyIn74 r)) happyReduce_143 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_143 = happySpecReduce_1 58# happyReduction_143 happyReduction_143 happy_x_1 = case happyOut292 happy_x_1 of { (HappyWrap292 happy_var_1) -> happyIn74 (sL1 happy_var_1 (unitOL happy_var_1) )} happyReduce_144 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_144 = happySpecReduce_2 59# happyReduction_144 happyReduction_144 happy_x_2 happy_x_1 = case happyOut76 happy_x_1 of { (HappyWrap76 happy_var_1) -> case happyOut77 happy_x_2 of { (HappyWrap77 happy_var_2) -> happyIn75 (happy_var_1 `snocOL` happy_var_2 )}} happyReduce_145 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_145 = happyMonadReduce 3# 60# happyReduction_145 happyReduction_145 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut76 happy_x_1 of { (HappyWrap76 happy_var_1) -> case happyOut77 happy_x_2 of { (HappyWrap77 happy_var_2) -> case happyOut60 happy_x_3 of { (HappyWrap60 happy_var_3) -> ( ams happy_var_2 happy_var_3 >> return (happy_var_1 `snocOL` happy_var_2))}}}) ) (\r -> happyReturn (happyIn76 r)) happyReduce_146 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_146 = happySpecReduce_0 60# happyReduction_146 happyReduction_146 = happyIn76 (nilOL ) happyReduce_147 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_147 = happySpecReduce_1 61# happyReduction_147 happyReduction_147 happy_x_1 = case happyOut78 happy_x_1 of { (HappyWrap78 happy_var_1) -> happyIn77 (sL1 happy_var_1 (TyClD noExtField (unLoc happy_var_1)) )} happyReduce_148 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_148 = happySpecReduce_1 61# happyReduction_148 happyReduction_148 happy_x_1 = case happyOut79 happy_x_1 of { (HappyWrap79 happy_var_1) -> happyIn77 (sL1 happy_var_1 (TyClD noExtField (unLoc happy_var_1)) )} happyReduce_149 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_149 = happySpecReduce_1 61# happyReduction_149 happyReduction_149 happy_x_1 = case happyOut80 happy_x_1 of { (HappyWrap80 happy_var_1) -> happyIn77 (sL1 happy_var_1 (KindSigD noExtField (unLoc happy_var_1)) )} happyReduce_150 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_150 = happySpecReduce_1 61# happyReduction_150 happyReduction_150 happy_x_1 = case happyOut82 happy_x_1 of { (HappyWrap82 happy_var_1) -> happyIn77 (sL1 happy_var_1 (InstD noExtField (unLoc happy_var_1)) )} happyReduce_151 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_151 = happySpecReduce_1 61# happyReduction_151 happyReduction_151 happy_x_1 = case happyOut106 happy_x_1 of { (HappyWrap106 happy_var_1) -> happyIn77 (sLL happy_var_1 happy_var_1 (DerivD noExtField (unLoc happy_var_1)) )} happyReduce_152 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_152 = happySpecReduce_1 61# happyReduction_152 happyReduction_152 happy_x_1 = case happyOut107 happy_x_1 of { (HappyWrap107 happy_var_1) -> happyIn77 (sL1 happy_var_1 (RoleAnnotD noExtField (unLoc happy_var_1)) )} happyReduce_153 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_153 = happyMonadReduce 4# 61# happyReduction_153 happyReduction_153 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> ( ams (sLL happy_var_1 happy_var_4 (DefD noExtField (DefaultDecl noExtField happy_var_3))) [mj AnnDefault happy_var_1 ,mop happy_var_2,mcp happy_var_4])}}}}) ) (\r -> happyReturn (happyIn77 r)) happyReduce_154 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_154 = happyMonadReduce 2# 61# happyReduction_154 happyReduction_154 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut143 happy_x_2 of { (HappyWrap143 happy_var_2) -> ( ams (sLL happy_var_1 happy_var_2 (snd $ unLoc happy_var_2)) (mj AnnForeign happy_var_1:(fst $ unLoc happy_var_2)))}}) ) (\r -> happyReturn (happyIn77 r)) happyReduce_155 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_155 = happyMonadReduce 3# 61# happyReduction_155 happyReduction_155 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut138 happy_x_2 of { (HappyWrap138 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ WarningD noExtField (Warnings noExtField (getDEPRECATED_PRAGs happy_var_1) (fromOL happy_var_2))) [mo happy_var_1,mc happy_var_3])}}}) ) (\r -> happyReturn (happyIn77 r)) happyReduce_156 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_156 = happyMonadReduce 3# 61# happyReduction_156 happyReduction_156 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut136 happy_x_2 of { (HappyWrap136 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ WarningD noExtField (Warnings noExtField (getWARNING_PRAGs happy_var_1) (fromOL happy_var_2))) [mo happy_var_1,mc happy_var_3])}}}) ) (\r -> happyReturn (happyIn77 r)) happyReduce_157 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_157 = happyMonadReduce 3# 61# happyReduction_157 happyReduction_157 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut129 happy_x_2 of { (HappyWrap129 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ RuleD noExtField (HsRules noExtField (getRULES_PRAGs happy_var_1) (fromOL happy_var_2))) [mo happy_var_1,mc happy_var_3])}}}) ) (\r -> happyReturn (happyIn77 r)) happyReduce_158 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_158 = happySpecReduce_1 61# happyReduction_158 happyReduction_158 happy_x_1 = case happyOut142 happy_x_1 of { (HappyWrap142 happy_var_1) -> happyIn77 (happy_var_1 )} happyReduce_159 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_159 = happySpecReduce_1 61# happyReduction_159 happyReduction_159 happy_x_1 = case happyOut200 happy_x_1 of { (HappyWrap200 happy_var_1) -> happyIn77 (happy_var_1 )} happyReduce_160 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_160 = happyMonadReduce 1# 61# happyReduction_160 happyReduction_160 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut211 happy_x_1 of { (HappyWrap211 happy_var_1) -> ( runECP_P happy_var_1 >>= \ happy_var_1 -> return $ sLL happy_var_1 happy_var_1 $ mkSpliceDecl happy_var_1)}) ) (\r -> happyReturn (happyIn77 r)) happyReduce_161 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_161 = happyMonadReduce 4# 62# happyReduction_161 happyReduction_161 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut103 happy_x_2 of { (HappyWrap103 happy_var_2) -> case happyOut177 happy_x_3 of { (HappyWrap177 happy_var_3) -> case happyOut120 happy_x_4 of { (HappyWrap120 happy_var_4) -> ( amms (mkClassDecl (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) happy_var_2 happy_var_3 (snd $ unLoc happy_var_4)) (mj AnnClass happy_var_1:(fst $ unLoc happy_var_3)++(fst $ unLoc happy_var_4)))}}}}) ) (\r -> happyReturn (happyIn78 r)) happyReduce_162 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_162 = happyMonadReduce 4# 63# happyReduction_162 happyReduction_162 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut161 happy_x_2 of { (HappyWrap161 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut156 happy_x_4 of { (HappyWrap156 happy_var_4) -> ( amms (mkTySynonym (comb2 happy_var_1 happy_var_4) happy_var_2 happy_var_4) [mj AnnType happy_var_1,mj AnnEqual happy_var_3])}}}}) ) (\r -> happyReturn (happyIn79 r)) happyReduce_163 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_163 = happyMonadReduce 6# 63# happyReduction_163 happyReduction_163 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> case happyOut101 happy_x_4 of { (HappyWrap101 happy_var_4) -> case happyOut87 happy_x_5 of { (HappyWrap87 happy_var_5) -> case happyOut90 happy_x_6 of { (HappyWrap90 happy_var_6) -> ( amms (mkFamDecl (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (snd $ unLoc happy_var_6) happy_var_3 (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5)) (mj AnnType happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4) ++ (fst $ unLoc happy_var_5) ++ (fst $ unLoc happy_var_6)))}}}}}}) ) (\r -> happyReturn (happyIn79 r)) happyReduce_164 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_164 = happyMonadReduce 5# 63# happyReduction_164 happyReduction_164 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut98 happy_x_1 of { (HappyWrap98 happy_var_1) -> case happyOut105 happy_x_2 of { (HappyWrap105 happy_var_2) -> case happyOut103 happy_x_3 of { (HappyWrap103 happy_var_3) -> case happyOut186 happy_x_4 of { (HappyWrap186 happy_var_4) -> case happyOut194 happy_x_5 of { (HappyWrap194 happy_var_5) -> ( amms (mkTyData (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (snd $ unLoc happy_var_1) happy_var_2 happy_var_3 Nothing (reverse (snd $ unLoc happy_var_4)) (fmap reverse happy_var_5)) -- We need the location on tycl_hdr in case -- constrs and deriving are both empty ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_4)))}}}}}) ) (\r -> happyReturn (happyIn79 r)) happyReduce_165 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_165 = happyMonadReduce 6# 63# happyReduction_165 happyReduction_165 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut98 happy_x_1 of { (HappyWrap98 happy_var_1) -> case happyOut105 happy_x_2 of { (HappyWrap105 happy_var_2) -> case happyOut103 happy_x_3 of { (HappyWrap103 happy_var_3) -> case happyOut99 happy_x_4 of { (HappyWrap99 happy_var_4) -> case happyOut182 happy_x_5 of { (HappyWrap182 happy_var_5) -> case happyOut194 happy_x_6 of { (HappyWrap194 happy_var_6) -> ( amms (mkTyData (comb4 happy_var_1 happy_var_3 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_2 happy_var_3 (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) (fmap reverse happy_var_6) ) -- We need the location on tycl_hdr in case -- constrs and deriving are both empty ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)))}}}}}}) ) (\r -> happyReturn (happyIn79 r)) happyReduce_166 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_166 = happyMonadReduce 4# 63# happyReduction_166 happyReduction_166 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> case happyOut100 happy_x_4 of { (HappyWrap100 happy_var_4) -> ( amms (mkFamDecl (comb3 happy_var_1 happy_var_2 happy_var_4) DataFamily happy_var_3 (snd $ unLoc happy_var_4) Nothing) (mj AnnData happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4)))}}}}) ) (\r -> happyReturn (happyIn79 r)) happyReduce_167 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_167 = happyMonadReduce 4# 64# happyReduction_167 happyReduction_167 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut81 happy_x_2 of { (HappyWrap81 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut156 happy_x_4 of { (HappyWrap156 happy_var_4) -> ( amms (mkStandaloneKindSig (comb2 happy_var_1 happy_var_4) happy_var_2 happy_var_4) [mj AnnType happy_var_1,mu AnnDcolon happy_var_3])}}}}) ) (\r -> happyReturn (happyIn80 r)) happyReduce_168 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_168 = happyMonadReduce 3# 65# happyReduction_168 happyReduction_168 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut81 happy_x_1 of { (HappyWrap81 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut284 happy_x_3 of { (HappyWrap284 happy_var_3) -> ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))}}}) ) (\r -> happyReturn (happyIn81 r)) happyReduce_169 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_169 = happySpecReduce_1 65# happyReduction_169 happyReduction_169 happy_x_1 = case happyOut284 happy_x_1 of { (HappyWrap284 happy_var_1) -> happyIn81 (sL1 happy_var_1 [happy_var_1] )} happyReduce_170 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_170 = happyMonadReduce 4# 66# happyReduction_170 happyReduction_170 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut83 happy_x_2 of { (HappyWrap83 happy_var_2) -> case happyOut170 happy_x_3 of { (HappyWrap170 happy_var_3) -> case happyOut124 happy_x_4 of { (HappyWrap124 happy_var_4) -> ( do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc happy_var_4) ; let cid = ClsInstDecl { cid_ext = noExtField , cid_poly_ty = happy_var_3, cid_binds = binds , cid_sigs = mkClassOpSigs sigs , cid_tyfam_insts = ats , cid_overlap_mode = happy_var_2 , cid_datafam_insts = adts } ; ams (cL (comb3 happy_var_1 (hsSigType happy_var_3) happy_var_4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid })) (mj AnnInstance happy_var_1 : (fst $ unLoc happy_var_4)) })}}}}) ) (\r -> happyReturn (happyIn82 r)) happyReduce_171 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_171 = happyMonadReduce 3# 66# happyReduction_171 happyReduction_171 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut93 happy_x_3 of { (HappyWrap93 happy_var_3) -> ( ams happy_var_3 (fst $ unLoc happy_var_3) >> amms (mkTyFamInst (comb2 happy_var_1 happy_var_3) (snd $ unLoc happy_var_3)) (mj AnnType happy_var_1:mj AnnInstance happy_var_2:(fst $ unLoc happy_var_3)))}}}) ) (\r -> happyReturn (happyIn82 r)) happyReduce_172 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_172 = happyMonadReduce 6# 66# happyReduction_172 happyReduction_172 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut98 happy_x_1 of { (HappyWrap98 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut105 happy_x_3 of { (HappyWrap105 happy_var_3) -> case happyOut104 happy_x_4 of { (HappyWrap104 happy_var_4) -> case happyOut186 happy_x_5 of { (HappyWrap186 happy_var_5) -> case happyOut194 happy_x_6 of { (HappyWrap194 happy_var_6) -> ( amms (mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_3 (snd $ unLoc happy_var_4) Nothing (reverse (snd $ unLoc happy_var_5)) (fmap reverse happy_var_6)) ((fst $ unLoc happy_var_1):mj AnnInstance happy_var_2:(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)))}}}}}}) ) (\r -> happyReturn (happyIn82 r)) happyReduce_173 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_173 = happyMonadReduce 7# 66# happyReduction_173 happyReduction_173 (happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut98 happy_x_1 of { (HappyWrap98 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut105 happy_x_3 of { (HappyWrap105 happy_var_3) -> case happyOut104 happy_x_4 of { (HappyWrap104 happy_var_4) -> case happyOut99 happy_x_5 of { (HappyWrap99 happy_var_5) -> case happyOut182 happy_x_6 of { (HappyWrap182 happy_var_6) -> case happyOut194 happy_x_7 of { (HappyWrap194 happy_var_7) -> ( amms (mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_6 happy_var_7) (snd $ unLoc happy_var_1) happy_var_3 (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) (snd $ unLoc happy_var_6) (fmap reverse happy_var_7)) ((fst $ unLoc happy_var_1):mj AnnInstance happy_var_2 :(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)++(fst $ unLoc happy_var_6)))}}}}}}}) ) (\r -> happyReturn (happyIn82 r)) happyReduce_174 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_174 = happyMonadReduce 2# 67# happyReduction_174 happyReduction_174 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> ( ajs (sLL happy_var_1 happy_var_2 (Overlappable (getOVERLAPPABLE_PRAGs happy_var_1))) [mo happy_var_1,mc happy_var_2])}}) ) (\r -> happyReturn (happyIn83 r)) happyReduce_175 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_175 = happyMonadReduce 2# 67# happyReduction_175 happyReduction_175 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> ( ajs (sLL happy_var_1 happy_var_2 (Overlapping (getOVERLAPPING_PRAGs happy_var_1))) [mo happy_var_1,mc happy_var_2])}}) ) (\r -> happyReturn (happyIn83 r)) happyReduce_176 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_176 = happyMonadReduce 2# 67# happyReduction_176 happyReduction_176 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> ( ajs (sLL happy_var_1 happy_var_2 (Overlaps (getOVERLAPS_PRAGs happy_var_1))) [mo happy_var_1,mc happy_var_2])}}) ) (\r -> happyReturn (happyIn83 r)) happyReduce_177 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_177 = happyMonadReduce 2# 67# happyReduction_177 happyReduction_177 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> ( ajs (sLL happy_var_1 happy_var_2 (Incoherent (getINCOHERENT_PRAGs happy_var_1))) [mo happy_var_1,mc happy_var_2])}}) ) (\r -> happyReturn (happyIn83 r)) happyReduce_178 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_178 = happySpecReduce_0 67# happyReduction_178 happyReduction_178 = happyIn83 (Nothing ) happyReduce_179 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_179 = happyMonadReduce 1# 68# happyReduction_179 happyReduction_179 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( ams (sL1 happy_var_1 StockStrategy) [mj AnnStock happy_var_1])}) ) (\r -> happyReturn (happyIn84 r)) happyReduce_180 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_180 = happyMonadReduce 1# 68# happyReduction_180 happyReduction_180 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( ams (sL1 happy_var_1 AnyclassStrategy) [mj AnnAnyclass happy_var_1])}) ) (\r -> happyReturn (happyIn84 r)) happyReduce_181 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_181 = happyMonadReduce 1# 68# happyReduction_181 happyReduction_181 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( ams (sL1 happy_var_1 NewtypeStrategy) [mj AnnNewtype happy_var_1])}) ) (\r -> happyReturn (happyIn84 r)) happyReduce_182 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_182 = happyMonadReduce 2# 69# happyReduction_182 happyReduction_182 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut161 happy_x_2 of { (HappyWrap161 happy_var_2) -> ( ams (sLL happy_var_1 happy_var_2 (ViaStrategy (mkLHsSigType happy_var_2))) [mj AnnVia happy_var_1])}}) ) (\r -> happyReturn (happyIn85 r)) happyReduce_183 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_183 = happyMonadReduce 1# 70# happyReduction_183 happyReduction_183 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( ajs (sL1 happy_var_1 StockStrategy) [mj AnnStock happy_var_1])}) ) (\r -> happyReturn (happyIn86 r)) happyReduce_184 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_184 = happyMonadReduce 1# 70# happyReduction_184 happyReduction_184 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( ajs (sL1 happy_var_1 AnyclassStrategy) [mj AnnAnyclass happy_var_1])}) ) (\r -> happyReturn (happyIn86 r)) happyReduce_185 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_185 = happyMonadReduce 1# 70# happyReduction_185 happyReduction_185 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( ajs (sL1 happy_var_1 NewtypeStrategy) [mj AnnNewtype happy_var_1])}) ) (\r -> happyReturn (happyIn86 r)) happyReduce_186 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_186 = happySpecReduce_1 70# happyReduction_186 happyReduction_186 happy_x_1 = case happyOut85 happy_x_1 of { (HappyWrap85 happy_var_1) -> happyIn86 (Just happy_var_1 )} happyReduce_187 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_187 = happySpecReduce_0 70# happyReduction_187 happyReduction_187 = happyIn86 (Nothing ) happyReduce_188 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_188 = happySpecReduce_0 71# happyReduction_188 happyReduction_188 = happyIn87 (noLoc ([], Nothing) ) happyReduce_189 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_189 = happySpecReduce_2 71# happyReduction_189 happyReduction_189 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut88 happy_x_2 of { (HappyWrap88 happy_var_2) -> happyIn87 (sLL happy_var_1 happy_var_2 ([mj AnnVbar happy_var_1] , Just (happy_var_2)) )}} happyReduce_190 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_190 = happyMonadReduce 3# 72# happyReduction_190 happyReduction_190 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut89 happy_x_3 of { (HappyWrap89 happy_var_3) -> ( ams (sLL happy_var_1 happy_var_3 (InjectivityAnn happy_var_1 (reverse (unLoc happy_var_3)))) [mu AnnRarrow happy_var_2])}}}) ) (\r -> happyReturn (happyIn88 r)) happyReduce_191 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_191 = happySpecReduce_2 73# happyReduction_191 happyReduction_191 happy_x_2 happy_x_1 = case happyOut89 happy_x_1 of { (HappyWrap89 happy_var_1) -> case happyOut301 happy_x_2 of { (HappyWrap301 happy_var_2) -> happyIn89 (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) )}} happyReduce_192 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_192 = happySpecReduce_1 73# happyReduction_192 happyReduction_192 happy_x_1 = case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> happyIn89 (sLL happy_var_1 happy_var_1 [happy_var_1] )} happyReduce_193 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_193 = happySpecReduce_0 74# happyReduction_193 happyReduction_193 = happyIn90 (noLoc ([],OpenTypeFamily) ) happyReduce_194 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_194 = happySpecReduce_2 74# happyReduction_194 happyReduction_194 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut91 happy_x_2 of { (HappyWrap91 happy_var_2) -> happyIn90 (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2) ,ClosedTypeFamily (fmap reverse $ snd $ unLoc happy_var_2)) )}} happyReduce_195 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_195 = happySpecReduce_3 75# happyReduction_195 happyReduction_195 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut92 happy_x_2 of { (HappyWrap92 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn91 (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3] ,Just (unLoc happy_var_2)) )}}} happyReduce_196 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_196 = happySpecReduce_3 75# happyReduction_196 happyReduction_196 happy_x_3 happy_x_2 happy_x_1 = case happyOut92 happy_x_2 of { (HappyWrap92 happy_var_2) -> happyIn91 (let (dL->L loc _) = happy_var_2 in cL loc ([],Just (unLoc happy_var_2)) )} happyReduce_197 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_197 = happySpecReduce_3 75# happyReduction_197 happyReduction_197 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn91 (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mj AnnDotdot happy_var_2 ,mcc happy_var_3],Nothing) )}}} happyReduce_198 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_198 = happySpecReduce_3 75# happyReduction_198 happyReduction_198 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_2 of { happy_var_2 -> happyIn91 (let (dL->L loc _) = happy_var_2 in cL loc ([mj AnnDotdot happy_var_2],Nothing) )} happyReduce_199 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_199 = happyMonadReduce 3# 76# happyReduction_199 happyReduction_199 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut92 happy_x_1 of { (HappyWrap92 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut93 happy_x_3 of { (HappyWrap93 happy_var_3) -> ( let (dL->L loc (anns, eqn)) = happy_var_3 in asl (unLoc happy_var_1) happy_var_2 (cL loc eqn) >> ams happy_var_3 anns >> return (sLL happy_var_1 happy_var_3 (cL loc eqn : unLoc happy_var_1)))}}}) ) (\r -> happyReturn (happyIn92 r)) happyReduce_200 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_200 = happyMonadReduce 2# 76# happyReduction_200 happyReduction_200 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut92 happy_x_1 of { (HappyWrap92 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> ( addAnnotation (gl happy_var_1) AnnSemi (gl happy_var_2) >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))}}) ) (\r -> happyReturn (happyIn92 r)) happyReduce_201 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_201 = happyMonadReduce 1# 76# happyReduction_201 happyReduction_201 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut93 happy_x_1 of { (HappyWrap93 happy_var_1) -> ( let (dL->L loc (anns, eqn)) = happy_var_1 in ams happy_var_1 anns >> return (sLL happy_var_1 happy_var_1 [cL loc eqn]))}) ) (\r -> happyReturn (happyIn92 r)) happyReduce_202 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_202 = happySpecReduce_0 76# happyReduction_202 happyReduction_202 = happyIn92 (noLoc [] ) happyReduce_203 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_203 = happyMonadReduce 6# 77# happyReduction_203 happyReduction_203 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut175 happy_x_2 of { (HappyWrap175 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut161 happy_x_4 of { (HappyWrap161 happy_var_4) -> case happyOutTok happy_x_5 of { happy_var_5 -> case happyOut155 happy_x_6 of { (HappyWrap155 happy_var_6) -> ( do { hintExplicitForall happy_var_1 ; (eqn,ann) <- mkTyFamInstEqn (Just happy_var_2) happy_var_4 happy_var_6 ; return (sLL happy_var_1 happy_var_6 (mu AnnForall happy_var_1:mj AnnDot happy_var_3:mj AnnEqual happy_var_5:ann,eqn)) })}}}}}}) ) (\r -> happyReturn (happyIn93 r)) happyReduce_204 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_204 = happyMonadReduce 3# 77# happyReduction_204 happyReduction_204 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut161 happy_x_1 of { (HappyWrap161 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut155 happy_x_3 of { (HappyWrap155 happy_var_3) -> ( do { (eqn,ann) <- mkTyFamInstEqn Nothing happy_var_1 happy_var_3 ; return (sLL happy_var_1 happy_var_3 (mj AnnEqual happy_var_2:ann, eqn)) })}}}) ) (\r -> happyReturn (happyIn93 r)) happyReduce_205 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_205 = happyMonadReduce 4# 78# happyReduction_205 happyReduction_205 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut95 happy_x_2 of { (HappyWrap95 happy_var_2) -> case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> case happyOut100 happy_x_4 of { (HappyWrap100 happy_var_4) -> ( amms (liftM mkTyClD (mkFamDecl (comb3 happy_var_1 happy_var_3 happy_var_4) DataFamily happy_var_3 (snd $ unLoc happy_var_4) Nothing)) (mj AnnData happy_var_1:happy_var_2++(fst $ unLoc happy_var_4)))}}}}) ) (\r -> happyReturn (happyIn94 r)) happyReduce_206 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_206 = happyMonadReduce 3# 78# happyReduction_206 happyReduction_206 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut161 happy_x_2 of { (HappyWrap161 happy_var_2) -> case happyOut102 happy_x_3 of { (HappyWrap102 happy_var_3) -> ( amms (liftM mkTyClD (mkFamDecl (comb3 happy_var_1 happy_var_2 happy_var_3) OpenTypeFamily happy_var_2 (fst . snd $ unLoc happy_var_3) (snd . snd $ unLoc happy_var_3))) (mj AnnType happy_var_1:(fst $ unLoc happy_var_3)))}}}) ) (\r -> happyReturn (happyIn94 r)) happyReduce_207 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_207 = happyMonadReduce 4# 78# happyReduction_207 happyReduction_207 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> case happyOut102 happy_x_4 of { (HappyWrap102 happy_var_4) -> ( amms (liftM mkTyClD (mkFamDecl (comb3 happy_var_1 happy_var_3 happy_var_4) OpenTypeFamily happy_var_3 (fst . snd $ unLoc happy_var_4) (snd . snd $ unLoc happy_var_4))) (mj AnnType happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4)))}}}}) ) (\r -> happyReturn (happyIn94 r)) happyReduce_208 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_208 = happyMonadReduce 2# 78# happyReduction_208 happyReduction_208 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut93 happy_x_2 of { (HappyWrap93 happy_var_2) -> ( ams happy_var_2 (fst $ unLoc happy_var_2) >> amms (liftM mkInstD (mkTyFamInst (comb2 happy_var_1 happy_var_2) (snd $ unLoc happy_var_2))) (mj AnnType happy_var_1:(fst $ unLoc happy_var_2)))}}) ) (\r -> happyReturn (happyIn94 r)) happyReduce_209 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_209 = happyMonadReduce 3# 78# happyReduction_209 happyReduction_209 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut93 happy_x_3 of { (HappyWrap93 happy_var_3) -> ( ams happy_var_3 (fst $ unLoc happy_var_3) >> amms (liftM mkInstD (mkTyFamInst (comb2 happy_var_1 happy_var_3) (snd $ unLoc happy_var_3))) (mj AnnType happy_var_1:mj AnnInstance happy_var_2:(fst $ unLoc happy_var_3)))}}}) ) (\r -> happyReturn (happyIn94 r)) happyReduce_210 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_210 = happySpecReduce_0 79# happyReduction_210 happyReduction_210 = happyIn95 ([] ) happyReduce_211 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_211 = happySpecReduce_1 79# happyReduction_211 happyReduction_211 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn95 ([mj AnnFamily happy_var_1] )} happyReduce_212 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_212 = happySpecReduce_0 80# happyReduction_212 happyReduction_212 = happyIn96 ([] ) happyReduce_213 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_213 = happySpecReduce_1 80# happyReduction_213 happyReduction_213 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn96 ([mj AnnInstance happy_var_1] )} happyReduce_214 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_214 = happyMonadReduce 3# 81# happyReduction_214 happyReduction_214 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut96 happy_x_2 of { (HappyWrap96 happy_var_2) -> case happyOut93 happy_x_3 of { (HappyWrap93 happy_var_3) -> ( ams happy_var_3 (fst $ unLoc happy_var_3) >> amms (mkTyFamInst (comb2 happy_var_1 happy_var_3) (snd $ unLoc happy_var_3)) (mj AnnType happy_var_1:happy_var_2++(fst $ unLoc happy_var_3)))}}}) ) (\r -> happyReturn (happyIn97 r)) happyReduce_215 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_215 = happyMonadReduce 6# 81# happyReduction_215 happyReduction_215 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut98 happy_x_1 of { (HappyWrap98 happy_var_1) -> case happyOut96 happy_x_2 of { (HappyWrap96 happy_var_2) -> case happyOut105 happy_x_3 of { (HappyWrap105 happy_var_3) -> case happyOut104 happy_x_4 of { (HappyWrap104 happy_var_4) -> case happyOut186 happy_x_5 of { (HappyWrap186 happy_var_5) -> case happyOut194 happy_x_6 of { (HappyWrap194 happy_var_6) -> ( amms (mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_3 (snd $ unLoc happy_var_4) Nothing (reverse (snd $ unLoc happy_var_5)) (fmap reverse happy_var_6)) ((fst $ unLoc happy_var_1):happy_var_2++(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)))}}}}}}) ) (\r -> happyReturn (happyIn97 r)) happyReduce_216 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_216 = happyMonadReduce 7# 81# happyReduction_216 happyReduction_216 (happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut98 happy_x_1 of { (HappyWrap98 happy_var_1) -> case happyOut96 happy_x_2 of { (HappyWrap96 happy_var_2) -> case happyOut105 happy_x_3 of { (HappyWrap105 happy_var_3) -> case happyOut104 happy_x_4 of { (HappyWrap104 happy_var_4) -> case happyOut99 happy_x_5 of { (HappyWrap99 happy_var_5) -> case happyOut182 happy_x_6 of { (HappyWrap182 happy_var_6) -> case happyOut194 happy_x_7 of { (HappyWrap194 happy_var_7) -> ( amms (mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_6 happy_var_7) (snd $ unLoc happy_var_1) happy_var_3 (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) (snd $ unLoc happy_var_6) (fmap reverse happy_var_7)) ((fst $ unLoc happy_var_1):happy_var_2++(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)++(fst $ unLoc happy_var_6)))}}}}}}}) ) (\r -> happyReturn (happyIn97 r)) happyReduce_217 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_217 = happySpecReduce_1 82# happyReduction_217 happyReduction_217 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn98 (sL1 happy_var_1 (mj AnnData happy_var_1,DataType) )} happyReduce_218 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_218 = happySpecReduce_1 82# happyReduction_218 happyReduction_218 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn98 (sL1 happy_var_1 (mj AnnNewtype happy_var_1,NewType) )} happyReduce_219 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_219 = happySpecReduce_0 83# happyReduction_219 happyReduction_219 = happyIn99 (noLoc ([] , Nothing) ) happyReduce_220 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_220 = happySpecReduce_2 83# happyReduction_220 happyReduction_220 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut181 happy_x_2 of { (HappyWrap181 happy_var_2) -> happyIn99 (sLL happy_var_1 happy_var_2 ([mu AnnDcolon happy_var_1], Just happy_var_2) )}} happyReduce_221 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_221 = happySpecReduce_0 84# happyReduction_221 happyReduction_221 = happyIn100 (noLoc ([] , noLoc (NoSig noExtField) ) ) happyReduce_222 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_222 = happySpecReduce_2 84# happyReduction_222 happyReduction_222 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut181 happy_x_2 of { (HappyWrap181 happy_var_2) -> happyIn100 (sLL happy_var_1 happy_var_2 ([mu AnnDcolon happy_var_1], sLL happy_var_1 happy_var_2 (KindSig noExtField happy_var_2)) )}} happyReduce_223 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_223 = happySpecReduce_0 85# happyReduction_223 happyReduction_223 = happyIn101 (noLoc ([] , noLoc (NoSig noExtField) ) ) happyReduce_224 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_224 = happySpecReduce_2 85# happyReduction_224 happyReduction_224 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut181 happy_x_2 of { (HappyWrap181 happy_var_2) -> happyIn101 (sLL happy_var_1 happy_var_2 ([mu AnnDcolon happy_var_1], sLL happy_var_1 happy_var_2 (KindSig noExtField happy_var_2)) )}} happyReduce_225 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_225 = happySpecReduce_2 85# happyReduction_225 happyReduction_225 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut176 happy_x_2 of { (HappyWrap176 happy_var_2) -> happyIn101 (sLL happy_var_1 happy_var_2 ([mj AnnEqual happy_var_1] , sLL happy_var_1 happy_var_2 (TyVarSig noExtField happy_var_2)) )}} happyReduce_226 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_226 = happySpecReduce_0 86# happyReduction_226 happyReduction_226 = happyIn102 (noLoc ([], (noLoc (NoSig noExtField), Nothing)) ) happyReduce_227 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_227 = happySpecReduce_2 86# happyReduction_227 happyReduction_227 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut181 happy_x_2 of { (HappyWrap181 happy_var_2) -> happyIn102 (sLL happy_var_1 happy_var_2 ( [mu AnnDcolon happy_var_1] , (sLL happy_var_2 happy_var_2 (KindSig noExtField happy_var_2), Nothing)) )}} happyReduce_228 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_228 = happyReduce 4# 86# happyReduction_228 happyReduction_228 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut176 happy_x_2 of { (HappyWrap176 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut88 happy_x_4 of { (HappyWrap88 happy_var_4) -> happyIn102 (sLL happy_var_1 happy_var_4 ([mj AnnEqual happy_var_1, mj AnnVbar happy_var_3] , (sLL happy_var_1 happy_var_2 (TyVarSig noExtField happy_var_2), Just happy_var_4)) ) `HappyStk` happyRest}}}} happyReduce_229 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_229 = happyMonadReduce 3# 87# happyReduction_229 happyReduction_229 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> ( addAnnotation (gl happy_var_1) (toUnicodeAnn AnnDarrow happy_var_2) (gl happy_var_2) >> (return (sLL happy_var_1 happy_var_3 (Just happy_var_1, happy_var_3))))}}}) ) (\r -> happyReturn (happyIn103 r)) happyReduce_230 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_230 = happySpecReduce_1 87# happyReduction_230 happyReduction_230 happy_x_1 = case happyOut161 happy_x_1 of { (HappyWrap161 happy_var_1) -> happyIn103 (sL1 happy_var_1 (Nothing, happy_var_1) )} happyReduce_231 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_231 = happyMonadReduce 6# 88# happyReduction_231 happyReduction_231 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut175 happy_x_2 of { (HappyWrap175 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut159 happy_x_4 of { (HappyWrap159 happy_var_4) -> case happyOutTok happy_x_5 of { happy_var_5 -> case happyOut161 happy_x_6 of { (HappyWrap161 happy_var_6) -> ( hintExplicitForall happy_var_1 >> (addAnnotation (gl happy_var_4) (toUnicodeAnn AnnDarrow happy_var_5) (gl happy_var_5) >> return (sLL happy_var_1 happy_var_6 ([mu AnnForall happy_var_1, mj AnnDot happy_var_3] , (Just happy_var_4, Just happy_var_2, happy_var_6))) ))}}}}}}) ) (\r -> happyReturn (happyIn104 r)) happyReduce_232 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_232 = happyMonadReduce 4# 88# happyReduction_232 happyReduction_232 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut175 happy_x_2 of { (HappyWrap175 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut161 happy_x_4 of { (HappyWrap161 happy_var_4) -> ( hintExplicitForall happy_var_1 >> return (sLL happy_var_1 happy_var_4 ([mu AnnForall happy_var_1, mj AnnDot happy_var_3] , (Nothing, Just happy_var_2, happy_var_4))))}}}}) ) (\r -> happyReturn (happyIn104 r)) happyReduce_233 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_233 = happyMonadReduce 3# 88# happyReduction_233 happyReduction_233 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> ( addAnnotation (gl happy_var_1) (toUnicodeAnn AnnDarrow happy_var_2) (gl happy_var_2) >> (return (sLL happy_var_1 happy_var_3([], (Just happy_var_1, Nothing, happy_var_3)))))}}}) ) (\r -> happyReturn (happyIn104 r)) happyReduce_234 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_234 = happySpecReduce_1 88# happyReduction_234 happyReduction_234 happy_x_1 = case happyOut161 happy_x_1 of { (HappyWrap161 happy_var_1) -> happyIn104 (sL1 happy_var_1 ([], (Nothing, Nothing, happy_var_1)) )} happyReduce_235 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_235 = happyMonadReduce 4# 89# happyReduction_235 happyReduction_235 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> ( ajs (sLL happy_var_1 happy_var_4 (CType (getCTYPEs happy_var_1) (Just (Header (getSTRINGs happy_var_2) (getSTRING happy_var_2))) (getSTRINGs happy_var_3,getSTRING happy_var_3))) [mo happy_var_1,mj AnnHeader happy_var_2,mj AnnVal happy_var_3,mc happy_var_4])}}}}) ) (\r -> happyReturn (happyIn105 r)) happyReduce_236 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_236 = happyMonadReduce 3# 89# happyReduction_236 happyReduction_236 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ajs (sLL happy_var_1 happy_var_3 (CType (getCTYPEs happy_var_1) Nothing (getSTRINGs happy_var_2, getSTRING happy_var_2))) [mo happy_var_1,mj AnnVal happy_var_2,mc happy_var_3])}}}) ) (\r -> happyReturn (happyIn105 r)) happyReduce_237 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_237 = happySpecReduce_0 89# happyReduction_237 happyReduction_237 = happyIn105 (Nothing ) happyReduce_238 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_238 = happyMonadReduce 5# 90# happyReduction_238 happyReduction_238 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut86 happy_x_2 of { (HappyWrap86 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut83 happy_x_4 of { (HappyWrap83 happy_var_4) -> case happyOut170 happy_x_5 of { (HappyWrap170 happy_var_5) -> ( do { let { err = text "in the stand-alone deriving instance" <> colon <+> quotes (ppr happy_var_5) } ; ams (sLL happy_var_1 (hsSigType happy_var_5) (DerivDecl noExtField (mkHsWildCardBndrs happy_var_5) happy_var_2 happy_var_4)) [mj AnnDeriving happy_var_1, mj AnnInstance happy_var_3] })}}}}}) ) (\r -> happyReturn (happyIn106 r)) happyReduce_239 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_239 = happyMonadReduce 4# 91# happyReduction_239 happyReduction_239 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut284 happy_x_3 of { (HappyWrap284 happy_var_3) -> case happyOut108 happy_x_4 of { (HappyWrap108 happy_var_4) -> ( amms (mkRoleAnnotDecl (comb3 happy_var_1 happy_var_3 happy_var_4) happy_var_3 (reverse (unLoc happy_var_4))) [mj AnnType happy_var_1,mj AnnRole happy_var_2])}}}}) ) (\r -> happyReturn (happyIn107 r)) happyReduce_240 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_240 = happySpecReduce_0 92# happyReduction_240 happyReduction_240 = happyIn108 (noLoc [] ) happyReduce_241 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_241 = happySpecReduce_1 92# happyReduction_241 happyReduction_241 happy_x_1 = case happyOut109 happy_x_1 of { (HappyWrap109 happy_var_1) -> happyIn108 (happy_var_1 )} happyReduce_242 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_242 = happySpecReduce_1 93# happyReduction_242 happyReduction_242 happy_x_1 = case happyOut110 happy_x_1 of { (HappyWrap110 happy_var_1) -> happyIn109 (sLL happy_var_1 happy_var_1 [happy_var_1] )} happyReduce_243 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_243 = happySpecReduce_2 93# happyReduction_243 happyReduction_243 happy_x_2 happy_x_1 = case happyOut109 happy_x_1 of { (HappyWrap109 happy_var_1) -> case happyOut110 happy_x_2 of { (HappyWrap110 happy_var_2) -> happyIn109 (sLL happy_var_1 happy_var_2 $ happy_var_2 : unLoc happy_var_1 )}} happyReduce_244 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_244 = happySpecReduce_1 94# happyReduction_244 happyReduction_244 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn110 (sL1 happy_var_1 $ Just $ getVARID happy_var_1 )} happyReduce_245 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_245 = happySpecReduce_1 94# happyReduction_245 happyReduction_245 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn110 (sL1 happy_var_1 Nothing )} happyReduce_246 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_246 = happyMonadReduce 4# 95# happyReduction_246 happyReduction_246 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut112 happy_x_2 of { (HappyWrap112 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut249 happy_x_4 of { (HappyWrap249 happy_var_4) -> ( let (name, args,as ) = happy_var_2 in ams (sLL happy_var_1 happy_var_4 . ValD noExtField $ mkPatSynBind name args happy_var_4 ImplicitBidirectional) (as ++ [mj AnnPattern happy_var_1, mj AnnEqual happy_var_3]))}}}}) ) (\r -> happyReturn (happyIn111 r)) happyReduce_247 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_247 = happyMonadReduce 4# 95# happyReduction_247 happyReduction_247 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut112 happy_x_2 of { (HappyWrap112 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut249 happy_x_4 of { (HappyWrap249 happy_var_4) -> ( let (name, args, as) = happy_var_2 in ams (sLL happy_var_1 happy_var_4 . ValD noExtField $ mkPatSynBind name args happy_var_4 Unidirectional) (as ++ [mj AnnPattern happy_var_1,mu AnnLarrow happy_var_3]))}}}}) ) (\r -> happyReturn (happyIn111 r)) happyReduce_248 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_248 = happyMonadReduce 5# 95# happyReduction_248 happyReduction_248 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut112 happy_x_2 of { (HappyWrap112 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut249 happy_x_4 of { (HappyWrap249 happy_var_4) -> case happyOut115 happy_x_5 of { (HappyWrap115 happy_var_5) -> ( do { let (name, args, as) = happy_var_2 ; mg <- mkPatSynMatchGroup name (snd $ unLoc happy_var_5) ; ams (sLL happy_var_1 happy_var_5 . ValD noExtField $ mkPatSynBind name args happy_var_4 (ExplicitBidirectional mg)) (as ++ ((mj AnnPattern happy_var_1:mu AnnLarrow happy_var_3:(fst $ unLoc happy_var_5))) ) })}}}}}) ) (\r -> happyReturn (happyIn111 r)) happyReduce_249 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_249 = happySpecReduce_2 96# happyReduction_249 happyReduction_249 happy_x_2 happy_x_1 = case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> case happyOut113 happy_x_2 of { (HappyWrap113 happy_var_2) -> happyIn112 ((happy_var_1, PrefixCon happy_var_2, []) )}} happyReduce_250 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_250 = happySpecReduce_3 96# happyReduction_250 happyReduction_250 happy_x_3 happy_x_2 happy_x_1 = case happyOut305 happy_x_1 of { (HappyWrap305 happy_var_1) -> case happyOut280 happy_x_2 of { (HappyWrap280 happy_var_2) -> case happyOut305 happy_x_3 of { (HappyWrap305 happy_var_3) -> happyIn112 ((happy_var_2, InfixCon happy_var_1 happy_var_3, []) )}}} happyReduce_251 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_251 = happyReduce 4# 96# happyReduction_251 happyReduction_251 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut114 happy_x_3 of { (HappyWrap114 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> happyIn112 ((happy_var_1, RecCon happy_var_3, [moc happy_var_2, mcc happy_var_4] ) ) `HappyStk` happyRest}}}} happyReduce_252 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_252 = happySpecReduce_0 97# happyReduction_252 happyReduction_252 = happyIn113 ([] ) happyReduce_253 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_253 = happySpecReduce_2 97# happyReduction_253 happyReduction_253 happy_x_2 happy_x_1 = case happyOut305 happy_x_1 of { (HappyWrap305 happy_var_1) -> case happyOut113 happy_x_2 of { (HappyWrap113 happy_var_2) -> happyIn113 (happy_var_1 : happy_var_2 )}} happyReduce_254 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_254 = happySpecReduce_1 98# happyReduction_254 happyReduction_254 happy_x_1 = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> happyIn114 ([RecordPatSynField happy_var_1 happy_var_1] )} happyReduce_255 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_255 = happyMonadReduce 3# 98# happyReduction_255 happyReduction_255 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut114 happy_x_3 of { (HappyWrap114 happy_var_3) -> ( addAnnotation (getLoc happy_var_1) AnnComma (getLoc happy_var_2) >> return ((RecordPatSynField happy_var_1 happy_var_1) : happy_var_3 ))}}}) ) (\r -> happyReturn (happyIn114 r)) happyReduce_256 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_256 = happyReduce 4# 99# happyReduction_256 happyReduction_256 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut125 happy_x_3 of { (HappyWrap125 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> happyIn115 (sLL happy_var_1 happy_var_4 ((mj AnnWhere happy_var_1:moc happy_var_2 :mcc happy_var_4:(fst $ unLoc happy_var_3)),sL1 happy_var_3 (snd $ unLoc happy_var_3)) ) `HappyStk` happyRest}}}} happyReduce_257 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_257 = happyReduce 4# 99# happyReduction_257 happyReduction_257 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut125 happy_x_3 of { (HappyWrap125 happy_var_3) -> happyIn115 (cL (comb2 happy_var_1 happy_var_3) ((mj AnnWhere happy_var_1:(fst $ unLoc happy_var_3)) ,sL1 happy_var_3 (snd $ unLoc happy_var_3)) ) `HappyStk` happyRest}} happyReduce_258 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_258 = happyMonadReduce 4# 100# happyReduction_258 happyReduction_258 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut277 happy_x_2 of { (HappyWrap277 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut150 happy_x_4 of { (HappyWrap150 happy_var_4) -> ( ams (sLL happy_var_1 happy_var_4 $ PatSynSig noExtField (unLoc happy_var_2) (mkLHsSigType happy_var_4)) [mj AnnPattern happy_var_1, mu AnnDcolon happy_var_3])}}}}) ) (\r -> happyReturn (happyIn116 r)) happyReduce_259 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_259 = happySpecReduce_1 101# happyReduction_259 happyReduction_259 happy_x_1 = case happyOut94 happy_x_1 of { (HappyWrap94 happy_var_1) -> happyIn117 (happy_var_1 )} happyReduce_260 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_260 = happySpecReduce_1 101# happyReduction_260 happyReduction_260 happy_x_1 = case happyOut201 happy_x_1 of { (HappyWrap201 happy_var_1) -> happyIn117 (happy_var_1 )} happyReduce_261 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_261 = happyMonadReduce 4# 101# happyReduction_261 happyReduction_261 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut210 happy_x_2 of { (HappyWrap210 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut150 happy_x_4 of { (HappyWrap150 happy_var_4) -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> do { v <- checkValSigLhs happy_var_2 ; let err = text "in default signature" <> colon <+> quotes (ppr happy_var_2) ; ams (sLL happy_var_1 happy_var_4 $ SigD noExtField $ ClassOpSig noExtField True [v] $ mkLHsSigType happy_var_4) [mj AnnDefault happy_var_1,mu AnnDcolon happy_var_3] })}}}}) ) (\r -> happyReturn (happyIn117 r)) happyReduce_262 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_262 = happyMonadReduce 3# 102# happyReduction_262 happyReduction_262 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut118 happy_x_1 of { (HappyWrap118 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut117 happy_x_3 of { (HappyWrap117 happy_var_3) -> ( if isNilOL (snd $ unLoc happy_var_1) then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) , unitOL happy_var_3)) else ams (lastOL (snd $ unLoc happy_var_1)) [mj AnnSemi happy_var_2] >> return (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1 ,(snd $ unLoc happy_var_1) `appOL` unitOL happy_var_3)))}}}) ) (\r -> happyReturn (happyIn118 r)) happyReduce_263 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_263 = happyMonadReduce 2# 102# happyReduction_263 happyReduction_263 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut118 happy_x_1 of { (HappyWrap118 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> ( if isNilOL (snd $ unLoc happy_var_1) then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) ,snd $ unLoc happy_var_1)) else ams (lastOL (snd $ unLoc happy_var_1)) [mj AnnSemi happy_var_2] >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))}}) ) (\r -> happyReturn (happyIn118 r)) happyReduce_264 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_264 = happySpecReduce_1 102# happyReduction_264 happyReduction_264 happy_x_1 = case happyOut117 happy_x_1 of { (HappyWrap117 happy_var_1) -> happyIn118 (sL1 happy_var_1 ([], unitOL happy_var_1) )} happyReduce_265 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_265 = happySpecReduce_0 102# happyReduction_265 happyReduction_265 = happyIn118 (noLoc ([],nilOL) ) happyReduce_266 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_266 = happySpecReduce_3 103# happyReduction_266 happyReduction_266 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut118 happy_x_2 of { (HappyWrap118 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn119 (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2) ,snd $ unLoc happy_var_2) )}}} happyReduce_267 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_267 = happySpecReduce_3 103# happyReduction_267 happyReduction_267 happy_x_3 happy_x_2 happy_x_1 = case happyOut118 happy_x_2 of { (HappyWrap118 happy_var_2) -> happyIn119 (happy_var_2 )} happyReduce_268 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_268 = happySpecReduce_2 104# happyReduction_268 happyReduction_268 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut119 happy_x_2 of { (HappyWrap119 happy_var_2) -> happyIn120 (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2) ,snd $ unLoc happy_var_2) )}} happyReduce_269 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_269 = happySpecReduce_0 104# happyReduction_269 happyReduction_269 = happyIn120 (noLoc ([],nilOL) ) happyReduce_270 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_270 = happySpecReduce_1 105# happyReduction_270 happyReduction_270 happy_x_1 = case happyOut97 happy_x_1 of { (HappyWrap97 happy_var_1) -> happyIn121 (sLL happy_var_1 happy_var_1 (unitOL (sL1 happy_var_1 (InstD noExtField (unLoc happy_var_1)))) )} happyReduce_271 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_271 = happySpecReduce_1 105# happyReduction_271 happyReduction_271 happy_x_1 = case happyOut201 happy_x_1 of { (HappyWrap201 happy_var_1) -> happyIn121 (sLL happy_var_1 happy_var_1 (unitOL happy_var_1) )} happyReduce_272 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_272 = happyMonadReduce 3# 106# happyReduction_272 happyReduction_272 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut122 happy_x_1 of { (HappyWrap122 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut121 happy_x_3 of { (HappyWrap121 happy_var_3) -> ( if isNilOL (snd $ unLoc happy_var_1) then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) , unLoc happy_var_3)) else ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] >> return (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1 ,(snd $ unLoc happy_var_1) `appOL` unLoc happy_var_3)))}}}) ) (\r -> happyReturn (happyIn122 r)) happyReduce_273 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_273 = happyMonadReduce 2# 106# happyReduction_273 happyReduction_273 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut122 happy_x_1 of { (HappyWrap122 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> ( if isNilOL (snd $ unLoc happy_var_1) then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) ,snd $ unLoc happy_var_1)) else ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))}}) ) (\r -> happyReturn (happyIn122 r)) happyReduce_274 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_274 = happySpecReduce_1 106# happyReduction_274 happyReduction_274 happy_x_1 = case happyOut121 happy_x_1 of { (HappyWrap121 happy_var_1) -> happyIn122 (sL1 happy_var_1 ([],unLoc happy_var_1) )} happyReduce_275 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_275 = happySpecReduce_0 106# happyReduction_275 happyReduction_275 = happyIn122 (noLoc ([],nilOL) ) happyReduce_276 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_276 = happySpecReduce_3 107# happyReduction_276 happyReduction_276 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut122 happy_x_2 of { (HappyWrap122 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn123 (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2),snd $ unLoc happy_var_2) )}}} happyReduce_277 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_277 = happySpecReduce_3 107# happyReduction_277 happyReduction_277 happy_x_3 happy_x_2 happy_x_1 = case happyOut122 happy_x_2 of { (HappyWrap122 happy_var_2) -> happyIn123 (cL (gl happy_var_2) (unLoc happy_var_2) )} happyReduce_278 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_278 = happySpecReduce_2 108# happyReduction_278 happyReduction_278 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut123 happy_x_2 of { (HappyWrap123 happy_var_2) -> happyIn124 (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2) ,(snd $ unLoc happy_var_2)) )}} happyReduce_279 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_279 = happySpecReduce_0 108# happyReduction_279 happyReduction_279 = happyIn124 (noLoc ([],nilOL) ) happyReduce_280 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_280 = happyMonadReduce 3# 109# happyReduction_280 happyReduction_280 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut125 happy_x_1 of { (HappyWrap125 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut201 happy_x_3 of { (HappyWrap201 happy_var_3) -> ( if isNilOL (snd $ unLoc happy_var_1) then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) , unitOL happy_var_3)) else do ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] >> return ( let { this = unitOL happy_var_3; rest = snd $ unLoc happy_var_1; these = rest `appOL` this } in rest `seq` this `seq` these `seq` (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1,these))))}}}) ) (\r -> happyReturn (happyIn125 r)) happyReduce_281 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_281 = happyMonadReduce 2# 109# happyReduction_281 happyReduction_281 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut125 happy_x_1 of { (HappyWrap125 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> ( if isNilOL (snd $ unLoc happy_var_1) then return (sLL happy_var_1 happy_var_2 ((mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) ,snd $ unLoc happy_var_1))) else ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))}}) ) (\r -> happyReturn (happyIn125 r)) happyReduce_282 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_282 = happySpecReduce_1 109# happyReduction_282 happyReduction_282 happy_x_1 = case happyOut201 happy_x_1 of { (HappyWrap201 happy_var_1) -> happyIn125 (sL1 happy_var_1 ([], unitOL happy_var_1) )} happyReduce_283 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_283 = happySpecReduce_0 109# happyReduction_283 happyReduction_283 = happyIn125 (noLoc ([],nilOL) ) happyReduce_284 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_284 = happySpecReduce_3 110# happyReduction_284 happyReduction_284 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut125 happy_x_2 of { (HappyWrap125 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn126 (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2) ,sL1 happy_var_2 $ snd $ unLoc happy_var_2) )}}} happyReduce_285 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_285 = happySpecReduce_3 110# happyReduction_285 happyReduction_285 happy_x_3 happy_x_2 happy_x_1 = case happyOut125 happy_x_2 of { (HappyWrap125 happy_var_2) -> happyIn126 (cL (gl happy_var_2) (fst $ unLoc happy_var_2,sL1 happy_var_2 $ snd $ unLoc happy_var_2) )} happyReduce_286 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_286 = happyMonadReduce 1# 111# happyReduction_286 happyReduction_286 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut126 happy_x_1 of { (HappyWrap126 happy_var_1) -> ( do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc happy_var_1) ; return (sL1 happy_var_1 (fst $ unLoc happy_var_1 ,sL1 happy_var_1 $ HsValBinds noExtField val_binds)) })}) ) (\r -> happyReturn (happyIn127 r)) happyReduce_287 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_287 = happySpecReduce_3 111# happyReduction_287 happyReduction_287 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut262 happy_x_2 of { (HappyWrap262 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn127 (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3] ,sL1 happy_var_2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc happy_var_2))) )}}} happyReduce_288 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_288 = happySpecReduce_3 111# happyReduction_288 happyReduction_288 happy_x_3 happy_x_2 happy_x_1 = case happyOut262 happy_x_2 of { (HappyWrap262 happy_var_2) -> happyIn127 (cL (getLoc happy_var_2) ([] ,sL1 happy_var_2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc happy_var_2))) )} happyReduce_289 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_289 = happySpecReduce_2 112# happyReduction_289 happyReduction_289 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut127 happy_x_2 of { (HappyWrap127 happy_var_2) -> happyIn128 (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1 : (fst $ unLoc happy_var_2) ,snd $ unLoc happy_var_2) )}} happyReduce_290 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_290 = happySpecReduce_0 112# happyReduction_290 happyReduction_290 = happyIn128 (noLoc ([],noLoc emptyLocalBinds) ) happyReduce_291 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_291 = happyMonadReduce 3# 113# happyReduction_291 happyReduction_291 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut129 happy_x_1 of { (HappyWrap129 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut130 happy_x_3 of { (HappyWrap130 happy_var_3) -> ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) >> return (happy_var_1 `snocOL` happy_var_3))}}}) ) (\r -> happyReturn (happyIn129 r)) happyReduce_292 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_292 = happyMonadReduce 2# 113# happyReduction_292 happyReduction_292 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut129 happy_x_1 of { (HappyWrap129 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) >> return happy_var_1)}}) ) (\r -> happyReturn (happyIn129 r)) happyReduce_293 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_293 = happySpecReduce_1 113# happyReduction_293 happyReduction_293 happy_x_1 = case happyOut130 happy_x_1 of { (HappyWrap130 happy_var_1) -> happyIn129 (unitOL happy_var_1 )} happyReduce_294 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_294 = happySpecReduce_0 113# happyReduction_294 happyReduction_294 = happyIn129 (nilOL ) happyReduce_295 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_295 = happyMonadReduce 6# 114# happyReduction_295 happyReduction_295 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut131 happy_x_2 of { (HappyWrap131 happy_var_2) -> case happyOut133 happy_x_3 of { (HappyWrap133 happy_var_3) -> case happyOut210 happy_x_4 of { (HappyWrap210 happy_var_4) -> case happyOutTok happy_x_5 of { happy_var_5 -> case happyOut209 happy_x_6 of { (HappyWrap209 happy_var_6) -> (runECP_P happy_var_4 >>= \ happy_var_4 -> runECP_P happy_var_6 >>= \ happy_var_6 -> ams (sLL happy_var_1 happy_var_6 $ HsRule { rd_ext = noExtField , rd_name = cL (gl happy_var_1) (getSTRINGs happy_var_1, getSTRING happy_var_1) , rd_act = (snd happy_var_2) `orElse` AlwaysActive , rd_tyvs = sndOf3 happy_var_3, rd_tmvs = thdOf3 happy_var_3 , rd_lhs = happy_var_4, rd_rhs = happy_var_6 }) (mj AnnEqual happy_var_5 : (fst happy_var_2) ++ (fstOf3 happy_var_3)))}}}}}}) ) (\r -> happyReturn (happyIn130 r)) happyReduce_296 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_296 = happySpecReduce_0 115# happyReduction_296 happyReduction_296 = happyIn131 (([],Nothing) ) happyReduce_297 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_297 = happySpecReduce_1 115# happyReduction_297 happyReduction_297 happy_x_1 = case happyOut132 happy_x_1 of { (HappyWrap132 happy_var_1) -> happyIn131 ((fst happy_var_1,Just (snd happy_var_1)) )} happyReduce_298 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_298 = happySpecReduce_3 116# happyReduction_298 happyReduction_298 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn132 (([mos happy_var_1,mj AnnVal happy_var_2,mcs happy_var_3] ,ActiveAfter (getINTEGERs happy_var_2) (fromInteger (il_value (getINTEGER happy_var_2)))) )}}} happyReduce_299 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_299 = happyReduce 4# 116# happyReduction_299 happyReduction_299 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> happyIn132 (([mos happy_var_1,mj AnnTilde happy_var_2,mj AnnVal happy_var_3,mcs happy_var_4] ,ActiveBefore (getINTEGERs happy_var_3) (fromInteger (il_value (getINTEGER happy_var_3)))) ) `HappyStk` happyRest}}}} happyReduce_300 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_300 = happySpecReduce_3 116# happyReduction_300 happyReduction_300 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn132 (([mos happy_var_1,mj AnnTilde happy_var_2,mcs happy_var_3] ,NeverActive) )}}} happyReduce_301 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_301 = happyMonadReduce 6# 117# happyReduction_301 happyReduction_301 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> case happyOut134 happy_x_5 of { (HappyWrap134 happy_var_5) -> case happyOutTok happy_x_6 of { happy_var_6 -> ( let tyvs = mkRuleTyVarBndrs happy_var_2 in hintExplicitForall happy_var_1 >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs happy_var_2) >> return ([mu AnnForall happy_var_1,mj AnnDot happy_var_3, mu AnnForall happy_var_4,mj AnnDot happy_var_6], Just (mkRuleTyVarBndrs happy_var_2), mkRuleBndrs happy_var_5))}}}}}}) ) (\r -> happyReturn (happyIn133 r)) happyReduce_302 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_302 = happySpecReduce_3 117# happyReduction_302 happyReduction_302 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn133 (([mu AnnForall happy_var_1,mj AnnDot happy_var_3], Nothing, mkRuleBndrs happy_var_2) )}}} happyReduce_303 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_303 = happySpecReduce_0 117# happyReduction_303 happyReduction_303 = happyIn133 (([], Nothing, []) ) happyReduce_304 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_304 = happySpecReduce_2 118# happyReduction_304 happyReduction_304 happy_x_2 happy_x_1 = case happyOut135 happy_x_1 of { (HappyWrap135 happy_var_1) -> case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> happyIn134 (happy_var_1 : happy_var_2 )}} happyReduce_305 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_305 = happySpecReduce_0 118# happyReduction_305 happyReduction_305 = happyIn134 ([] ) happyReduce_306 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_306 = happySpecReduce_1 119# happyReduction_306 happyReduction_306 happy_x_1 = case happyOut305 happy_x_1 of { (HappyWrap305 happy_var_1) -> happyIn135 (sLL happy_var_1 happy_var_1 (RuleTyTmVar happy_var_1 Nothing) )} happyReduce_307 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_307 = happyMonadReduce 5# 119# happyReduction_307 happyReduction_307 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut305 happy_x_2 of { (HappyWrap305 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut157 happy_x_4 of { (HappyWrap157 happy_var_4) -> case happyOutTok happy_x_5 of { happy_var_5 -> ( ams (sLL happy_var_1 happy_var_5 (RuleTyTmVar happy_var_2 (Just happy_var_4))) [mop happy_var_1,mu AnnDcolon happy_var_3,mcp happy_var_5])}}}}}) ) (\r -> happyReturn (happyIn135 r)) happyReduce_308 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_308 = happyMonadReduce 3# 120# happyReduction_308 happyReduction_308 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut136 happy_x_1 of { (HappyWrap136 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut137 happy_x_3 of { (HappyWrap137 happy_var_3) -> ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) >> return (happy_var_1 `appOL` happy_var_3))}}}) ) (\r -> happyReturn (happyIn136 r)) happyReduce_309 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_309 = happyMonadReduce 2# 120# happyReduction_309 happyReduction_309 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut136 happy_x_1 of { (HappyWrap136 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) >> return happy_var_1)}}) ) (\r -> happyReturn (happyIn136 r)) happyReduce_310 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_310 = happySpecReduce_1 120# happyReduction_310 happyReduction_310 happy_x_1 = case happyOut137 happy_x_1 of { (HappyWrap137 happy_var_1) -> happyIn136 (happy_var_1 )} happyReduce_311 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_311 = happySpecReduce_0 120# happyReduction_311 happyReduction_311 = happyIn136 (nilOL ) happyReduce_312 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_312 = happyMonadReduce 2# 121# happyReduction_312 happyReduction_312 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut271 happy_x_1 of { (HappyWrap271 happy_var_1) -> case happyOut140 happy_x_2 of { (HappyWrap140 happy_var_2) -> ( amsu (sLL happy_var_1 happy_var_2 (Warning noExtField (unLoc happy_var_1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc happy_var_2))) (fst $ unLoc happy_var_2))}}) ) (\r -> happyReturn (happyIn137 r)) happyReduce_313 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_313 = happyMonadReduce 3# 122# happyReduction_313 happyReduction_313 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut138 happy_x_1 of { (HappyWrap138 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut139 happy_x_3 of { (HappyWrap139 happy_var_3) -> ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) >> return (happy_var_1 `appOL` happy_var_3))}}}) ) (\r -> happyReturn (happyIn138 r)) happyReduce_314 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_314 = happyMonadReduce 2# 122# happyReduction_314 happyReduction_314 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut138 happy_x_1 of { (HappyWrap138 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> ( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) >> return happy_var_1)}}) ) (\r -> happyReturn (happyIn138 r)) happyReduce_315 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_315 = happySpecReduce_1 122# happyReduction_315 happyReduction_315 happy_x_1 = case happyOut139 happy_x_1 of { (HappyWrap139 happy_var_1) -> happyIn138 (happy_var_1 )} happyReduce_316 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_316 = happySpecReduce_0 122# happyReduction_316 happyReduction_316 = happyIn138 (nilOL ) happyReduce_317 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_317 = happyMonadReduce 2# 123# happyReduction_317 happyReduction_317 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut271 happy_x_1 of { (HappyWrap271 happy_var_1) -> case happyOut140 happy_x_2 of { (HappyWrap140 happy_var_2) -> ( amsu (sLL happy_var_1 happy_var_2 $ (Warning noExtField (unLoc happy_var_1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc happy_var_2))) (fst $ unLoc happy_var_2))}}) ) (\r -> happyReturn (happyIn139 r)) happyReduce_318 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_318 = happySpecReduce_1 124# happyReduction_318 happyReduction_318 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn140 (sL1 happy_var_1 ([],[cL (gl happy_var_1) (getStringLiteral happy_var_1)]) )} happyReduce_319 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_319 = happySpecReduce_3 124# happyReduction_319 happyReduction_319 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut141 happy_x_2 of { (HappyWrap141 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn140 (sLL happy_var_1 happy_var_3 $ ([mos happy_var_1,mcs happy_var_3],fromOL (unLoc happy_var_2)) )}}} happyReduce_320 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_320 = happyMonadReduce 3# 125# happyReduction_320 happyReduction_320 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut141 happy_x_1 of { (HappyWrap141 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> ( addAnnotation (oll $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> return (sLL happy_var_1 happy_var_3 (unLoc happy_var_1 `snocOL` (cL (gl happy_var_3) (getStringLiteral happy_var_3)))))}}}) ) (\r -> happyReturn (happyIn141 r)) happyReduce_321 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_321 = happySpecReduce_1 125# happyReduction_321 happyReduction_321 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn141 (sLL happy_var_1 happy_var_1 (unitOL (cL (gl happy_var_1) (getStringLiteral happy_var_1))) )} happyReduce_322 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_322 = happySpecReduce_0 125# happyReduction_322 happyReduction_322 = happyIn141 (noLoc nilOL ) happyReduce_323 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_323 = happyMonadReduce 4# 126# happyReduction_323 happyReduction_323 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut272 happy_x_2 of { (HappyWrap272 happy_var_2) -> case happyOut218 happy_x_3 of { (HappyWrap218 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> ( runECP_P happy_var_3 >>= \ happy_var_3 -> ams (sLL happy_var_1 happy_var_4 (AnnD noExtField $ HsAnnotation noExtField (getANN_PRAGs happy_var_1) (ValueAnnProvenance happy_var_2) happy_var_3)) [mo happy_var_1,mc happy_var_4])}}}}) ) (\r -> happyReturn (happyIn142 r)) happyReduce_324 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_324 = happyMonadReduce 5# 126# happyReduction_324 happyReduction_324 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut289 happy_x_3 of { (HappyWrap289 happy_var_3) -> case happyOut218 happy_x_4 of { (HappyWrap218 happy_var_4) -> case happyOutTok happy_x_5 of { happy_var_5 -> ( runECP_P happy_var_4 >>= \ happy_var_4 -> ams (sLL happy_var_1 happy_var_5 (AnnD noExtField $ HsAnnotation noExtField (getANN_PRAGs happy_var_1) (TypeAnnProvenance happy_var_3) happy_var_4)) [mo happy_var_1,mj AnnType happy_var_2,mc happy_var_5])}}}}}) ) (\r -> happyReturn (happyIn142 r)) happyReduce_325 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_325 = happyMonadReduce 4# 126# happyReduction_325 happyReduction_325 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut218 happy_x_3 of { (HappyWrap218 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> ( runECP_P happy_var_3 >>= \ happy_var_3 -> ams (sLL happy_var_1 happy_var_4 (AnnD noExtField $ HsAnnotation noExtField (getANN_PRAGs happy_var_1) ModuleAnnProvenance happy_var_3)) [mo happy_var_1,mj AnnModule happy_var_2,mc happy_var_4])}}}}) ) (\r -> happyReturn (happyIn142 r)) happyReduce_326 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_326 = happyMonadReduce 4# 127# happyReduction_326 happyReduction_326 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut144 happy_x_2 of { (HappyWrap144 happy_var_2) -> case happyOut145 happy_x_3 of { (HappyWrap145 happy_var_3) -> case happyOut146 happy_x_4 of { (HappyWrap146 happy_var_4) -> ( mkImport happy_var_2 happy_var_3 (snd $ unLoc happy_var_4) >>= \i -> return (sLL happy_var_1 happy_var_4 (mj AnnImport happy_var_1 : (fst $ unLoc happy_var_4),i)))}}}}) ) (\r -> happyReturn (happyIn143 r)) happyReduce_327 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_327 = happyMonadReduce 3# 127# happyReduction_327 happyReduction_327 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut144 happy_x_2 of { (HappyWrap144 happy_var_2) -> case happyOut146 happy_x_3 of { (HappyWrap146 happy_var_3) -> ( do { d <- mkImport happy_var_2 (noLoc PlaySafe) (snd $ unLoc happy_var_3); return (sLL happy_var_1 happy_var_3 (mj AnnImport happy_var_1 : (fst $ unLoc happy_var_3),d)) })}}}) ) (\r -> happyReturn (happyIn143 r)) happyReduce_328 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_328 = happyMonadReduce 3# 127# happyReduction_328 happyReduction_328 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut144 happy_x_2 of { (HappyWrap144 happy_var_2) -> case happyOut146 happy_x_3 of { (HappyWrap146 happy_var_3) -> ( mkExport happy_var_2 (snd $ unLoc happy_var_3) >>= \i -> return (sLL happy_var_1 happy_var_3 (mj AnnExport happy_var_1 : (fst $ unLoc happy_var_3),i) ))}}}) ) (\r -> happyReturn (happyIn143 r)) happyReduce_329 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_329 = happySpecReduce_1 128# happyReduction_329 happyReduction_329 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn144 (sLL happy_var_1 happy_var_1 StdCallConv )} happyReduce_330 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_330 = happySpecReduce_1 128# happyReduction_330 happyReduction_330 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn144 (sLL happy_var_1 happy_var_1 CCallConv )} happyReduce_331 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_331 = happySpecReduce_1 128# happyReduction_331 happyReduction_331 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn144 (sLL happy_var_1 happy_var_1 CApiConv )} happyReduce_332 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_332 = happySpecReduce_1 128# happyReduction_332 happyReduction_332 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn144 (sLL happy_var_1 happy_var_1 PrimCallConv )} happyReduce_333 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_333 = happySpecReduce_1 128# happyReduction_333 happyReduction_333 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn144 (sLL happy_var_1 happy_var_1 JavaScriptCallConv )} happyReduce_334 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_334 = happySpecReduce_1 129# happyReduction_334 happyReduction_334 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn145 (sLL happy_var_1 happy_var_1 PlayRisky )} happyReduce_335 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_335 = happySpecReduce_1 129# happyReduction_335 happyReduction_335 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn145 (sLL happy_var_1 happy_var_1 PlaySafe )} happyReduce_336 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_336 = happySpecReduce_1 129# happyReduction_336 happyReduction_336 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn145 (sLL happy_var_1 happy_var_1 PlayInterruptible )} happyReduce_337 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_337 = happyReduce 4# 130# happyReduction_337 happyReduction_337 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut302 happy_x_2 of { (HappyWrap302 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut150 happy_x_4 of { (HappyWrap150 happy_var_4) -> happyIn146 (sLL happy_var_1 happy_var_4 ([mu AnnDcolon happy_var_3] ,(cL (getLoc happy_var_1) (getStringLiteral happy_var_1), happy_var_2, mkLHsSigType happy_var_4)) ) `HappyStk` happyRest}}}} happyReduce_338 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_338 = happySpecReduce_3 130# happyReduction_338 happyReduction_338 happy_x_3 happy_x_2 happy_x_1 = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut150 happy_x_3 of { (HappyWrap150 happy_var_3) -> happyIn146 (sLL happy_var_1 happy_var_3 ([mu AnnDcolon happy_var_2] ,(noLoc (StringLiteral NoSourceText nilFS), happy_var_1, mkLHsSigType happy_var_3)) )}}} happyReduce_339 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_339 = happySpecReduce_0 131# happyReduction_339 happyReduction_339 = happyIn147 (([],Nothing) ) happyReduce_340 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_340 = happySpecReduce_2 131# happyReduction_340 happyReduction_340 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut149 happy_x_2 of { (HappyWrap149 happy_var_2) -> happyIn147 (([mu AnnDcolon happy_var_1],Just happy_var_2) )}} happyReduce_341 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_341 = happySpecReduce_0 132# happyReduction_341 happyReduction_341 = happyIn148 (([], Nothing) ) happyReduce_342 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_342 = happySpecReduce_2 132# happyReduction_342 happyReduction_342 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut282 happy_x_2 of { (HappyWrap282 happy_var_2) -> happyIn148 (([mu AnnDcolon happy_var_1], Just happy_var_2) )}} happyReduce_343 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_343 = happySpecReduce_1 133# happyReduction_343 happyReduction_343 happy_x_1 = case happyOut157 happy_x_1 of { (HappyWrap157 happy_var_1) -> happyIn149 (happy_var_1 )} happyReduce_344 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_344 = happySpecReduce_1 134# happyReduction_344 happyReduction_344 happy_x_1 = case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> happyIn150 (happy_var_1 )} happyReduce_345 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_345 = happyMonadReduce 3# 135# happyReduction_345 happyReduction_345 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut151 happy_x_1 of { (HappyWrap151 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut302 happy_x_3 of { (HappyWrap302 happy_var_3) -> ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))}}}) ) (\r -> happyReturn (happyIn151 r)) happyReduce_346 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_346 = happySpecReduce_1 135# happyReduction_346 happyReduction_346 happy_x_1 = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> happyIn151 (sL1 happy_var_1 [happy_var_1] )} happyReduce_347 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_347 = happySpecReduce_1 136# happyReduction_347 happyReduction_347 happy_x_1 = case happyOut149 happy_x_1 of { (HappyWrap149 happy_var_1) -> happyIn152 (unitOL (mkLHsSigType happy_var_1) )} happyReduce_348 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_348 = happyMonadReduce 3# 136# happyReduction_348 happyReduction_348 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut149 happy_x_1 of { (HappyWrap149 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut152 happy_x_3 of { (HappyWrap152 happy_var_3) -> ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> return (unitOL (mkLHsSigType happy_var_1) `appOL` happy_var_3))}}}) ) (\r -> happyReturn (happyIn152 r)) happyReduce_349 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_349 = happySpecReduce_2 137# happyReduction_349 happyReduction_349 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> happyIn153 (sLL happy_var_1 happy_var_2 ([mo happy_var_1, mc happy_var_2], getUNPACK_PRAGs happy_var_1, SrcUnpack) )}} happyReduce_350 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_350 = happySpecReduce_2 137# happyReduction_350 happyReduction_350 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> happyIn153 (sLL happy_var_1 happy_var_2 ([mo happy_var_1, mc happy_var_2], getNOUNPACK_PRAGs happy_var_1, SrcNoUnpack) )}} happyReduce_351 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_351 = happySpecReduce_1 138# happyReduction_351 happyReduction_351 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn154 ((mj AnnDot happy_var_1, ForallInvis) )} happyReduce_352 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_352 = happySpecReduce_1 138# happyReduction_352 happyReduction_352 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn154 ((mu AnnRarrow happy_var_1, ForallVis) )} happyReduce_353 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_353 = happySpecReduce_1 139# happyReduction_353 happyReduction_353 happy_x_1 = case happyOut157 happy_x_1 of { (HappyWrap157 happy_var_1) -> happyIn155 (happy_var_1 )} happyReduce_354 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_354 = happyMonadReduce 3# 139# happyReduction_354 happyReduction_354 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut157 happy_x_1 of { (HappyWrap157 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut181 happy_x_3 of { (HappyWrap181 happy_var_3) -> ( ams (sLL happy_var_1 happy_var_3 $ HsKindSig noExtField happy_var_1 happy_var_3) [mu AnnDcolon happy_var_2])}}}) ) (\r -> happyReturn (happyIn155 r)) happyReduce_355 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_355 = happySpecReduce_1 140# happyReduction_355 happyReduction_355 happy_x_1 = case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> happyIn156 (happy_var_1 )} happyReduce_356 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_356 = happyMonadReduce 3# 140# happyReduction_356 happyReduction_356 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut181 happy_x_3 of { (HappyWrap181 happy_var_3) -> ( ams (sLL happy_var_1 happy_var_3 $ HsKindSig noExtField happy_var_1 happy_var_3) [mu AnnDcolon happy_var_2])}}}) ) (\r -> happyReturn (happyIn156 r)) happyReduce_357 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_357 = happyMonadReduce 4# 141# happyReduction_357 happyReduction_357 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut175 happy_x_2 of { (HappyWrap175 happy_var_2) -> case happyOut154 happy_x_3 of { (HappyWrap154 happy_var_3) -> case happyOut157 happy_x_4 of { (HappyWrap157 happy_var_4) -> ( let (fv_ann, fv_flag) = happy_var_3 in hintExplicitForall happy_var_1 *> ams (sLL happy_var_1 happy_var_4 $ HsForAllTy { hst_fvf = fv_flag , hst_bndrs = happy_var_2 , hst_xforall = noExtField , hst_body = happy_var_4 }) [mu AnnForall happy_var_1,fv_ann])}}}}) ) (\r -> happyReturn (happyIn157 r)) happyReduce_358 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_358 = happyMonadReduce 3# 141# happyReduction_358 happyReduction_358 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut157 happy_x_3 of { (HappyWrap157 happy_var_3) -> ( addAnnotation (gl happy_var_1) (toUnicodeAnn AnnDarrow happy_var_2) (gl happy_var_2) >> return (sLL happy_var_1 happy_var_3 $ HsQualTy { hst_ctxt = happy_var_1 , hst_xqual = noExtField , hst_body = happy_var_3 }))}}}) ) (\r -> happyReturn (happyIn157 r)) happyReduce_359 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_359 = happyMonadReduce 3# 141# happyReduction_359 happyReduction_359 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut264 happy_x_1 of { (HappyWrap264 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> ( ams (sLL happy_var_1 happy_var_3 (HsIParamTy noExtField happy_var_1 happy_var_3)) [mu AnnDcolon happy_var_2])}}}) ) (\r -> happyReturn (happyIn157 r)) happyReduce_360 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_360 = happySpecReduce_1 141# happyReduction_360 happyReduction_360 happy_x_1 = case happyOut161 happy_x_1 of { (HappyWrap161 happy_var_1) -> happyIn157 (happy_var_1 )} happyReduce_361 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_361 = happyMonadReduce 4# 142# happyReduction_361 happyReduction_361 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut175 happy_x_2 of { (HappyWrap175 happy_var_2) -> case happyOut154 happy_x_3 of { (HappyWrap154 happy_var_3) -> case happyOut158 happy_x_4 of { (HappyWrap158 happy_var_4) -> ( let (fv_ann, fv_flag) = happy_var_3 in hintExplicitForall happy_var_1 *> ams (sLL happy_var_1 happy_var_4 $ HsForAllTy { hst_fvf = fv_flag , hst_bndrs = happy_var_2 , hst_xforall = noExtField , hst_body = happy_var_4 }) [mu AnnForall happy_var_1,fv_ann])}}}}) ) (\r -> happyReturn (happyIn158 r)) happyReduce_362 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_362 = happyMonadReduce 3# 142# happyReduction_362 happyReduction_362 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut158 happy_x_3 of { (HappyWrap158 happy_var_3) -> ( addAnnotation (gl happy_var_1) (toUnicodeAnn AnnDarrow happy_var_2) (gl happy_var_2) >> return (sLL happy_var_1 happy_var_3 $ HsQualTy { hst_ctxt = happy_var_1 , hst_xqual = noExtField , hst_body = happy_var_3 }))}}}) ) (\r -> happyReturn (happyIn158 r)) happyReduce_363 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_363 = happyMonadReduce 3# 142# happyReduction_363 happyReduction_363 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut264 happy_x_1 of { (HappyWrap264 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> ( ams (sLL happy_var_1 happy_var_3 (HsIParamTy noExtField happy_var_1 happy_var_3)) [mu AnnDcolon happy_var_2])}}}) ) (\r -> happyReturn (happyIn158 r)) happyReduce_364 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_364 = happySpecReduce_1 142# happyReduction_364 happyReduction_364 happy_x_1 = case happyOut162 happy_x_1 of { (HappyWrap162 happy_var_1) -> happyIn158 (happy_var_1 )} happyReduce_365 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_365 = happyMonadReduce 1# 143# happyReduction_365 happyReduction_365 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> ( do { (anns,ctx) <- checkContext happy_var_1 ; if null (unLoc ctx) then addAnnotation (gl happy_var_1) AnnUnit (gl happy_var_1) else return () ; ams ctx anns })}) ) (\r -> happyReturn (happyIn159 r)) happyReduce_366 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_366 = happyMonadReduce 1# 144# happyReduction_366 happyReduction_366 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> ( do { (anns,ctx) <- checkContext happy_var_1 ; if null (unLoc ctx) then addAnnotation (gl happy_var_1) AnnUnit (gl happy_var_1) else return () ; ams ctx anns })}) ) (\r -> happyReturn (happyIn160 r)) happyReduce_367 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_367 = happySpecReduce_1 145# happyReduction_367 happyReduction_367 happy_x_1 = case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> happyIn161 (happy_var_1 )} happyReduce_368 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_368 = happyMonadReduce 3# 145# happyReduction_368 happyReduction_368 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut157 happy_x_3 of { (HappyWrap157 happy_var_3) -> ( ams happy_var_1 [mu AnnRarrow happy_var_2] -- See note [GADT decl discards annotations] >> ams (sLL happy_var_1 happy_var_3 $ HsFunTy noExtField happy_var_1 happy_var_3) [mu AnnRarrow happy_var_2])}}}) ) (\r -> happyReturn (happyIn161 r)) happyReduce_369 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_369 = happySpecReduce_1 146# happyReduction_369 happyReduction_369 happy_x_1 = case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> happyIn162 (happy_var_1 )} happyReduce_370 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_370 = happySpecReduce_2 146# happyReduction_370 happyReduction_370 happy_x_2 happy_x_1 = case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> case happyOut324 happy_x_2 of { (HappyWrap324 happy_var_2) -> happyIn162 (sLL happy_var_1 happy_var_2 $ HsDocTy noExtField happy_var_1 happy_var_2 )}} happyReduce_371 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_371 = happySpecReduce_2 146# happyReduction_371 happyReduction_371 happy_x_2 happy_x_1 = case happyOut323 happy_x_1 of { (HappyWrap323 happy_var_1) -> case happyOut166 happy_x_2 of { (HappyWrap166 happy_var_2) -> happyIn162 (sLL happy_var_1 happy_var_2 $ HsDocTy noExtField happy_var_2 happy_var_1 )}} happyReduce_372 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_372 = happyMonadReduce 3# 146# happyReduction_372 happyReduction_372 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut158 happy_x_3 of { (HappyWrap158 happy_var_3) -> ( ams happy_var_1 [mu AnnRarrow happy_var_2] -- See note [GADT decl discards annotations] >> ams (sLL happy_var_1 happy_var_3 $ HsFunTy noExtField happy_var_1 happy_var_3) [mu AnnRarrow happy_var_2])}}}) ) (\r -> happyReturn (happyIn162 r)) happyReduce_373 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_373 = happyMonadReduce 4# 146# happyReduction_373 happyReduction_373 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> case happyOut324 happy_x_2 of { (HappyWrap324 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut158 happy_x_4 of { (HappyWrap158 happy_var_4) -> ( ams happy_var_1 [mu AnnRarrow happy_var_3] -- See note [GADT decl discards annotations] >> ams (sLL happy_var_1 happy_var_4 $ HsFunTy noExtField (cL (comb2 happy_var_1 happy_var_2) (HsDocTy noExtField happy_var_1 happy_var_2)) happy_var_4) [mu AnnRarrow happy_var_3])}}}}) ) (\r -> happyReturn (happyIn162 r)) happyReduce_374 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_374 = happyMonadReduce 4# 146# happyReduction_374 happyReduction_374 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut323 happy_x_1 of { (HappyWrap323 happy_var_1) -> case happyOut166 happy_x_2 of { (HappyWrap166 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut158 happy_x_4 of { (HappyWrap158 happy_var_4) -> ( ams happy_var_2 [mu AnnRarrow happy_var_3] -- See note [GADT decl discards annotations] >> ams (sLL happy_var_1 happy_var_4 $ HsFunTy noExtField (cL (comb2 happy_var_1 happy_var_2) (HsDocTy noExtField happy_var_2 happy_var_1)) happy_var_4) [mu AnnRarrow happy_var_3])}}}}) ) (\r -> happyReturn (happyIn162 r)) happyReduce_375 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_375 = happyMonadReduce 1# 147# happyReduction_375 happyReduction_375 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> ( mergeOps (unLoc happy_var_1))}) ) (\r -> happyReturn (happyIn163 r)) happyReduce_376 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_376 = happySpecReduce_1 148# happyReduction_376 happyReduction_376 happy_x_1 = case happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> happyIn164 (sL1 happy_var_1 [happy_var_1] )} happyReduce_377 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_377 = happySpecReduce_2 148# happyReduction_377 happyReduction_377 happy_x_2 happy_x_1 = case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> case happyOut165 happy_x_2 of { (HappyWrap165 happy_var_2) -> happyIn164 (sLL happy_var_1 happy_var_2 $ happy_var_2 : (unLoc happy_var_1) )}} happyReduce_378 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_378 = happySpecReduce_1 149# happyReduction_378 happyReduction_378 happy_x_1 = case happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> happyIn165 (happy_var_1 )} happyReduce_379 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_379 = happySpecReduce_1 149# happyReduction_379 happyReduction_379 happy_x_1 = case happyOut324 happy_x_1 of { (HappyWrap324 happy_var_1) -> happyIn165 (sL1 happy_var_1 $ TyElDocPrev (unLoc happy_var_1) )} happyReduce_380 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_380 = happyMonadReduce 1# 150# happyReduction_380 happyReduction_380 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut167 happy_x_1 of { (HappyWrap167 happy_var_1) -> ( mergeOps happy_var_1)}) ) (\r -> happyReturn (happyIn166 r)) happyReduce_381 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_381 = happySpecReduce_1 151# happyReduction_381 happyReduction_381 happy_x_1 = case happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> happyIn167 ([happy_var_1] )} happyReduce_382 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_382 = happySpecReduce_2 151# happyReduction_382 happyReduction_382 happy_x_2 happy_x_1 = case happyOut167 happy_x_1 of { (HappyWrap167 happy_var_1) -> case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> happyIn167 (happy_var_2 : happy_var_1 )}} happyReduce_383 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_383 = happySpecReduce_1 152# happyReduction_383 happyReduction_383 happy_x_1 = case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> happyIn168 (sL1 happy_var_1 $ TyElOpd (unLoc happy_var_1) )} happyReduce_384 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_384 = happySpecReduce_2 152# happyReduction_384 happyReduction_384 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut169 happy_x_2 of { (HappyWrap169 happy_var_2) -> happyIn168 (sLL happy_var_1 happy_var_2 $ (TyElKindApp (comb2 happy_var_1 happy_var_2) happy_var_2) )}} happyReduce_385 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_385 = happySpecReduce_1 152# happyReduction_385 happyReduction_385 happy_x_1 = case happyOut286 happy_x_1 of { (HappyWrap286 happy_var_1) -> happyIn168 (sL1 happy_var_1 $ if isBangRdr (unLoc happy_var_1) then TyElBang else if isTildeRdr (unLoc happy_var_1) then TyElTilde else TyElOpr (unLoc happy_var_1) )} happyReduce_386 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_386 = happySpecReduce_1 152# happyReduction_386 happyReduction_386 happy_x_1 = case happyOut300 happy_x_1 of { (HappyWrap300 happy_var_1) -> happyIn168 (sL1 happy_var_1 $ TyElOpr (unLoc happy_var_1) )} happyReduce_387 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_387 = happyMonadReduce 2# 152# happyReduction_387 happyReduction_387 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut281 happy_x_2 of { (HappyWrap281 happy_var_2) -> ( ams (sLL happy_var_1 happy_var_2 $ TyElOpr (unLoc happy_var_2)) [mj AnnSimpleQuote happy_var_1,mj AnnVal happy_var_2])}}) ) (\r -> happyReturn (happyIn168 r)) happyReduce_388 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_388 = happyMonadReduce 2# 152# happyReduction_388 happyReduction_388 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut293 happy_x_2 of { (HappyWrap293 happy_var_2) -> ( ams (sLL happy_var_1 happy_var_2 $ TyElOpr (unLoc happy_var_2)) [mj AnnSimpleQuote happy_var_1,mj AnnVal happy_var_2])}}) ) (\r -> happyReturn (happyIn168 r)) happyReduce_389 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_389 = happySpecReduce_1 152# happyReduction_389 happyReduction_389 happy_x_1 = case happyOut153 happy_x_1 of { (HappyWrap153 happy_var_1) -> happyIn168 (sL1 happy_var_1 $ TyElUnpackedness (unLoc happy_var_1) )} happyReduce_390 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_390 = happySpecReduce_1 153# happyReduction_390 happyReduction_390 happy_x_1 = case happyOut283 happy_x_1 of { (HappyWrap283 happy_var_1) -> happyIn169 (sL1 happy_var_1 (HsTyVar noExtField NotPromoted happy_var_1) )} happyReduce_391 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_391 = happySpecReduce_1 153# happyReduction_391 happyReduction_391 happy_x_1 = case happyOut299 happy_x_1 of { (HappyWrap299 happy_var_1) -> happyIn169 (sL1 happy_var_1 (HsTyVar noExtField NotPromoted happy_var_1) )} happyReduce_392 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_392 = happyMonadReduce 1# 153# happyReduction_392 happyReduction_392 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( do { warnStarIsType (getLoc happy_var_1) ; return $ sL1 happy_var_1 (HsStarTy noExtField (isUnicode happy_var_1)) })}) ) (\r -> happyReturn (happyIn169 r)) happyReduce_393 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_393 = happyMonadReduce 3# 153# happyReduction_393 happyReduction_393 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut191 happy_x_2 of { (HappyWrap191 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( amms (checkRecordSyntax (sLL happy_var_1 happy_var_3 $ HsRecTy noExtField happy_var_2)) -- Constructor sigs only [moc happy_var_1,mcc happy_var_3])}}}) ) (\r -> happyReturn (happyIn169 r)) happyReduce_394 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_394 = happyMonadReduce 2# 153# happyReduction_394 happyReduction_394 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> ( ams (sLL happy_var_1 happy_var_2 $ HsTupleTy noExtField HsBoxedOrConstraintTuple []) [mop happy_var_1,mcp happy_var_2])}}) ) (\r -> happyReturn (happyIn169 r)) happyReduce_395 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_395 = happyMonadReduce 5# 153# happyReduction_395 happyReduction_395 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut155 happy_x_2 of { (HappyWrap155 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut173 happy_x_4 of { (HappyWrap173 happy_var_4) -> case happyOutTok happy_x_5 of { happy_var_5 -> ( addAnnotation (gl happy_var_2) AnnComma (gl happy_var_3) >> ams (sLL happy_var_1 happy_var_5 $ HsTupleTy noExtField HsBoxedOrConstraintTuple (happy_var_2 : happy_var_4)) [mop happy_var_1,mcp happy_var_5])}}}}}) ) (\r -> happyReturn (happyIn169 r)) happyReduce_396 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_396 = happyMonadReduce 2# 153# happyReduction_396 happyReduction_396 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> ( ams (sLL happy_var_1 happy_var_2 $ HsTupleTy noExtField HsUnboxedTuple []) [mo happy_var_1,mc happy_var_2])}}) ) (\r -> happyReturn (happyIn169 r)) happyReduce_397 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_397 = happyMonadReduce 3# 153# happyReduction_397 happyReduction_397 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut173 happy_x_2 of { (HappyWrap173 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ HsTupleTy noExtField HsUnboxedTuple happy_var_2) [mo happy_var_1,mc happy_var_3])}}}) ) (\r -> happyReturn (happyIn169 r)) happyReduce_398 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_398 = happyMonadReduce 3# 153# happyReduction_398 happyReduction_398 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ HsSumTy noExtField happy_var_2) [mo happy_var_1,mc happy_var_3])}}}) ) (\r -> happyReturn (happyIn169 r)) happyReduce_399 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_399 = happyMonadReduce 3# 153# happyReduction_399 happyReduction_399 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut155 happy_x_2 of { (HappyWrap155 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ HsListTy noExtField happy_var_2) [mos happy_var_1,mcs happy_var_3])}}}) ) (\r -> happyReturn (happyIn169 r)) happyReduce_400 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_400 = happyMonadReduce 3# 153# happyReduction_400 happyReduction_400 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut155 happy_x_2 of { (HappyWrap155 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ HsParTy noExtField happy_var_2) [mop happy_var_1,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn169 r)) happyReduce_401 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_401 = happySpecReduce_1 153# happyReduction_401 happyReduction_401 happy_x_1 = case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> happyIn169 (mapLoc (HsSpliceTy noExtField) happy_var_1 )} happyReduce_402 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_402 = happySpecReduce_1 153# happyReduction_402 happyReduction_402 happy_x_1 = case happyOut222 happy_x_1 of { (HappyWrap222 happy_var_1) -> happyIn169 (mapLoc (HsSpliceTy noExtField) happy_var_1 )} happyReduce_403 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_403 = happyMonadReduce 2# 153# happyReduction_403 happyReduction_403 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut273 happy_x_2 of { (HappyWrap273 happy_var_2) -> ( ams (sLL happy_var_1 happy_var_2 $ HsTyVar noExtField IsPromoted happy_var_2) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}}) ) (\r -> happyReturn (happyIn169 r)) happyReduce_404 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_404 = happyMonadReduce 6# 153# happyReduction_404 happyReduction_404 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut155 happy_x_3 of { (HappyWrap155 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> case happyOut173 happy_x_5 of { (HappyWrap173 happy_var_5) -> case happyOutTok happy_x_6 of { happy_var_6 -> ( addAnnotation (gl happy_var_3) AnnComma (gl happy_var_4) >> ams (sLL happy_var_1 happy_var_6 $ HsExplicitTupleTy noExtField (happy_var_3 : happy_var_5)) [mj AnnSimpleQuote happy_var_1,mop happy_var_2,mcp happy_var_6])}}}}}}) ) (\r -> happyReturn (happyIn169 r)) happyReduce_405 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_405 = happyMonadReduce 4# 153# happyReduction_405 happyReduction_405 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> ( ams (sLL happy_var_1 happy_var_4 $ HsExplicitListTy noExtField IsPromoted happy_var_3) [mj AnnSimpleQuote happy_var_1,mos happy_var_2,mcs happy_var_4])}}}}) ) (\r -> happyReturn (happyIn169 r)) happyReduce_406 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_406 = happyMonadReduce 2# 153# happyReduction_406 happyReduction_406 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut302 happy_x_2 of { (HappyWrap302 happy_var_2) -> ( ams (sLL happy_var_1 happy_var_2 $ HsTyVar noExtField IsPromoted happy_var_2) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}}) ) (\r -> happyReturn (happyIn169 r)) happyReduce_407 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_407 = happyMonadReduce 5# 153# happyReduction_407 happyReduction_407 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut155 happy_x_2 of { (HappyWrap155 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut173 happy_x_4 of { (HappyWrap173 happy_var_4) -> case happyOutTok happy_x_5 of { happy_var_5 -> ( addAnnotation (gl happy_var_2) AnnComma (gl happy_var_3) >> ams (sLL happy_var_1 happy_var_5 $ HsExplicitListTy noExtField NotPromoted (happy_var_2 : happy_var_4)) [mos happy_var_1,mcs happy_var_5])}}}}}) ) (\r -> happyReturn (happyIn169 r)) happyReduce_408 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_408 = happySpecReduce_1 153# happyReduction_408 happyReduction_408 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn169 (sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsNumTy (getINTEGERs happy_var_1) (il_value (getINTEGER happy_var_1)) )} happyReduce_409 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_409 = happySpecReduce_1 153# happyReduction_409 happyReduction_409 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn169 (sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsStrTy (getSTRINGs happy_var_1) (getSTRING happy_var_1) )} happyReduce_410 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_410 = happySpecReduce_1 153# happyReduction_410 happyReduction_410 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn169 (sL1 happy_var_1 $ mkAnonWildCardTy )} happyReduce_411 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_411 = happySpecReduce_1 154# happyReduction_411 happyReduction_411 happy_x_1 = case happyOut149 happy_x_1 of { (HappyWrap149 happy_var_1) -> happyIn170 (mkLHsSigType happy_var_1 )} happyReduce_412 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_412 = happySpecReduce_1 155# happyReduction_412 happyReduction_412 happy_x_1 = case happyOut156 happy_x_1 of { (HappyWrap156 happy_var_1) -> happyIn171 ([mkLHsSigType happy_var_1] )} happyReduce_413 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_413 = happyMonadReduce 3# 155# happyReduction_413 happyReduction_413 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut156 happy_x_1 of { (HappyWrap156 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut171 happy_x_3 of { (HappyWrap171 happy_var_3) -> ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> return (mkLHsSigType happy_var_1 : happy_var_3))}}}) ) (\r -> happyReturn (happyIn171 r)) happyReduce_414 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_414 = happySpecReduce_1 156# happyReduction_414 happyReduction_414 happy_x_1 = case happyOut173 happy_x_1 of { (HappyWrap173 happy_var_1) -> happyIn172 (happy_var_1 )} happyReduce_415 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_415 = happySpecReduce_0 156# happyReduction_415 happyReduction_415 = happyIn172 ([] ) happyReduce_416 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_416 = happySpecReduce_1 157# happyReduction_416 happyReduction_416 happy_x_1 = case happyOut155 happy_x_1 of { (HappyWrap155 happy_var_1) -> happyIn173 ([happy_var_1] )} happyReduce_417 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_417 = happyMonadReduce 3# 157# happyReduction_417 happyReduction_417 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut155 happy_x_1 of { (HappyWrap155 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut173 happy_x_3 of { (HappyWrap173 happy_var_3) -> ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> return (happy_var_1 : happy_var_3))}}}) ) (\r -> happyReturn (happyIn173 r)) happyReduce_418 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_418 = happyMonadReduce 3# 158# happyReduction_418 happyReduction_418 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut155 happy_x_1 of { (HappyWrap155 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut155 happy_x_3 of { (HappyWrap155 happy_var_3) -> ( addAnnotation (gl happy_var_1) AnnVbar (gl happy_var_2) >> return [happy_var_1,happy_var_3])}}}) ) (\r -> happyReturn (happyIn174 r)) happyReduce_419 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_419 = happyMonadReduce 3# 158# happyReduction_419 happyReduction_419 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut155 happy_x_1 of { (HappyWrap155 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut174 happy_x_3 of { (HappyWrap174 happy_var_3) -> ( addAnnotation (gl happy_var_1) AnnVbar (gl happy_var_2) >> return (happy_var_1 : happy_var_3))}}}) ) (\r -> happyReturn (happyIn174 r)) happyReduce_420 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_420 = happySpecReduce_2 159# happyReduction_420 happyReduction_420 happy_x_2 happy_x_1 = case happyOut176 happy_x_1 of { (HappyWrap176 happy_var_1) -> case happyOut175 happy_x_2 of { (HappyWrap175 happy_var_2) -> happyIn175 (happy_var_1 : happy_var_2 )}} happyReduce_421 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_421 = happySpecReduce_0 159# happyReduction_421 happyReduction_421 = happyIn175 ([] ) happyReduce_422 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_422 = happySpecReduce_1 160# happyReduction_422 happyReduction_422 happy_x_1 = case happyOut299 happy_x_1 of { (HappyWrap299 happy_var_1) -> happyIn176 (sL1 happy_var_1 (UserTyVar noExtField happy_var_1) )} happyReduce_423 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_423 = happyMonadReduce 5# 160# happyReduction_423 happyReduction_423 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut299 happy_x_2 of { (HappyWrap299 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut181 happy_x_4 of { (HappyWrap181 happy_var_4) -> case happyOutTok happy_x_5 of { happy_var_5 -> ( ams (sLL happy_var_1 happy_var_5 (KindedTyVar noExtField happy_var_2 happy_var_4)) [mop happy_var_1,mu AnnDcolon happy_var_3 ,mcp happy_var_5])}}}}}) ) (\r -> happyReturn (happyIn176 r)) happyReduce_424 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_424 = happySpecReduce_0 161# happyReduction_424 happyReduction_424 = happyIn177 (noLoc ([],[]) ) happyReduce_425 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_425 = happySpecReduce_2 161# happyReduction_425 happyReduction_425 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut178 happy_x_2 of { (HappyWrap178 happy_var_2) -> happyIn177 ((sLL happy_var_1 happy_var_2 ([mj AnnVbar happy_var_1] ,reverse (unLoc happy_var_2))) )}} happyReduce_426 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_426 = happyMonadReduce 3# 162# happyReduction_426 happyReduction_426 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut178 happy_x_1 of { (HappyWrap178 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut179 happy_x_3 of { (HappyWrap179 happy_var_3) -> ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))}}}) ) (\r -> happyReturn (happyIn178 r)) happyReduce_427 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_427 = happySpecReduce_1 162# happyReduction_427 happyReduction_427 happy_x_1 = case happyOut179 happy_x_1 of { (HappyWrap179 happy_var_1) -> happyIn178 (sL1 happy_var_1 [happy_var_1] )} happyReduce_428 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_428 = happyMonadReduce 3# 163# happyReduction_428 happyReduction_428 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut180 happy_x_1 of { (HappyWrap180 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut180 happy_x_3 of { (HappyWrap180 happy_var_3) -> ( ams (cL (comb3 happy_var_1 happy_var_2 happy_var_3) (reverse (unLoc happy_var_1), reverse (unLoc happy_var_3))) [mu AnnRarrow happy_var_2])}}}) ) (\r -> happyReturn (happyIn179 r)) happyReduce_429 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_429 = happySpecReduce_0 164# happyReduction_429 happyReduction_429 = happyIn180 (noLoc [] ) happyReduce_430 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_430 = happySpecReduce_2 164# happyReduction_430 happyReduction_430 happy_x_2 happy_x_1 = case happyOut180 happy_x_1 of { (HappyWrap180 happy_var_1) -> case happyOut299 happy_x_2 of { (HappyWrap299 happy_var_2) -> happyIn180 (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) )}} happyReduce_431 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_431 = happySpecReduce_1 165# happyReduction_431 happyReduction_431 happy_x_1 = case happyOut157 happy_x_1 of { (HappyWrap157 happy_var_1) -> happyIn181 (happy_var_1 )} happyReduce_432 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_432 = happyMonadReduce 4# 166# happyReduction_432 happyReduction_432 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut183 happy_x_3 of { (HappyWrap183 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> ( checkEmptyGADTs $ cL (comb2 happy_var_1 happy_var_3) ([mj AnnWhere happy_var_1 ,moc happy_var_2 ,mcc happy_var_4] , unLoc happy_var_3))}}}}) ) (\r -> happyReturn (happyIn182 r)) happyReduce_433 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_433 = happyMonadReduce 4# 166# happyReduction_433 happyReduction_433 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut183 happy_x_3 of { (HappyWrap183 happy_var_3) -> ( checkEmptyGADTs $ cL (comb2 happy_var_1 happy_var_3) ([mj AnnWhere happy_var_1] , unLoc happy_var_3))}}) ) (\r -> happyReturn (happyIn182 r)) happyReduce_434 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_434 = happySpecReduce_0 166# happyReduction_434 happyReduction_434 = happyIn182 (noLoc ([],[]) ) happyReduce_435 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_435 = happyMonadReduce 3# 167# happyReduction_435 happyReduction_435 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut184 happy_x_1 of { (HappyWrap184 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut183 happy_x_3 of { (HappyWrap183 happy_var_3) -> ( addAnnotation (gl happy_var_1) AnnSemi (gl happy_var_2) >> return (cL (comb2 happy_var_1 happy_var_3) (happy_var_1 : unLoc happy_var_3)))}}}) ) (\r -> happyReturn (happyIn183 r)) happyReduce_436 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_436 = happySpecReduce_1 167# happyReduction_436 happyReduction_436 happy_x_1 = case happyOut184 happy_x_1 of { (HappyWrap184 happy_var_1) -> happyIn183 (cL (gl happy_var_1) [happy_var_1] )} happyReduce_437 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_437 = happySpecReduce_0 167# happyReduction_437 happyReduction_437 = happyIn183 (noLoc [] ) happyReduce_438 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_438 = happyMonadReduce 3# 168# happyReduction_438 happyReduction_438 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut329 happy_x_1 of { (HappyWrap329 happy_var_1) -> case happyOut185 happy_x_3 of { (HappyWrap185 happy_var_3) -> ( return $ addConDoc happy_var_3 happy_var_1)}}) ) (\r -> happyReturn (happyIn184 r)) happyReduce_439 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_439 = happyMonadReduce 1# 168# happyReduction_439 happyReduction_439 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut185 happy_x_1 of { (HappyWrap185 happy_var_1) -> ( return happy_var_1)}) ) (\r -> happyReturn (happyIn184 r)) happyReduce_440 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_440 = happyMonadReduce 3# 169# happyReduction_440 happyReduction_440 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut277 happy_x_1 of { (HappyWrap277 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut150 happy_x_3 of { (HappyWrap150 happy_var_3) -> ( let (gadt,anns) = mkGadtDecl (unLoc happy_var_1) happy_var_3 in ams (sLL happy_var_1 happy_var_3 gadt) (mu AnnDcolon happy_var_2:anns))}}}) ) (\r -> happyReturn (happyIn185 r)) happyReduce_441 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_441 = happySpecReduce_3 170# happyReduction_441 happyReduction_441 happy_x_3 happy_x_2 happy_x_1 = case happyOut329 happy_x_1 of { (HappyWrap329 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut187 happy_x_3 of { (HappyWrap187 happy_var_3) -> happyIn186 (cL (comb2 happy_var_2 happy_var_3) ([mj AnnEqual happy_var_2] ,addConDocs (unLoc happy_var_3) happy_var_1) )}}} happyReduce_442 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_442 = happyMonadReduce 5# 171# happyReduction_442 happyReduction_442 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut187 happy_x_1 of { (HappyWrap187 happy_var_1) -> case happyOut329 happy_x_2 of { (HappyWrap329 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut328 happy_x_4 of { (HappyWrap328 happy_var_4) -> case happyOut188 happy_x_5 of { (HappyWrap188 happy_var_5) -> ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnVbar (gl happy_var_3) >> return (sLL happy_var_1 happy_var_5 (addConDoc happy_var_5 happy_var_2 : addConDocFirst (unLoc happy_var_1) happy_var_4)))}}}}}) ) (\r -> happyReturn (happyIn187 r)) happyReduce_443 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_443 = happySpecReduce_1 171# happyReduction_443 happyReduction_443 happy_x_1 = case happyOut188 happy_x_1 of { (HappyWrap188 happy_var_1) -> happyIn187 (sL1 happy_var_1 [happy_var_1] )} happyReduce_444 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_444 = happyMonadReduce 5# 172# happyReduction_444 happyReduction_444 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut329 happy_x_1 of { (HappyWrap329 happy_var_1) -> case happyOut189 happy_x_2 of { (HappyWrap189 happy_var_2) -> case happyOut160 happy_x_3 of { (HappyWrap160 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> case happyOut190 happy_x_5 of { (HappyWrap190 happy_var_5) -> ( ams (let (con,details,doc_prev) = unLoc happy_var_5 in addConDoc (cL (comb4 happy_var_2 happy_var_3 happy_var_4 happy_var_5) (mkConDeclH98 con (snd $ unLoc happy_var_2) (Just happy_var_3) details)) (happy_var_1 `mplus` doc_prev)) (mu AnnDarrow happy_var_4:(fst $ unLoc happy_var_2)))}}}}}) ) (\r -> happyReturn (happyIn188 r)) happyReduce_445 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_445 = happyMonadReduce 3# 172# happyReduction_445 happyReduction_445 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut329 happy_x_1 of { (HappyWrap329 happy_var_1) -> case happyOut189 happy_x_2 of { (HappyWrap189 happy_var_2) -> case happyOut190 happy_x_3 of { (HappyWrap190 happy_var_3) -> ( ams ( let (con,details,doc_prev) = unLoc happy_var_3 in addConDoc (cL (comb2 happy_var_2 happy_var_3) (mkConDeclH98 con (snd $ unLoc happy_var_2) Nothing -- No context details)) (happy_var_1 `mplus` doc_prev)) (fst $ unLoc happy_var_2))}}}) ) (\r -> happyReturn (happyIn188 r)) happyReduce_446 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_446 = happySpecReduce_3 173# happyReduction_446 happyReduction_446 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut175 happy_x_2 of { (HappyWrap175 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn189 (sLL happy_var_1 happy_var_3 ([mu AnnForall happy_var_1,mj AnnDot happy_var_3], Just happy_var_2) )}}} happyReduce_447 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_447 = happySpecReduce_0 173# happyReduction_447 happyReduction_447 = happyIn189 (noLoc ([], Nothing) ) happyReduce_448 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_448 = happyMonadReduce 1# 174# happyReduction_448 happyReduction_448 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> ( do { c <- mergeDataCon (unLoc happy_var_1) ; return $ sL1 happy_var_1 c })}) ) (\r -> happyReturn (happyIn190 r)) happyReduce_449 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_449 = happySpecReduce_0 175# happyReduction_449 happyReduction_449 = happyIn191 ([] ) happyReduce_450 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_450 = happySpecReduce_1 175# happyReduction_450 happyReduction_450 happy_x_1 = case happyOut192 happy_x_1 of { (HappyWrap192 happy_var_1) -> happyIn191 (happy_var_1 )} happyReduce_451 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_451 = happyMonadReduce 5# 176# happyReduction_451 happyReduction_451 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut193 happy_x_1 of { (HappyWrap193 happy_var_1) -> case happyOut329 happy_x_2 of { (HappyWrap329 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut328 happy_x_4 of { (HappyWrap328 happy_var_4) -> case happyOut192 happy_x_5 of { (HappyWrap192 happy_var_5) -> ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_3) >> return ((addFieldDoc happy_var_1 happy_var_4) : addFieldDocs happy_var_5 happy_var_2))}}}}}) ) (\r -> happyReturn (happyIn192 r)) happyReduce_452 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_452 = happySpecReduce_1 176# happyReduction_452 happyReduction_452 happy_x_1 = case happyOut193 happy_x_1 of { (HappyWrap193 happy_var_1) -> happyIn192 ([happy_var_1] )} happyReduce_453 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_453 = happyMonadReduce 5# 177# happyReduction_453 happyReduction_453 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut329 happy_x_1 of { (HappyWrap329 happy_var_1) -> case happyOut151 happy_x_2 of { (HappyWrap151 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut157 happy_x_4 of { (HappyWrap157 happy_var_4) -> case happyOut328 happy_x_5 of { (HappyWrap328 happy_var_5) -> ( ams (cL (comb2 happy_var_2 happy_var_4) (ConDeclField noExtField (reverse (map (\ln@(dL->L l n) -> cL l $ FieldOcc noExtField ln) (unLoc happy_var_2))) happy_var_4 (happy_var_1 `mplus` happy_var_5))) [mu AnnDcolon happy_var_3])}}}}}) ) (\r -> happyReturn (happyIn193 r)) happyReduce_454 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_454 = happySpecReduce_0 178# happyReduction_454 happyReduction_454 = happyIn194 (noLoc [] ) happyReduce_455 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_455 = happySpecReduce_1 178# happyReduction_455 happyReduction_455 happy_x_1 = case happyOut195 happy_x_1 of { (HappyWrap195 happy_var_1) -> happyIn194 (happy_var_1 )} happyReduce_456 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_456 = happySpecReduce_2 179# happyReduction_456 happyReduction_456 happy_x_2 happy_x_1 = case happyOut195 happy_x_1 of { (HappyWrap195 happy_var_1) -> case happyOut196 happy_x_2 of { (HappyWrap196 happy_var_2) -> happyIn195 (sLL happy_var_1 happy_var_2 $ happy_var_2 : unLoc happy_var_1 )}} happyReduce_457 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_457 = happySpecReduce_1 179# happyReduction_457 happyReduction_457 happy_x_1 = case happyOut196 happy_x_1 of { (HappyWrap196 happy_var_1) -> happyIn195 (sLL happy_var_1 happy_var_1 [happy_var_1] )} happyReduce_458 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_458 = happyMonadReduce 2# 180# happyReduction_458 happyReduction_458 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut197 happy_x_2 of { (HappyWrap197 happy_var_2) -> ( let { full_loc = comb2 happy_var_1 happy_var_2 } in ams (cL full_loc $ HsDerivingClause noExtField Nothing happy_var_2) [mj AnnDeriving happy_var_1])}}) ) (\r -> happyReturn (happyIn196 r)) happyReduce_459 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_459 = happyMonadReduce 3# 180# happyReduction_459 happyReduction_459 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut84 happy_x_2 of { (HappyWrap84 happy_var_2) -> case happyOut197 happy_x_3 of { (HappyWrap197 happy_var_3) -> ( let { full_loc = comb2 happy_var_1 happy_var_3 } in ams (cL full_loc $ HsDerivingClause noExtField (Just happy_var_2) happy_var_3) [mj AnnDeriving happy_var_1])}}}) ) (\r -> happyReturn (happyIn196 r)) happyReduce_460 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_460 = happyMonadReduce 3# 180# happyReduction_460 happyReduction_460 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut197 happy_x_2 of { (HappyWrap197 happy_var_2) -> case happyOut85 happy_x_3 of { (HappyWrap85 happy_var_3) -> ( let { full_loc = comb2 happy_var_1 happy_var_3 } in ams (cL full_loc $ HsDerivingClause noExtField (Just happy_var_3) happy_var_2) [mj AnnDeriving happy_var_1])}}}) ) (\r -> happyReturn (happyIn196 r)) happyReduce_461 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_461 = happySpecReduce_1 181# happyReduction_461 happyReduction_461 happy_x_1 = case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> happyIn197 (sL1 happy_var_1 [mkLHsSigType happy_var_1] )} happyReduce_462 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_462 = happyMonadReduce 2# 181# happyReduction_462 happyReduction_462 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> ( ams (sLL happy_var_1 happy_var_2 []) [mop happy_var_1,mcp happy_var_2])}}) ) (\r -> happyReturn (happyIn197 r)) happyReduce_463 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_463 = happyMonadReduce 3# 181# happyReduction_463 happyReduction_463 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut171 happy_x_2 of { (HappyWrap171 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 happy_var_2) [mop happy_var_1,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn197 r)) happyReduce_464 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_464 = happySpecReduce_1 182# happyReduction_464 happyReduction_464 happy_x_1 = case happyOut199 happy_x_1 of { (HappyWrap199 happy_var_1) -> happyIn198 (sL1 happy_var_1 (DocD noExtField (unLoc happy_var_1)) )} happyReduce_465 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_465 = happySpecReduce_1 183# happyReduction_465 happyReduction_465 happy_x_1 = case happyOut323 happy_x_1 of { (HappyWrap323 happy_var_1) -> happyIn199 (sL1 happy_var_1 (DocCommentNext (unLoc happy_var_1)) )} happyReduce_466 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_466 = happySpecReduce_1 183# happyReduction_466 happyReduction_466 happy_x_1 = case happyOut324 happy_x_1 of { (HappyWrap324 happy_var_1) -> happyIn199 (sL1 happy_var_1 (DocCommentPrev (unLoc happy_var_1)) )} happyReduce_467 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_467 = happySpecReduce_1 183# happyReduction_467 happyReduction_467 happy_x_1 = case happyOut325 happy_x_1 of { (HappyWrap325 happy_var_1) -> happyIn199 (sL1 happy_var_1 (case (unLoc happy_var_1) of (n, doc) -> DocCommentNamed n doc) )} happyReduce_468 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_468 = happySpecReduce_1 183# happyReduction_468 happyReduction_468 happy_x_1 = case happyOut326 happy_x_1 of { (HappyWrap326 happy_var_1) -> happyIn199 (sL1 happy_var_1 (case (unLoc happy_var_1) of (n, doc) -> DocGroup n doc) )} happyReduce_469 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_469 = happySpecReduce_1 184# happyReduction_469 happyReduction_469 happy_x_1 = case happyOut205 happy_x_1 of { (HappyWrap205 happy_var_1) -> happyIn200 (happy_var_1 )} happyReduce_470 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_470 = happyMonadReduce 3# 184# happyReduction_470 happyReduction_470 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut218 happy_x_2 of { (HappyWrap218 happy_var_2) -> case happyOut202 happy_x_3 of { (HappyWrap202 happy_var_3) -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> do { let { e = patBuilderBang (getLoc happy_var_1) happy_var_2 ; l = comb2 happy_var_1 happy_var_3 }; (ann, r) <- checkValDef SrcStrict e Nothing happy_var_3 ; runPV $ hintBangPat (comb2 happy_var_1 happy_var_2) (unLoc e) ; -- Depending upon what the pattern looks like we might get either -- a FunBind or PatBind back from checkValDef. See Note -- [FunBind vs PatBind] case r of { (FunBind _ n _ _ _) -> amsL l [mj AnnFunId n] >> return () ; (PatBind _ (dL->L l _) _rhs _) -> amsL l [] >> return () } ; _ <- amsL l (ann ++ fst (unLoc happy_var_3) ++ [mj AnnBang happy_var_1]) ; return $! (sL l $ ValD noExtField r) })}}}) ) (\r -> happyReturn (happyIn200 r)) happyReduce_471 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_471 = happyMonadReduce 3# 184# happyReduction_471 happyReduction_471 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut211 happy_x_1 of { (HappyWrap211 happy_var_1) -> case happyOut147 happy_x_2 of { (HappyWrap147 happy_var_2) -> case happyOut202 happy_x_3 of { (HappyWrap202 happy_var_3) -> ( runECP_P happy_var_1 >>= \ happy_var_1 -> do { (ann,r) <- checkValDef NoSrcStrict happy_var_1 (snd happy_var_2) happy_var_3; let { l = comb2 happy_var_1 happy_var_3 }; -- Depending upon what the pattern looks like we might get either -- a FunBind or PatBind back from checkValDef. See Note -- [FunBind vs PatBind] case r of { (FunBind _ n _ _ _) -> amsL l (mj AnnFunId n:(fst happy_var_2)) >> return () ; (PatBind _ (dL->L lh _lhs) _rhs _) -> amsL lh (fst happy_var_2) >> return () } ; _ <- amsL l (ann ++ (fst $ unLoc happy_var_3)); return $! (sL l $ ValD noExtField r) })}}}) ) (\r -> happyReturn (happyIn200 r)) happyReduce_472 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_472 = happySpecReduce_1 184# happyReduction_472 happyReduction_472 happy_x_1 = case happyOut111 happy_x_1 of { (HappyWrap111 happy_var_1) -> happyIn200 (happy_var_1 )} happyReduce_473 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_473 = happySpecReduce_1 184# happyReduction_473 happyReduction_473 happy_x_1 = case happyOut198 happy_x_1 of { (HappyWrap198 happy_var_1) -> happyIn200 (happy_var_1 )} happyReduce_474 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_474 = happySpecReduce_1 185# happyReduction_474 happyReduction_474 happy_x_1 = case happyOut200 happy_x_1 of { (HappyWrap200 happy_var_1) -> happyIn201 (happy_var_1 )} happyReduce_475 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_475 = happySpecReduce_1 185# happyReduction_475 happyReduction_475 happy_x_1 = case happyOut221 happy_x_1 of { (HappyWrap221 happy_var_1) -> happyIn201 (sLL happy_var_1 happy_var_1 $ mkSpliceDecl happy_var_1 )} happyReduce_476 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_476 = happyMonadReduce 3# 186# happyReduction_476 happyReduction_476 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> case happyOut128 happy_x_3 of { (HappyWrap128 happy_var_3) -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> return $ sL (comb3 happy_var_1 happy_var_2 happy_var_3) ((mj AnnEqual happy_var_1 : (fst $ unLoc happy_var_3)) ,GRHSs noExtField (unguardedRHS (comb3 happy_var_1 happy_var_2 happy_var_3) happy_var_2) (snd $ unLoc happy_var_3)))}}}) ) (\r -> happyReturn (happyIn202 r)) happyReduce_477 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_477 = happySpecReduce_2 186# happyReduction_477 happyReduction_477 happy_x_2 happy_x_1 = case happyOut203 happy_x_1 of { (HappyWrap203 happy_var_1) -> case happyOut128 happy_x_2 of { (HappyWrap128 happy_var_2) -> happyIn202 (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_2 ,GRHSs noExtField (reverse (unLoc happy_var_1)) (snd $ unLoc happy_var_2)) )}} happyReduce_478 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_478 = happySpecReduce_2 187# happyReduction_478 happyReduction_478 happy_x_2 happy_x_1 = case happyOut203 happy_x_1 of { (HappyWrap203 happy_var_1) -> case happyOut204 happy_x_2 of { (HappyWrap204 happy_var_2) -> happyIn203 (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) )}} happyReduce_479 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_479 = happySpecReduce_1 187# happyReduction_479 happyReduction_479 happy_x_1 = case happyOut204 happy_x_1 of { (HappyWrap204 happy_var_1) -> happyIn203 (sL1 happy_var_1 [happy_var_1] )} happyReduce_480 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_480 = happyMonadReduce 4# 188# happyReduction_480 happyReduction_480 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut238 happy_x_2 of { (HappyWrap238 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut209 happy_x_4 of { (HappyWrap209 happy_var_4) -> ( runECP_P happy_var_4 >>= \ happy_var_4 -> ams (sL (comb2 happy_var_1 happy_var_4) $ GRHS noExtField (unLoc happy_var_2) happy_var_4) [mj AnnVbar happy_var_1,mj AnnEqual happy_var_3])}}}}) ) (\r -> happyReturn (happyIn204 r)) happyReduce_481 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_481 = happyMonadReduce 3# 189# happyReduction_481 happyReduction_481 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut211 happy_x_1 of { (HappyWrap211 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut150 happy_x_3 of { (HappyWrap150 happy_var_3) -> ( do { happy_var_1 <- runECP_P happy_var_1 ; v <- checkValSigLhs happy_var_1 ; _ <- amsL (comb2 happy_var_1 happy_var_3) [mu AnnDcolon happy_var_2] ; return (sLL happy_var_1 happy_var_3 $ SigD noExtField $ TypeSig noExtField [v] (mkLHsSigWcType happy_var_3))})}}}) ) (\r -> happyReturn (happyIn205 r)) happyReduce_482 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_482 = happyMonadReduce 5# 189# happyReduction_482 happyReduction_482 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut151 happy_x_3 of { (HappyWrap151 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> case happyOut150 happy_x_5 of { (HappyWrap150 happy_var_5) -> ( do { let sig = TypeSig noExtField (happy_var_1 : reverse (unLoc happy_var_3)) (mkLHsSigWcType happy_var_5) ; addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) ; ams ( sLL happy_var_1 happy_var_5 $ SigD noExtField sig ) [mu AnnDcolon happy_var_4] })}}}}}) ) (\r -> happyReturn (happyIn205 r)) happyReduce_483 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_483 = happyMonadReduce 3# 189# happyReduction_483 happyReduction_483 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut73 happy_x_1 of { (HappyWrap73 happy_var_1) -> case happyOut72 happy_x_2 of { (HappyWrap72 happy_var_2) -> case happyOut74 happy_x_3 of { (HappyWrap74 happy_var_3) -> ( checkPrecP happy_var_2 happy_var_3 >> ams (sLL happy_var_1 happy_var_3 $ SigD noExtField (FixSig noExtField (FixitySig noExtField (fromOL $ unLoc happy_var_3) (Fixity (fst $ unLoc happy_var_2) (snd $ unLoc happy_var_2) (unLoc happy_var_1))))) [mj AnnInfix happy_var_1,mj AnnVal happy_var_2])}}}) ) (\r -> happyReturn (happyIn205 r)) happyReduce_484 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_484 = happySpecReduce_1 189# happyReduction_484 happyReduction_484 happy_x_1 = case happyOut116 happy_x_1 of { (HappyWrap116 happy_var_1) -> happyIn205 (sLL happy_var_1 happy_var_1 . SigD noExtField . unLoc $ happy_var_1 )} happyReduce_485 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_485 = happyMonadReduce 4# 189# happyReduction_485 happyReduction_485 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut277 happy_x_2 of { (HappyWrap277 happy_var_2) -> case happyOut148 happy_x_3 of { (HappyWrap148 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> ( let (dcolon, tc) = happy_var_3 in ams (sLL happy_var_1 happy_var_4 (SigD noExtField (CompleteMatchSig noExtField (getCOMPLETE_PRAGs happy_var_1) happy_var_2 tc))) ([ mo happy_var_1 ] ++ dcolon ++ [mc happy_var_4]))}}}}) ) (\r -> happyReturn (happyIn205 r)) happyReduce_486 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_486 = happyMonadReduce 4# 189# happyReduction_486 happyReduction_486 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> case happyOut303 happy_x_3 of { (HappyWrap303 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> ( ams ((sLL happy_var_1 happy_var_4 $ SigD noExtField (InlineSig noExtField happy_var_3 (mkInlinePragma (getINLINE_PRAGs happy_var_1) (getINLINE happy_var_1) (snd happy_var_2))))) ((mo happy_var_1:fst happy_var_2) ++ [mc happy_var_4]))}}}}) ) (\r -> happyReturn (happyIn205 r)) happyReduce_487 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_487 = happyMonadReduce 3# 189# happyReduction_487 happyReduction_487 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut303 happy_x_2 of { (HappyWrap303 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (SigD noExtField (SCCFunSig noExtField (getSCC_PRAGs happy_var_1) happy_var_2 Nothing))) [mo happy_var_1, mc happy_var_3])}}}) ) (\r -> happyReturn (happyIn205 r)) happyReduce_488 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_488 = happyMonadReduce 4# 189# happyReduction_488 happyReduction_488 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut303 happy_x_2 of { (HappyWrap303 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> ( do { scc <- getSCC happy_var_3 ; let str_lit = StringLiteral (getSTRINGs happy_var_3) scc ; ams (sLL happy_var_1 happy_var_4 (SigD noExtField (SCCFunSig noExtField (getSCC_PRAGs happy_var_1) happy_var_2 (Just ( sL1 happy_var_3 str_lit))))) [mo happy_var_1, mc happy_var_4] })}}}}) ) (\r -> happyReturn (happyIn205 r)) happyReduce_489 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_489 = happyMonadReduce 6# 189# happyReduction_489 happyReduction_489 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> case happyOut303 happy_x_3 of { (HappyWrap303 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> case happyOut152 happy_x_5 of { (HappyWrap152 happy_var_5) -> case happyOutTok happy_x_6 of { happy_var_6 -> ( ams ( let inl_prag = mkInlinePragma (getSPEC_PRAGs happy_var_1) (NoUserInline, FunLike) (snd happy_var_2) in sLL happy_var_1 happy_var_6 $ SigD noExtField (SpecSig noExtField happy_var_3 (fromOL happy_var_5) inl_prag)) (mo happy_var_1:mu AnnDcolon happy_var_4:mc happy_var_6:(fst happy_var_2)))}}}}}}) ) (\r -> happyReturn (happyIn205 r)) happyReduce_490 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_490 = happyMonadReduce 6# 189# happyReduction_490 happyReduction_490 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> case happyOut303 happy_x_3 of { (HappyWrap303 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> case happyOut152 happy_x_5 of { (HappyWrap152 happy_var_5) -> case happyOutTok happy_x_6 of { happy_var_6 -> ( ams (sLL happy_var_1 happy_var_6 $ SigD noExtField (SpecSig noExtField happy_var_3 (fromOL happy_var_5) (mkInlinePragma (getSPEC_INLINE_PRAGs happy_var_1) (getSPEC_INLINE happy_var_1) (snd happy_var_2)))) (mo happy_var_1:mu AnnDcolon happy_var_4:mc happy_var_6:(fst happy_var_2)))}}}}}}) ) (\r -> happyReturn (happyIn205 r)) happyReduce_491 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_491 = happyMonadReduce 4# 189# happyReduction_491 happyReduction_491 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut170 happy_x_3 of { (HappyWrap170 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> ( ams (sLL happy_var_1 happy_var_4 $ SigD noExtField (SpecInstSig noExtField (getSPEC_PRAGs happy_var_1) happy_var_3)) [mo happy_var_1,mj AnnInstance happy_var_2,mc happy_var_4])}}}}) ) (\r -> happyReturn (happyIn205 r)) happyReduce_492 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_492 = happyMonadReduce 3# 189# happyReduction_492 happyReduction_492 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut266 happy_x_2 of { (HappyWrap266 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ SigD noExtField (MinimalSig noExtField (getMINIMAL_PRAGs happy_var_1) happy_var_2)) [mo happy_var_1,mc happy_var_3])}}}) ) (\r -> happyReturn (happyIn205 r)) happyReduce_493 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_493 = happySpecReduce_0 190# happyReduction_493 happyReduction_493 = happyIn206 (([],Nothing) ) happyReduce_494 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_494 = happySpecReduce_1 190# happyReduction_494 happyReduction_494 happy_x_1 = case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> happyIn206 ((fst happy_var_1,Just (snd happy_var_1)) )} happyReduce_495 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_495 = happySpecReduce_3 191# happyReduction_495 happyReduction_495 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn207 (([mj AnnOpenS happy_var_1,mj AnnVal happy_var_2,mj AnnCloseS happy_var_3] ,ActiveAfter (getINTEGERs happy_var_2) (fromInteger (il_value (getINTEGER happy_var_2)))) )}}} happyReduce_496 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_496 = happyReduce 4# 191# happyReduction_496 happyReduction_496 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> happyIn207 (([mj AnnOpenS happy_var_1,mj AnnTilde happy_var_2,mj AnnVal happy_var_3 ,mj AnnCloseS happy_var_4] ,ActiveBefore (getINTEGERs happy_var_3) (fromInteger (il_value (getINTEGER happy_var_3)))) ) `HappyStk` happyRest}}}} happyReduce_497 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_497 = happySpecReduce_1 192# happyReduction_497 happyReduction_497 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn208 (let { loc = getLoc happy_var_1 ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc happy_var_1 ; quoterId = mkUnqual varName quoter } in sL1 happy_var_1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) )} happyReduce_498 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_498 = happySpecReduce_1 192# happyReduction_498 happyReduction_498 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn208 (let { loc = getLoc happy_var_1 ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc happy_var_1 ; quoterId = mkQual varName (qual, quoter) } in sL (getLoc happy_var_1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) )} happyReduce_499 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_499 = happySpecReduce_3 193# happyReduction_499 happyReduction_499 happy_x_3 happy_x_2 happy_x_1 = case happyOut210 happy_x_1 of { (HappyWrap210 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut149 happy_x_3 of { (HappyWrap149 happy_var_3) -> happyIn209 (ECP $ runECP_PV happy_var_1 >>= \ happy_var_1 -> amms (mkHsTySigPV (comb2 happy_var_1 happy_var_3) happy_var_1 happy_var_3) [mu AnnDcolon happy_var_2] )}}} happyReduce_500 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_500 = happyMonadReduce 3# 193# happyReduction_500 happyReduction_500 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut210 happy_x_1 of { (HappyWrap210 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut209 happy_x_3 of { (HappyWrap209 happy_var_3) -> ( runECP_P happy_var_1 >>= \ happy_var_1 -> runECP_P happy_var_3 >>= \ happy_var_3 -> fmap ecpFromCmd $ ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExtField happy_var_1 happy_var_3 HsFirstOrderApp True) [mu Annlarrowtail happy_var_2])}}}) ) (\r -> happyReturn (happyIn209 r)) happyReduce_501 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_501 = happyMonadReduce 3# 193# happyReduction_501 happyReduction_501 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut210 happy_x_1 of { (HappyWrap210 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut209 happy_x_3 of { (HappyWrap209 happy_var_3) -> ( runECP_P happy_var_1 >>= \ happy_var_1 -> runECP_P happy_var_3 >>= \ happy_var_3 -> fmap ecpFromCmd $ ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExtField happy_var_3 happy_var_1 HsFirstOrderApp False) [mu Annrarrowtail happy_var_2])}}}) ) (\r -> happyReturn (happyIn209 r)) happyReduce_502 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_502 = happyMonadReduce 3# 193# happyReduction_502 happyReduction_502 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut210 happy_x_1 of { (HappyWrap210 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut209 happy_x_3 of { (HappyWrap209 happy_var_3) -> ( runECP_P happy_var_1 >>= \ happy_var_1 -> runECP_P happy_var_3 >>= \ happy_var_3 -> fmap ecpFromCmd $ ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExtField happy_var_1 happy_var_3 HsHigherOrderApp True) [mu AnnLarrowtail happy_var_2])}}}) ) (\r -> happyReturn (happyIn209 r)) happyReduce_503 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_503 = happyMonadReduce 3# 193# happyReduction_503 happyReduction_503 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut210 happy_x_1 of { (HappyWrap210 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut209 happy_x_3 of { (HappyWrap209 happy_var_3) -> ( runECP_P happy_var_1 >>= \ happy_var_1 -> runECP_P happy_var_3 >>= \ happy_var_3 -> fmap ecpFromCmd $ ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExtField happy_var_3 happy_var_1 HsHigherOrderApp False) [mu AnnRarrowtail happy_var_2])}}}) ) (\r -> happyReturn (happyIn209 r)) happyReduce_504 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_504 = happySpecReduce_1 193# happyReduction_504 happyReduction_504 happy_x_1 = case happyOut210 happy_x_1 of { (HappyWrap210 happy_var_1) -> happyIn209 (happy_var_1 )} happyReduce_505 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_505 = happySpecReduce_1 194# happyReduction_505 happyReduction_505 happy_x_1 = case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> happyIn210 (happy_var_1 )} happyReduce_506 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_506 = happySpecReduce_3 194# happyReduction_506 happyReduction_506 happy_x_3 happy_x_2 happy_x_1 = case happyOut210 happy_x_1 of { (HappyWrap210 happy_var_1) -> case happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> case happyOut213 happy_x_3 of { (HappyWrap213 happy_var_3) -> happyIn210 (ECP $ superInfixOp $ happy_var_2 >>= \ happy_var_2 -> runECP_PV happy_var_1 >>= \ happy_var_1 -> runECP_PV happy_var_3 >>= \ happy_var_3 -> amms (mkHsOpAppPV (comb2 happy_var_1 happy_var_3) happy_var_1 happy_var_2 happy_var_3) [mj AnnVal happy_var_2] )}}} happyReduce_507 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_507 = happySpecReduce_1 195# happyReduction_507 happyReduction_507 happy_x_1 = case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> happyIn211 (happy_var_1 )} happyReduce_508 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_508 = happySpecReduce_3 195# happyReduction_508 happyReduction_508 happy_x_3 happy_x_2 happy_x_1 = case happyOut211 happy_x_1 of { (HappyWrap211 happy_var_1) -> case happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> case happyOut212 happy_x_3 of { (HappyWrap212 happy_var_3) -> happyIn211 (ECP $ superInfixOp $ happy_var_2 >>= \ happy_var_2 -> runECP_PV happy_var_1 >>= \ happy_var_1 -> runECP_PV happy_var_3 >>= \ happy_var_3 -> amms (mkHsOpAppPV (comb2 happy_var_1 happy_var_3) happy_var_1 happy_var_2 happy_var_3) [mj AnnVal happy_var_2] )}}} happyReduce_509 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_509 = happySpecReduce_2 196# happyReduction_509 happyReduction_509 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut217 happy_x_2 of { (HappyWrap217 happy_var_2) -> happyIn212 (ECP $ runECP_PV happy_var_2 >>= \ happy_var_2 -> amms (mkHsNegAppPV (comb2 happy_var_1 happy_var_2) happy_var_2) [mj AnnMinus happy_var_1] )}} happyReduce_510 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_510 = happyMonadReduce 2# 196# happyReduction_510 happyReduction_510 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut216 happy_x_1 of { (HappyWrap216 happy_var_1) -> case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsTickPragma noExtField (snd $ fst $ fst $ unLoc happy_var_1) (snd $ fst $ unLoc happy_var_1) (snd $ unLoc happy_var_1) happy_var_2) (fst $ fst $ fst $ unLoc happy_var_1))}}) ) (\r -> happyReturn (happyIn212 r)) happyReduce_511 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_511 = happyMonadReduce 4# 196# happyReduction_511 happyReduction_511 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut209 happy_x_4 of { (HappyWrap209 happy_var_4) -> ( runECP_P happy_var_4 >>= \ happy_var_4 -> fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_4 $ HsCoreAnn noExtField (getCORE_PRAGs happy_var_1) (getStringLiteral happy_var_2) happy_var_4) [mo happy_var_1,mj AnnVal happy_var_2 ,mc happy_var_3])}}}}) ) (\r -> happyReturn (happyIn212 r)) happyReduce_512 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_512 = happySpecReduce_1 196# happyReduction_512 happyReduction_512 happy_x_1 = case happyOut217 happy_x_1 of { (HappyWrap217 happy_var_1) -> happyIn212 (happy_var_1 )} happyReduce_513 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_513 = happySpecReduce_1 197# happyReduction_513 happyReduction_513 happy_x_1 = case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> happyIn213 (happy_var_1 )} happyReduce_514 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_514 = happyMonadReduce 2# 197# happyReduction_514 happyReduction_514 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut215 happy_x_1 of { (HappyWrap215 happy_var_1) -> case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsSCC noExtField (snd $ fst $ unLoc happy_var_1) (snd $ unLoc happy_var_1) happy_var_2) (fst $ fst $ unLoc happy_var_1))}}) ) (\r -> happyReturn (happyIn213 r)) happyReduce_515 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_515 = happySpecReduce_1 198# happyReduction_515 happyReduction_515 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn214 (([happy_var_1],True) )} happyReduce_516 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_516 = happySpecReduce_0 198# happyReduction_516 happyReduction_516 = happyIn214 (([],False) ) happyReduce_517 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_517 = happyMonadReduce 3# 199# happyReduction_517 happyReduction_517 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> ( do scc <- getSCC happy_var_2 ; return $ sLL happy_var_1 happy_var_3 (([mo happy_var_1,mj AnnValStr happy_var_2 ,mc happy_var_3],getSCC_PRAGs happy_var_1),(StringLiteral (getSTRINGs happy_var_2) scc)))}}}) ) (\r -> happyReturn (happyIn215 r)) happyReduce_518 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_518 = happySpecReduce_3 199# happyReduction_518 happyReduction_518 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn215 (sLL happy_var_1 happy_var_3 (([mo happy_var_1,mj AnnVal happy_var_2 ,mc happy_var_3],getSCC_PRAGs happy_var_1) ,(StringLiteral NoSourceText (getVARID happy_var_2))) )}}} happyReduce_519 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_519 = happyReduce 10# 200# happyReduction_519 happyReduction_519 (happy_x_10 `HappyStk` happy_x_9 `HappyStk` happy_x_8 `HappyStk` happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> case happyOutTok happy_x_5 of { happy_var_5 -> case happyOutTok happy_x_6 of { happy_var_6 -> case happyOutTok happy_x_7 of { happy_var_7 -> case happyOutTok happy_x_8 of { happy_var_8 -> case happyOutTok happy_x_9 of { happy_var_9 -> case happyOutTok happy_x_10 of { happy_var_10 -> happyIn216 (sLL happy_var_1 happy_var_10 $ ((([mo happy_var_1,mj AnnVal happy_var_2 ,mj AnnVal happy_var_3,mj AnnColon happy_var_4 ,mj AnnVal happy_var_5,mj AnnMinus happy_var_6 ,mj AnnVal happy_var_7,mj AnnColon happy_var_8 ,mj AnnVal happy_var_9,mc happy_var_10], getGENERATED_PRAGs happy_var_1) ,((getStringLiteral happy_var_2) ,( fromInteger $ il_value $ getINTEGER happy_var_3 , fromInteger $ il_value $ getINTEGER happy_var_5 ) ,( fromInteger $ il_value $ getINTEGER happy_var_7 , fromInteger $ il_value $ getINTEGER happy_var_9 ) )) , (( getINTEGERs happy_var_3 , getINTEGERs happy_var_5 ) ,( getINTEGERs happy_var_7 , getINTEGERs happy_var_9 ))) ) `HappyStk` happyRest}}}}}}}}}} happyReduce_520 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_520 = happySpecReduce_2 201# happyReduction_520 happyReduction_520 happy_x_2 happy_x_1 = case happyOut217 happy_x_1 of { (HappyWrap217 happy_var_1) -> case happyOut218 happy_x_2 of { (HappyWrap218 happy_var_2) -> happyIn217 (ECP $ superFunArg $ runECP_PV happy_var_1 >>= \ happy_var_1 -> runECP_PV happy_var_2 >>= \ happy_var_2 -> mkHsAppPV (comb2 happy_var_1 happy_var_2) happy_var_1 happy_var_2 )}} happyReduce_521 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_521 = happyMonadReduce 3# 201# happyReduction_521 happyReduction_521 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut217 happy_x_1 of { (HappyWrap217 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> ( runECP_P happy_var_1 >>= \ happy_var_1 -> runPV (checkExpBlockArguments happy_var_1) >>= \_ -> fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_3 $ HsAppType noExtField happy_var_1 (mkHsWildCardBndrs happy_var_3)) [mj AnnAt happy_var_2])}}}) ) (\r -> happyReturn (happyIn217 r)) happyReduce_522 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_522 = happyMonadReduce 2# 201# happyReduction_522 happyReduction_522 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut218 happy_x_2 of { (HappyWrap218 happy_var_2) -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsStatic noExtField happy_var_2) [mj AnnStatic happy_var_1])}}) ) (\r -> happyReturn (happyIn217 r)) happyReduce_523 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_523 = happySpecReduce_1 201# happyReduction_523 happyReduction_523 happy_x_1 = case happyOut218 happy_x_1 of { (HappyWrap218 happy_var_1) -> happyIn217 (happy_var_1 )} happyReduce_524 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_524 = happySpecReduce_3 202# happyReduction_524 happyReduction_524 happy_x_3 happy_x_2 happy_x_1 = case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut218 happy_x_3 of { (HappyWrap218 happy_var_3) -> happyIn218 (ECP $ runECP_PV happy_var_3 >>= \ happy_var_3 -> amms (mkHsAsPatPV (comb2 happy_var_1 happy_var_3) happy_var_1 happy_var_3) [mj AnnAt happy_var_2] )}}} happyReduce_525 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_525 = happySpecReduce_2 202# happyReduction_525 happyReduction_525 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut218 happy_x_2 of { (HappyWrap218 happy_var_2) -> happyIn218 (ECP $ runECP_PV happy_var_2 >>= \ happy_var_2 -> amms (mkHsLazyPatPV (comb2 happy_var_1 happy_var_2) happy_var_2) [mj AnnTilde happy_var_1] )}} happyReduce_526 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_526 = happyReduce 5# 202# happyReduction_526 happyReduction_526 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut251 happy_x_2 of { (HappyWrap251 happy_var_2) -> case happyOut252 happy_x_3 of { (HappyWrap252 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> case happyOut209 happy_x_5 of { (HappyWrap209 happy_var_5) -> happyIn218 (ECP $ runECP_PV happy_var_5 >>= \ happy_var_5 -> amms (mkHsLamPV (comb2 happy_var_1 happy_var_5) (mkMatchGroup FromSource [sLL happy_var_1 happy_var_5 $ Match { m_ext = noExtField , m_ctxt = LambdaExpr , m_pats = happy_var_2:happy_var_3 , m_grhss = unguardedGRHSs happy_var_5 }])) [mj AnnLam happy_var_1, mu AnnRarrow happy_var_4] ) `HappyStk` happyRest}}}}} happyReduce_527 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_527 = happyReduce 4# 202# happyReduction_527 happyReduction_527 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut127 happy_x_2 of { (HappyWrap127 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut209 happy_x_4 of { (HappyWrap209 happy_var_4) -> happyIn218 (ECP $ runECP_PV happy_var_4 >>= \ happy_var_4 -> amms (mkHsLetPV (comb2 happy_var_1 happy_var_4) (snd (unLoc happy_var_2)) happy_var_4) (mj AnnLet happy_var_1:mj AnnIn happy_var_3 :(fst $ unLoc happy_var_2)) ) `HappyStk` happyRest}}}} happyReduce_528 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_528 = happyMonadReduce 3# 202# happyReduction_528 happyReduction_528 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut240 happy_x_3 of { (HappyWrap240 happy_var_3) -> ( runPV happy_var_3 >>= \ happy_var_3 -> fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_3 $ HsLamCase noExtField (mkMatchGroup FromSource (snd $ unLoc happy_var_3))) (mj AnnLam happy_var_1:mj AnnCase happy_var_2:(fst $ unLoc happy_var_3)))}}}) ) (\r -> happyReturn (happyIn218 r)) happyReduce_529 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_529 = happyMonadReduce 8# 202# happyReduction_529 happyReduction_529 (happy_x_8 `HappyStk` happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> case happyOut214 happy_x_3 of { (HappyWrap214 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> case happyOut209 happy_x_5 of { (HappyWrap209 happy_var_5) -> case happyOut214 happy_x_6 of { (HappyWrap214 happy_var_6) -> case happyOutTok happy_x_7 of { happy_var_7 -> case happyOut209 happy_x_8 of { (HappyWrap209 happy_var_8) -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> return $ ECP $ runECP_PV happy_var_5 >>= \ happy_var_5 -> runECP_PV happy_var_8 >>= \ happy_var_8 -> amms (mkHsIfPV (comb2 happy_var_1 happy_var_8) happy_var_2 (snd happy_var_3) happy_var_5 (snd happy_var_6) happy_var_8) (mj AnnIf happy_var_1:mj AnnThen happy_var_4 :mj AnnElse happy_var_7 :(map (\l -> mj AnnSemi l) (fst happy_var_3)) ++(map (\l -> mj AnnSemi l) (fst happy_var_6))))}}}}}}}}) ) (\r -> happyReturn (happyIn218 r)) happyReduce_530 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_530 = happyMonadReduce 2# 202# happyReduction_530 happyReduction_530 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut247 happy_x_2 of { (HappyWrap247 happy_var_2) -> ( hintMultiWayIf (getLoc happy_var_1) >>= \_ -> fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsMultiIf noExtField (reverse $ snd $ unLoc happy_var_2)) (mj AnnIf happy_var_1:(fst $ unLoc happy_var_2)))}}) ) (\r -> happyReturn (happyIn218 r)) happyReduce_531 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_531 = happyMonadReduce 4# 202# happyReduction_531 happyReduction_531 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut240 happy_x_4 of { (HappyWrap240 happy_var_4) -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> return $ ECP $ happy_var_4 >>= \ happy_var_4 -> amms (mkHsCasePV (comb3 happy_var_1 happy_var_3 happy_var_4) happy_var_2 (mkMatchGroup FromSource (snd $ unLoc happy_var_4))) (mj AnnCase happy_var_1:mj AnnOf happy_var_3 :(fst $ unLoc happy_var_4)))}}}}) ) (\r -> happyReturn (happyIn218 r)) happyReduce_532 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_532 = happySpecReduce_2 202# happyReduction_532 happyReduction_532 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut253 happy_x_2 of { (HappyWrap253 happy_var_2) -> happyIn218 (ECP $ happy_var_2 >>= \ happy_var_2 -> amms (mkHsDoPV (comb2 happy_var_1 happy_var_2) (mapLoc snd happy_var_2)) (mj AnnDo happy_var_1:(fst $ unLoc happy_var_2)) )}} happyReduce_533 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_533 = happyMonadReduce 2# 202# happyReduction_533 happyReduction_533 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut253 happy_x_2 of { (HappyWrap253 happy_var_2) -> ( runPV happy_var_2 >>= \ happy_var_2 -> fmap ecpFromExp $ ams (cL (comb2 happy_var_1 happy_var_2) (mkHsDo MDoExpr (snd $ unLoc happy_var_2))) (mj AnnMdo happy_var_1:(fst $ unLoc happy_var_2)))}}) ) (\r -> happyReturn (happyIn218 r)) happyReduce_534 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_534 = happyMonadReduce 4# 202# happyReduction_534 happyReduction_534 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut218 happy_x_2 of { (HappyWrap218 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut209 happy_x_4 of { (HappyWrap209 happy_var_4) -> ( (checkPattern <=< runECP_P) happy_var_2 >>= \ p -> runECP_P happy_var_4 >>= \ happy_var_4@cmd -> fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_4 $ HsProc noExtField p (sLL happy_var_1 happy_var_4 $ HsCmdTop noExtField cmd)) -- TODO: is LL right here? [mj AnnProc happy_var_1,mu AnnRarrow happy_var_3])}}}}) ) (\r -> happyReturn (happyIn218 r)) happyReduce_535 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_535 = happySpecReduce_1 202# happyReduction_535 happyReduction_535 happy_x_1 = case happyOut219 happy_x_1 of { (HappyWrap219 happy_var_1) -> happyIn218 (happy_var_1 )} happyReduce_536 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_536 = happyReduce 4# 203# happyReduction_536 happyReduction_536 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOut219 happy_x_1 of { (HappyWrap219 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut259 happy_x_3 of { (HappyWrap259 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> happyIn219 (ECP $ runECP_PV happy_var_1 >>= \ happy_var_1 -> happy_var_3 >>= \ happy_var_3 -> amms (mkHsRecordPV (comb2 happy_var_1 happy_var_4) (comb2 happy_var_2 happy_var_4) happy_var_1 (snd happy_var_3)) (moc happy_var_2:mcc happy_var_4:(fst happy_var_3)) ) `HappyStk` happyRest}}}} happyReduce_537 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_537 = happySpecReduce_1 203# happyReduction_537 happyReduction_537 happy_x_1 = case happyOut220 happy_x_1 of { (HappyWrap220 happy_var_1) -> happyIn219 (happy_var_1 )} happyReduce_538 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_538 = happySpecReduce_1 204# happyReduction_538 happyReduction_538 happy_x_1 = case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> happyIn220 (ECP $ mkHsVarPV $! happy_var_1 )} happyReduce_539 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_539 = happySpecReduce_1 204# happyReduction_539 happyReduction_539 happy_x_1 = case happyOut274 happy_x_1 of { (HappyWrap274 happy_var_1) -> happyIn220 (ECP $ mkHsVarPV $! happy_var_1 )} happyReduce_540 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_540 = happySpecReduce_1 204# happyReduction_540 happyReduction_540 happy_x_1 = case happyOut264 happy_x_1 of { (HappyWrap264 happy_var_1) -> happyIn220 (ecpFromExp $ sL1 happy_var_1 (HsIPVar noExtField $! unLoc happy_var_1) )} happyReduce_541 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_541 = happySpecReduce_1 204# happyReduction_541 happyReduction_541 happy_x_1 = case happyOut265 happy_x_1 of { (HappyWrap265 happy_var_1) -> happyIn220 (ecpFromExp $ sL1 happy_var_1 (HsOverLabel noExtField Nothing $! unLoc happy_var_1) )} happyReduce_542 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_542 = happySpecReduce_1 204# happyReduction_542 happyReduction_542 happy_x_1 = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> happyIn220 (ECP $ mkHsLitPV $! happy_var_1 )} happyReduce_543 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_543 = happySpecReduce_1 204# happyReduction_543 happyReduction_543 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn220 (ECP $ mkHsOverLitPV (sL1 happy_var_1 $ mkHsIntegral (getINTEGER happy_var_1)) )} happyReduce_544 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_544 = happySpecReduce_1 204# happyReduction_544 happyReduction_544 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn220 (ECP $ mkHsOverLitPV (sL1 happy_var_1 $ mkHsFractional (getRATIONAL happy_var_1)) )} happyReduce_545 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_545 = happySpecReduce_3 204# happyReduction_545 happyReduction_545 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut228 happy_x_2 of { (HappyWrap228 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn220 (ECP $ runECP_PV happy_var_2 >>= \ happy_var_2 -> amms (mkHsParPV (comb2 happy_var_1 happy_var_3) happy_var_2) [mop happy_var_1,mcp happy_var_3] )}}} happyReduce_546 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_546 = happySpecReduce_3 204# happyReduction_546 happyReduction_546 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut229 happy_x_2 of { (HappyWrap229 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn220 (ECP $ happy_var_2 >>= \ happy_var_2 -> amms (mkSumOrTuplePV (comb2 happy_var_1 happy_var_3) Boxed (snd happy_var_2)) ((mop happy_var_1:fst happy_var_2) ++ [mcp happy_var_3]) )}}} happyReduce_547 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_547 = happySpecReduce_3 204# happyReduction_547 happyReduction_547 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut228 happy_x_2 of { (HappyWrap228 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn220 (ECP $ runECP_PV happy_var_2 >>= \ happy_var_2 -> amms (mkSumOrTuplePV (comb2 happy_var_1 happy_var_3) Unboxed (Tuple [cL (gl happy_var_2) (Just happy_var_2)])) [mo happy_var_1,mc happy_var_3] )}}} happyReduce_548 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_548 = happySpecReduce_3 204# happyReduction_548 happyReduction_548 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut229 happy_x_2 of { (HappyWrap229 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn220 (ECP $ happy_var_2 >>= \ happy_var_2 -> amms (mkSumOrTuplePV (comb2 happy_var_1 happy_var_3) Unboxed (snd happy_var_2)) ((mo happy_var_1:fst happy_var_2) ++ [mc happy_var_3]) )}}} happyReduce_549 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_549 = happySpecReduce_3 204# happyReduction_549 happyReduction_549 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut232 happy_x_2 of { (HappyWrap232 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn220 (ECP $ happy_var_2 (comb2 happy_var_1 happy_var_3) >>= \a -> ams a [mos happy_var_1,mcs happy_var_3] )}}} happyReduce_550 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_550 = happySpecReduce_1 204# happyReduction_550 happyReduction_550 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn220 (ECP $ mkHsWildCardPV (getLoc happy_var_1) )} happyReduce_551 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_551 = happySpecReduce_1 204# happyReduction_551 happyReduction_551 happy_x_1 = case happyOut222 happy_x_1 of { (HappyWrap222 happy_var_1) -> happyIn220 (ECP $ mkHsSplicePV happy_var_1 )} happyReduce_552 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_552 = happySpecReduce_1 204# happyReduction_552 happyReduction_552 happy_x_1 = case happyOut223 happy_x_1 of { (HappyWrap223 happy_var_1) -> happyIn220 (ecpFromExp $ mapLoc (HsSpliceE noExtField) happy_var_1 )} happyReduce_553 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_553 = happyMonadReduce 2# 204# happyReduction_553 happyReduction_553 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut303 happy_x_2 of { (HappyWrap303 happy_var_2) -> ( fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExtField (VarBr noExtField True (unLoc happy_var_2))) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}}) ) (\r -> happyReturn (happyIn220 r)) happyReduce_554 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_554 = happyMonadReduce 2# 204# happyReduction_554 happyReduction_554 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut274 happy_x_2 of { (HappyWrap274 happy_var_2) -> ( fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExtField (VarBr noExtField True (unLoc happy_var_2))) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])}}) ) (\r -> happyReturn (happyIn220 r)) happyReduce_555 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_555 = happyMonadReduce 2# 204# happyReduction_555 happyReduction_555 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut299 happy_x_2 of { (HappyWrap299 happy_var_2) -> ( fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExtField (VarBr noExtField False (unLoc happy_var_2))) [mj AnnThTyQuote happy_var_1,mj AnnName happy_var_2])}}) ) (\r -> happyReturn (happyIn220 r)) happyReduce_556 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_556 = happyMonadReduce 2# 204# happyReduction_556 happyReduction_556 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut282 happy_x_2 of { (HappyWrap282 happy_var_2) -> ( fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExtField (VarBr noExtField False (unLoc happy_var_2))) [mj AnnThTyQuote happy_var_1,mj AnnName happy_var_2])}}) ) (\r -> happyReturn (happyIn220 r)) happyReduce_557 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_557 = happyMonadReduce 1# 204# happyReduction_557 happyReduction_557 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( reportEmptyDoubleQuotes (getLoc happy_var_1))}) ) (\r -> happyReturn (happyIn220 r)) happyReduce_558 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_558 = happyMonadReduce 3# 204# happyReduction_558 happyReduction_558 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_3 $ HsBracket noExtField (ExpBr noExtField happy_var_2)) (if (hasE happy_var_1) then [mj AnnOpenE happy_var_1, mu AnnCloseQ happy_var_3] else [mu AnnOpenEQ happy_var_1,mu AnnCloseQ happy_var_3]))}}}) ) (\r -> happyReturn (happyIn220 r)) happyReduce_559 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_559 = happyMonadReduce 3# 204# happyReduction_559 happyReduction_559 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_3 $ HsBracket noExtField (TExpBr noExtField happy_var_2)) (if (hasE happy_var_1) then [mj AnnOpenE happy_var_1,mc happy_var_3] else [mo happy_var_1,mc happy_var_3]))}}}) ) (\r -> happyReturn (happyIn220 r)) happyReduce_560 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_560 = happyMonadReduce 3# 204# happyReduction_560 happyReduction_560 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut155 happy_x_2 of { (HappyWrap155 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_3 $ HsBracket noExtField (TypBr noExtField happy_var_2)) [mo happy_var_1,mu AnnCloseQ happy_var_3])}}}) ) (\r -> happyReturn (happyIn220 r)) happyReduce_561 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_561 = happyMonadReduce 3# 204# happyReduction_561 happyReduction_561 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut210 happy_x_2 of { (HappyWrap210 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( (checkPattern <=< runECP_P) happy_var_2 >>= \p -> fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_3 $ HsBracket noExtField (PatBr noExtField p)) [mo happy_var_1,mu AnnCloseQ happy_var_3])}}}) ) (\r -> happyReturn (happyIn220 r)) happyReduce_562 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_562 = happyMonadReduce 3# 204# happyReduction_562 happyReduction_562 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut226 happy_x_2 of { (HappyWrap226 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( fmap ecpFromExp $ ams (sLL happy_var_1 happy_var_3 $ HsBracket noExtField (DecBrL noExtField (snd happy_var_2))) (mo happy_var_1:mu AnnCloseQ happy_var_3:fst happy_var_2))}}}) ) (\r -> happyReturn (happyIn220 r)) happyReduce_563 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_563 = happySpecReduce_1 204# happyReduction_563 happyReduction_563 happy_x_1 = case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> happyIn220 (ECP $ mkHsSplicePV happy_var_1 )} happyReduce_564 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_564 = happyMonadReduce 4# 204# happyReduction_564 happyReduction_564 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut220 happy_x_2 of { (HappyWrap220 happy_var_2) -> case happyOut224 happy_x_3 of { (HappyWrap224 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> fmap ecpFromCmd $ ams (sLL happy_var_1 happy_var_4 $ HsCmdArrForm noExtField happy_var_2 Prefix Nothing (reverse happy_var_3)) [mu AnnOpenB happy_var_1,mu AnnCloseB happy_var_4])}}}}) ) (\r -> happyReturn (happyIn220 r)) happyReduce_565 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_565 = happySpecReduce_1 205# happyReduction_565 happyReduction_565 happy_x_1 = case happyOut222 happy_x_1 of { (HappyWrap222 happy_var_1) -> happyIn221 (mapLoc (HsSpliceE noExtField) happy_var_1 )} happyReduce_566 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_566 = happySpecReduce_1 205# happyReduction_566 happyReduction_566 happy_x_1 = case happyOut223 happy_x_1 of { (HappyWrap223 happy_var_1) -> happyIn221 (mapLoc (HsSpliceE noExtField) happy_var_1 )} happyReduce_567 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_567 = happyMonadReduce 1# 206# happyReduction_567 happyReduction_567 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( ams (sL1 happy_var_1 $ mkUntypedSplice HasDollar (sL1 happy_var_1 $ HsVar noExtField (sL1 happy_var_1 (mkUnqual varName (getTH_ID_SPLICE happy_var_1))))) [mj AnnThIdSplice happy_var_1])}) ) (\r -> happyReturn (happyIn222 r)) happyReduce_568 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_568 = happyMonadReduce 3# 206# happyReduction_568 happyReduction_568 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> ams (sLL happy_var_1 happy_var_3 $ mkUntypedSplice HasParens happy_var_2) [mj AnnOpenPE happy_var_1,mj AnnCloseP happy_var_3])}}}) ) (\r -> happyReturn (happyIn222 r)) happyReduce_569 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_569 = happyMonadReduce 1# 207# happyReduction_569 happyReduction_569 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( ams (sL1 happy_var_1 $ mkTypedSplice HasDollar (sL1 happy_var_1 $ HsVar noExtField (sL1 happy_var_1 (mkUnqual varName (getTH_ID_TY_SPLICE happy_var_1))))) [mj AnnThIdTySplice happy_var_1])}) ) (\r -> happyReturn (happyIn223 r)) happyReduce_570 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_570 = happyMonadReduce 3# 207# happyReduction_570 happyReduction_570 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> ams (sLL happy_var_1 happy_var_3 $ mkTypedSplice HasParens happy_var_2) [mj AnnOpenPTE happy_var_1,mj AnnCloseP happy_var_3])}}}) ) (\r -> happyReturn (happyIn223 r)) happyReduce_571 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_571 = happySpecReduce_2 208# happyReduction_571 happyReduction_571 happy_x_2 happy_x_1 = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> case happyOut225 happy_x_2 of { (HappyWrap225 happy_var_2) -> happyIn224 (happy_var_2 : happy_var_1 )}} happyReduce_572 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_572 = happySpecReduce_0 208# happyReduction_572 happyReduction_572 = happyIn224 ([] ) happyReduce_573 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_573 = happyMonadReduce 1# 209# happyReduction_573 happyReduction_573 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut220 happy_x_1 of { (HappyWrap220 happy_var_1) -> ( runECP_P happy_var_1 >>= \ cmd -> return (sL1 cmd $ HsCmdTop noExtField cmd))}) ) (\r -> happyReturn (happyIn225 r)) happyReduce_574 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_574 = happySpecReduce_3 210# happyReduction_574 happyReduction_574 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut227 happy_x_2 of { (HappyWrap227 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn226 (([mj AnnOpenC happy_var_1 ,mj AnnCloseC happy_var_3],happy_var_2) )}}} happyReduce_575 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_575 = happySpecReduce_3 210# happyReduction_575 happyReduction_575 happy_x_3 happy_x_2 happy_x_1 = case happyOut227 happy_x_2 of { (HappyWrap227 happy_var_2) -> happyIn226 (([],happy_var_2) )} happyReduce_576 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_576 = happySpecReduce_1 211# happyReduction_576 happyReduction_576 happy_x_1 = case happyOut76 happy_x_1 of { (HappyWrap76 happy_var_1) -> happyIn227 (cvTopDecls happy_var_1 )} happyReduce_577 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_577 = happySpecReduce_1 211# happyReduction_577 happyReduction_577 happy_x_1 = case happyOut75 happy_x_1 of { (HappyWrap75 happy_var_1) -> happyIn227 (cvTopDecls happy_var_1 )} happyReduce_578 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_578 = happySpecReduce_1 212# happyReduction_578 happyReduction_578 happy_x_1 = case happyOut209 happy_x_1 of { (HappyWrap209 happy_var_1) -> happyIn228 (happy_var_1 )} happyReduce_579 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_579 = happyMonadReduce 2# 212# happyReduction_579 happyReduction_579 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut210 happy_x_1 of { (HappyWrap210 happy_var_1) -> case happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> ( runECP_P happy_var_1 >>= \ happy_var_1 -> runPV happy_var_2 >>= \ happy_var_2 -> return $ ecpFromExp $ sLL happy_var_1 happy_var_2 $ SectionL noExtField happy_var_1 happy_var_2)}}) ) (\r -> happyReturn (happyIn228 r)) happyReduce_580 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_580 = happySpecReduce_2 212# happyReduction_580 happyReduction_580 happy_x_2 happy_x_1 = case happyOut295 happy_x_1 of { (HappyWrap295 happy_var_1) -> case happyOut210 happy_x_2 of { (HappyWrap210 happy_var_2) -> happyIn228 (ECP $ superInfixOp $ runECP_PV happy_var_2 >>= \ happy_var_2 -> happy_var_1 >>= \ happy_var_1 -> mkHsSectionR_PV (comb2 happy_var_1 happy_var_2) happy_var_1 happy_var_2 )}} happyReduce_581 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_581 = happySpecReduce_3 212# happyReduction_581 happyReduction_581 happy_x_3 happy_x_2 happy_x_1 = case happyOut209 happy_x_1 of { (HappyWrap209 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut228 happy_x_3 of { (HappyWrap228 happy_var_3) -> happyIn228 (ECP $ runECP_PV happy_var_1 >>= \ happy_var_1 -> runECP_PV happy_var_3 >>= \ happy_var_3 -> amms (mkHsViewPatPV (comb2 happy_var_1 happy_var_3) happy_var_1 happy_var_3) [mu AnnRarrow happy_var_2] )}}} happyReduce_582 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_582 = happySpecReduce_2 213# happyReduction_582 happyReduction_582 happy_x_2 happy_x_1 = case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> happyIn229 (runECP_PV happy_var_1 >>= \ happy_var_1 -> happy_var_2 >>= \ happy_var_2 -> do { addAnnotation (gl happy_var_1) AnnComma (fst happy_var_2) ; return ([],Tuple ((sL1 happy_var_1 (Just happy_var_1)) : snd happy_var_2)) } )}} happyReduce_583 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_583 = happySpecReduce_2 213# happyReduction_583 happyReduction_583 happy_x_2 happy_x_1 = case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> case happyOut322 happy_x_2 of { (HappyWrap322 happy_var_2) -> happyIn229 (runECP_PV happy_var_1 >>= \ happy_var_1 -> return $ (mvbars (fst happy_var_2), Sum 1 (snd happy_var_2 + 1) happy_var_1) )}} happyReduce_584 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_584 = happySpecReduce_2 213# happyReduction_584 happyReduction_584 happy_x_2 happy_x_1 = case happyOut320 happy_x_1 of { (HappyWrap320 happy_var_1) -> case happyOut231 happy_x_2 of { (HappyWrap231 happy_var_2) -> happyIn229 (happy_var_2 >>= \ happy_var_2 -> do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst happy_var_1) ; return ([],Tuple (map (\l -> cL l Nothing) (fst happy_var_1) ++ happy_var_2)) } )}} happyReduce_585 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_585 = happySpecReduce_3 213# happyReduction_585 happyReduction_585 happy_x_3 happy_x_2 happy_x_1 = case happyOut322 happy_x_1 of { (HappyWrap322 happy_var_1) -> case happyOut228 happy_x_2 of { (HappyWrap228 happy_var_2) -> case happyOut321 happy_x_3 of { (HappyWrap321 happy_var_3) -> happyIn229 (runECP_PV happy_var_2 >>= \ happy_var_2 -> return $ (mvbars (fst happy_var_1) ++ mvbars (fst happy_var_3), Sum (snd happy_var_1 + 1) (snd happy_var_1 + snd happy_var_3 + 1) happy_var_2) )}}} happyReduce_586 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_586 = happySpecReduce_2 214# happyReduction_586 happyReduction_586 happy_x_2 happy_x_1 = case happyOut320 happy_x_1 of { (HappyWrap320 happy_var_1) -> case happyOut231 happy_x_2 of { (HappyWrap231 happy_var_2) -> happyIn230 (happy_var_2 >>= \ happy_var_2 -> do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst happy_var_1) ; return ( (head $ fst happy_var_1 ,(map (\l -> cL l Nothing) (tail $ fst happy_var_1)) ++ happy_var_2)) } )}} happyReduce_587 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_587 = happySpecReduce_2 215# happyReduction_587 happyReduction_587 happy_x_2 happy_x_1 = case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> happyIn231 (runECP_PV happy_var_1 >>= \ happy_var_1 -> happy_var_2 >>= \ happy_var_2 -> addAnnotation (gl happy_var_1) AnnComma (fst happy_var_2) >> return ((cL (gl happy_var_1) (Just happy_var_1)) : snd happy_var_2) )}} happyReduce_588 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_588 = happySpecReduce_1 215# happyReduction_588 happyReduction_588 happy_x_1 = case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> happyIn231 (runECP_PV happy_var_1 >>= \ happy_var_1 -> return [cL (gl happy_var_1) (Just happy_var_1)] )} happyReduce_589 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_589 = happySpecReduce_0 215# happyReduction_589 happyReduction_589 = happyIn231 (return [noLoc Nothing] ) happyReduce_590 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_590 = happySpecReduce_1 216# happyReduction_590 happyReduction_590 happy_x_1 = case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> happyIn232 (\loc -> runECP_PV happy_var_1 >>= \ happy_var_1 -> mkHsExplicitListPV loc [happy_var_1] )} happyReduce_591 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_591 = happySpecReduce_1 216# happyReduction_591 happyReduction_591 happy_x_1 = case happyOut233 happy_x_1 of { (HappyWrap233 happy_var_1) -> happyIn232 (\loc -> happy_var_1 >>= \ happy_var_1 -> mkHsExplicitListPV loc (reverse happy_var_1) )} happyReduce_592 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_592 = happySpecReduce_2 216# happyReduction_592 happyReduction_592 happy_x_2 happy_x_1 = case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> happyIn232 (\loc -> runECP_PV happy_var_1 >>= \ happy_var_1 -> ams (cL loc $ ArithSeq noExtField Nothing (From happy_var_1)) [mj AnnDotdot happy_var_2] >>= ecpFromExp' )}} happyReduce_593 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_593 = happyReduce 4# 216# happyReduction_593 happyReduction_593 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut209 happy_x_3 of { (HappyWrap209 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> happyIn232 (\loc -> runECP_PV happy_var_1 >>= \ happy_var_1 -> runECP_PV happy_var_3 >>= \ happy_var_3 -> ams (cL loc $ ArithSeq noExtField Nothing (FromThen happy_var_1 happy_var_3)) [mj AnnComma happy_var_2,mj AnnDotdot happy_var_4] >>= ecpFromExp' ) `HappyStk` happyRest}}}} happyReduce_594 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_594 = happySpecReduce_3 216# happyReduction_594 happyReduction_594 happy_x_3 happy_x_2 happy_x_1 = case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut209 happy_x_3 of { (HappyWrap209 happy_var_3) -> happyIn232 (\loc -> runECP_PV happy_var_1 >>= \ happy_var_1 -> runECP_PV happy_var_3 >>= \ happy_var_3 -> ams (cL loc $ ArithSeq noExtField Nothing (FromTo happy_var_1 happy_var_3)) [mj AnnDotdot happy_var_2] >>= ecpFromExp' )}}} happyReduce_595 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_595 = happyReduce 5# 216# happyReduction_595 happyReduction_595 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut209 happy_x_3 of { (HappyWrap209 happy_var_3) -> case happyOutTok happy_x_4 of { happy_var_4 -> case happyOut209 happy_x_5 of { (HappyWrap209 happy_var_5) -> happyIn232 (\loc -> runECP_PV happy_var_1 >>= \ happy_var_1 -> runECP_PV happy_var_3 >>= \ happy_var_3 -> runECP_PV happy_var_5 >>= \ happy_var_5 -> ams (cL loc $ ArithSeq noExtField Nothing (FromThenTo happy_var_1 happy_var_3 happy_var_5)) [mj AnnComma happy_var_2,mj AnnDotdot happy_var_4] >>= ecpFromExp' ) `HappyStk` happyRest}}}}} happyReduce_596 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_596 = happySpecReduce_3 216# happyReduction_596 happyReduction_596 happy_x_3 happy_x_2 happy_x_1 = case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut234 happy_x_3 of { (HappyWrap234 happy_var_3) -> happyIn232 (\loc -> checkMonadComp >>= \ ctxt -> runECP_PV happy_var_1 >>= \ happy_var_1 -> ams (cL loc $ mkHsComp ctxt (unLoc happy_var_3) happy_var_1) [mj AnnVbar happy_var_2] >>= ecpFromExp' )}}} happyReduce_597 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_597 = happySpecReduce_3 217# happyReduction_597 happyReduction_597 happy_x_3 happy_x_2 happy_x_1 = case happyOut233 happy_x_1 of { (HappyWrap233 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut228 happy_x_3 of { (HappyWrap228 happy_var_3) -> happyIn233 (happy_var_1 >>= \ happy_var_1 -> runECP_PV happy_var_3 >>= \ happy_var_3 -> addAnnotation (gl $ head $ happy_var_1) AnnComma (gl happy_var_2) >> return (((:) $! happy_var_3) $! happy_var_1) )}}} happyReduce_598 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_598 = happySpecReduce_3 217# happyReduction_598 happyReduction_598 happy_x_3 happy_x_2 happy_x_1 = case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut228 happy_x_3 of { (HappyWrap228 happy_var_3) -> happyIn233 (runECP_PV happy_var_1 >>= \ happy_var_1 -> runECP_PV happy_var_3 >>= \ happy_var_3 -> addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> return [happy_var_3,happy_var_1] )}}} happyReduce_599 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_599 = happySpecReduce_1 218# happyReduction_599 happyReduction_599 happy_x_1 = case happyOut235 happy_x_1 of { (HappyWrap235 happy_var_1) -> happyIn234 (case (unLoc happy_var_1) of [qs] -> sL1 happy_var_1 qs -- We just had one thing in our "parallel" list so -- we simply return that thing directly qss -> sL1 happy_var_1 [sL1 happy_var_1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr | qs <- qss] noExpr noSyntaxExpr] -- We actually found some actual parallel lists so -- we wrap them into as a ParStmt )} happyReduce_600 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_600 = happyMonadReduce 3# 219# happyReduction_600 happyReduction_600 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut236 happy_x_1 of { (HappyWrap236 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut235 happy_x_3 of { (HappyWrap235 happy_var_3) -> ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnVbar (gl happy_var_2) >> return (sLL happy_var_1 happy_var_3 (reverse (unLoc happy_var_1) : unLoc happy_var_3)))}}}) ) (\r -> happyReturn (happyIn235 r)) happyReduce_601 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_601 = happySpecReduce_1 219# happyReduction_601 happyReduction_601 happy_x_1 = case happyOut236 happy_x_1 of { (HappyWrap236 happy_var_1) -> happyIn235 (cL (getLoc happy_var_1) [reverse (unLoc happy_var_1)] )} happyReduce_602 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_602 = happyMonadReduce 3# 220# happyReduction_602 happyReduction_602 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut236 happy_x_1 of { (HappyWrap236 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut237 happy_x_3 of { (HappyWrap237 happy_var_3) -> ( addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> amsL (comb2 happy_var_1 happy_var_3) (fst $ unLoc happy_var_3) >> return (sLL happy_var_1 happy_var_3 [sLL happy_var_1 happy_var_3 ((snd $ unLoc happy_var_3) (reverse (unLoc happy_var_1)))]))}}}) ) (\r -> happyReturn (happyIn236 r)) happyReduce_603 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_603 = happyMonadReduce 3# 220# happyReduction_603 happyReduction_603 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut236 happy_x_1 of { (HappyWrap236 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut258 happy_x_3 of { (HappyWrap258 happy_var_3) -> ( runPV happy_var_3 >>= \ happy_var_3 -> addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))}}}) ) (\r -> happyReturn (happyIn236 r)) happyReduce_604 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_604 = happyMonadReduce 1# 220# happyReduction_604 happyReduction_604 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut237 happy_x_1 of { (HappyWrap237 happy_var_1) -> ( ams happy_var_1 (fst $ unLoc happy_var_1) >> return (sLL happy_var_1 happy_var_1 [cL (getLoc happy_var_1) ((snd $ unLoc happy_var_1) [])]))}) ) (\r -> happyReturn (happyIn236 r)) happyReduce_605 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_605 = happyMonadReduce 1# 220# happyReduction_605 happyReduction_605 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut258 happy_x_1 of { (HappyWrap258 happy_var_1) -> ( runPV happy_var_1 >>= \ happy_var_1 -> return $ sL1 happy_var_1 [happy_var_1])}) ) (\r -> happyReturn (happyIn236 r)) happyReduce_606 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_606 = happyMonadReduce 2# 221# happyReduction_606 happyReduction_606 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> return $ sLL happy_var_1 happy_var_2 ([mj AnnThen happy_var_1], \ss -> (mkTransformStmt ss happy_var_2)))}}) ) (\r -> happyReturn (happyIn237 r)) happyReduce_607 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_607 = happyMonadReduce 4# 221# happyReduction_607 happyReduction_607 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut209 happy_x_4 of { (HappyWrap209 happy_var_4) -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> runECP_P happy_var_4 >>= \ happy_var_4 -> return $ sLL happy_var_1 happy_var_4 ([mj AnnThen happy_var_1,mj AnnBy happy_var_3], \ss -> (mkTransformByStmt ss happy_var_2 happy_var_4)))}}}}) ) (\r -> happyReturn (happyIn237 r)) happyReduce_608 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_608 = happyMonadReduce 4# 221# happyReduction_608 happyReduction_608 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut209 happy_x_4 of { (HappyWrap209 happy_var_4) -> ( runECP_P happy_var_4 >>= \ happy_var_4 -> return $ sLL happy_var_1 happy_var_4 ([mj AnnThen happy_var_1,mj AnnGroup happy_var_2,mj AnnUsing happy_var_3], \ss -> (mkGroupUsingStmt ss happy_var_4)))}}}}) ) (\r -> happyReturn (happyIn237 r)) happyReduce_609 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_609 = happyMonadReduce 6# 221# happyReduction_609 happyReduction_609 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut209 happy_x_4 of { (HappyWrap209 happy_var_4) -> case happyOutTok happy_x_5 of { happy_var_5 -> case happyOut209 happy_x_6 of { (HappyWrap209 happy_var_6) -> ( runECP_P happy_var_4 >>= \ happy_var_4 -> runECP_P happy_var_6 >>= \ happy_var_6 -> return $ sLL happy_var_1 happy_var_6 ([mj AnnThen happy_var_1,mj AnnGroup happy_var_2,mj AnnBy happy_var_3,mj AnnUsing happy_var_5], \ss -> (mkGroupByUsingStmt ss happy_var_4 happy_var_6)))}}}}}}) ) (\r -> happyReturn (happyIn237 r)) happyReduce_610 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_610 = happySpecReduce_1 222# happyReduction_610 happyReduction_610 happy_x_1 = case happyOut239 happy_x_1 of { (HappyWrap239 happy_var_1) -> happyIn238 (cL (getLoc happy_var_1) (reverse (unLoc happy_var_1)) )} happyReduce_611 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_611 = happyMonadReduce 3# 223# happyReduction_611 happyReduction_611 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut239 happy_x_1 of { (HappyWrap239 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut258 happy_x_3 of { (HappyWrap258 happy_var_3) -> ( runPV happy_var_3 >>= \ happy_var_3 -> addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))}}}) ) (\r -> happyReturn (happyIn239 r)) happyReduce_612 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_612 = happyMonadReduce 1# 223# happyReduction_612 happyReduction_612 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut258 happy_x_1 of { (HappyWrap258 happy_var_1) -> ( runPV happy_var_1 >>= \ happy_var_1 -> return $ sL1 happy_var_1 [happy_var_1])}) ) (\r -> happyReturn (happyIn239 r)) happyReduce_613 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_613 = happySpecReduce_3 224# happyReduction_613 happyReduction_613 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut241 happy_x_2 of { (HappyWrap241 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn240 (happy_var_2 >>= \ happy_var_2 -> return $ sLL happy_var_1 happy_var_3 ((moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2)) ,(reverse (snd $ unLoc happy_var_2))) )}}} happyReduce_614 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_614 = happySpecReduce_3 224# happyReduction_614 happyReduction_614 happy_x_3 happy_x_2 happy_x_1 = case happyOut241 happy_x_2 of { (HappyWrap241 happy_var_2) -> happyIn240 (happy_var_2 >>= \ happy_var_2 -> return $ cL (getLoc happy_var_2) (fst $ unLoc happy_var_2 ,(reverse (snd $ unLoc happy_var_2))) )} happyReduce_615 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_615 = happySpecReduce_2 224# happyReduction_615 happyReduction_615 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> happyIn240 (return $ sLL happy_var_1 happy_var_2 ([moc happy_var_1,mcc happy_var_2],[]) )}} happyReduce_616 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_616 = happySpecReduce_2 224# happyReduction_616 happyReduction_616 happy_x_2 happy_x_1 = happyIn240 (return $ noLoc ([],[]) ) happyReduce_617 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_617 = happySpecReduce_1 225# happyReduction_617 happyReduction_617 happy_x_1 = case happyOut242 happy_x_1 of { (HappyWrap242 happy_var_1) -> happyIn241 (happy_var_1 >>= \ happy_var_1 -> return $ sL1 happy_var_1 (fst $ unLoc happy_var_1,snd $ unLoc happy_var_1) )} happyReduce_618 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_618 = happySpecReduce_2 225# happyReduction_618 happyReduction_618 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut241 happy_x_2 of { (HappyWrap241 happy_var_2) -> happyIn241 (happy_var_2 >>= \ happy_var_2 -> return $ sLL happy_var_1 happy_var_2 ((mj AnnSemi happy_var_1:(fst $ unLoc happy_var_2)) ,snd $ unLoc happy_var_2) )}} happyReduce_619 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_619 = happySpecReduce_3 226# happyReduction_619 happyReduction_619 happy_x_3 happy_x_2 happy_x_1 = case happyOut242 happy_x_1 of { (HappyWrap242 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut243 happy_x_3 of { (HappyWrap243 happy_var_3) -> happyIn242 (happy_var_1 >>= \ happy_var_1 -> happy_var_3 >>= \ happy_var_3 -> if null (snd $ unLoc happy_var_1) then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) ,[happy_var_3])) else (ams (head $ snd $ unLoc happy_var_1) (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1)) >> return (sLL happy_var_1 happy_var_3 ([],happy_var_3 : (snd $ unLoc happy_var_1))) ) )}}} happyReduce_620 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_620 = happySpecReduce_2 226# happyReduction_620 happyReduction_620 happy_x_2 happy_x_1 = case happyOut242 happy_x_1 of { (HappyWrap242 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> happyIn242 (happy_var_1 >>= \ happy_var_1 -> if null (snd $ unLoc happy_var_1) then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) ,snd $ unLoc happy_var_1)) else (ams (head $ snd $ unLoc happy_var_1) (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1)) >> return (sLL happy_var_1 happy_var_2 ([],snd $ unLoc happy_var_1))) )}} happyReduce_621 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_621 = happySpecReduce_1 226# happyReduction_621 happyReduction_621 happy_x_1 = case happyOut243 happy_x_1 of { (HappyWrap243 happy_var_1) -> happyIn242 (happy_var_1 >>= \ happy_var_1 -> return $ sL1 happy_var_1 ([],[happy_var_1]) )} happyReduce_622 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_622 = happySpecReduce_2 227# happyReduction_622 happyReduction_622 happy_x_2 happy_x_1 = case happyOut249 happy_x_1 of { (HappyWrap249 happy_var_1) -> case happyOut244 happy_x_2 of { (HappyWrap244 happy_var_2) -> happyIn243 (happy_var_2 >>= \ happy_var_2 -> ams (sLL happy_var_1 happy_var_2 (Match { m_ext = noExtField , m_ctxt = CaseAlt , m_pats = [happy_var_1] , m_grhss = snd $ unLoc happy_var_2 })) (fst $ unLoc happy_var_2) )}} happyReduce_623 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_623 = happySpecReduce_2 228# happyReduction_623 happyReduction_623 happy_x_2 happy_x_1 = case happyOut245 happy_x_1 of { (HappyWrap245 happy_var_1) -> case happyOut128 happy_x_2 of { (HappyWrap128 happy_var_2) -> happyIn244 (happy_var_1 >>= \alt -> return $ sLL alt happy_var_2 (fst $ unLoc happy_var_2, GRHSs noExtField (unLoc alt) (snd $ unLoc happy_var_2)) )}} happyReduce_624 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_624 = happySpecReduce_2 229# happyReduction_624 happyReduction_624 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> happyIn245 (runECP_PV happy_var_2 >>= \ happy_var_2 -> ams (sLL happy_var_1 happy_var_2 (unguardedRHS (comb2 happy_var_1 happy_var_2) happy_var_2)) [mu AnnRarrow happy_var_1] )}} happyReduce_625 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_625 = happySpecReduce_1 229# happyReduction_625 happyReduction_625 happy_x_1 = case happyOut246 happy_x_1 of { (HappyWrap246 happy_var_1) -> happyIn245 (happy_var_1 >>= \gdpats -> return $ sL1 gdpats (reverse (unLoc gdpats)) )} happyReduce_626 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_626 = happySpecReduce_2 230# happyReduction_626 happyReduction_626 happy_x_2 happy_x_1 = case happyOut246 happy_x_1 of { (HappyWrap246 happy_var_1) -> case happyOut248 happy_x_2 of { (HappyWrap248 happy_var_2) -> happyIn246 (happy_var_1 >>= \gdpats -> happy_var_2 >>= \gdpat -> return $ sLL gdpats gdpat (gdpat : unLoc gdpats) )}} happyReduce_627 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_627 = happySpecReduce_1 230# happyReduction_627 happyReduction_627 happy_x_1 = case happyOut248 happy_x_1 of { (HappyWrap248 happy_var_1) -> happyIn246 (happy_var_1 >>= \gdpat -> return $ sL1 gdpat [gdpat] )} happyReduce_628 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_628 = happyMonadReduce 3# 231# happyReduction_628 happyReduction_628 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut246 happy_x_2 of { (HappyWrap246 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( runPV happy_var_2 >>= \ happy_var_2 -> return $ sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3],unLoc happy_var_2))}}}) ) (\r -> happyReturn (happyIn247 r)) happyReduce_629 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_629 = happyMonadReduce 2# 231# happyReduction_629 happyReduction_629 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut246 happy_x_1 of { (HappyWrap246 happy_var_1) -> ( runPV happy_var_1 >>= \ happy_var_1 -> return $ sL1 happy_var_1 ([],unLoc happy_var_1))}) ) (\r -> happyReturn (happyIn247 r)) happyReduce_630 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_630 = happyReduce 4# 232# happyReduction_630 happyReduction_630 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut238 happy_x_2 of { (HappyWrap238 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut209 happy_x_4 of { (HappyWrap209 happy_var_4) -> happyIn248 (runECP_PV happy_var_4 >>= \ happy_var_4 -> ams (sL (comb2 happy_var_1 happy_var_4) $ GRHS noExtField (unLoc happy_var_2) happy_var_4) [mj AnnVbar happy_var_1,mu AnnRarrow happy_var_3] ) `HappyStk` happyRest}}}} happyReduce_631 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_631 = happyMonadReduce 1# 233# happyReduction_631 happyReduction_631 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut209 happy_x_1 of { (HappyWrap209 happy_var_1) -> ( (checkPattern <=< runECP_P) happy_var_1)}) ) (\r -> happyReturn (happyIn249 r)) happyReduce_632 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_632 = happyMonadReduce 2# 233# happyReduction_632 happyReduction_632 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut218 happy_x_2 of { (HappyWrap218 happy_var_2) -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> amms (checkPattern (patBuilderBang (getLoc happy_var_1) happy_var_2)) [mj AnnBang happy_var_1])}}) ) (\r -> happyReturn (happyIn249 r)) happyReduce_633 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_633 = happyMonadReduce 1# 234# happyReduction_633 happyReduction_633 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut209 happy_x_1 of { (HappyWrap209 happy_var_1) -> ( -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn checkPattern_msg (text "Possibly caused by a missing 'do'?") (runECP_PV happy_var_1))}) ) (\r -> happyReturn (happyIn250 r)) happyReduce_634 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_634 = happyMonadReduce 2# 234# happyReduction_634 happyReduction_634 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut218 happy_x_2 of { (HappyWrap218 happy_var_2) -> ( -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn amms (checkPattern_msg (text "Possibly caused by a missing 'do'?") (patBuilderBang (getLoc happy_var_1) `fmap` runECP_PV happy_var_2)) [mj AnnBang happy_var_1])}}) ) (\r -> happyReturn (happyIn250 r)) happyReduce_635 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_635 = happyMonadReduce 1# 235# happyReduction_635 happyReduction_635 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut218 happy_x_1 of { (HappyWrap218 happy_var_1) -> ( (checkPattern <=< runECP_P) happy_var_1)}) ) (\r -> happyReturn (happyIn251 r)) happyReduce_636 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_636 = happyMonadReduce 2# 235# happyReduction_636 happyReduction_636 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut218 happy_x_2 of { (HappyWrap218 happy_var_2) -> ( runECP_P happy_var_2 >>= \ happy_var_2 -> amms (checkPattern (patBuilderBang (getLoc happy_var_1) happy_var_2)) [mj AnnBang happy_var_1])}}) ) (\r -> happyReturn (happyIn251 r)) happyReduce_637 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_637 = happySpecReduce_2 236# happyReduction_637 happyReduction_637 happy_x_2 happy_x_1 = case happyOut251 happy_x_1 of { (HappyWrap251 happy_var_1) -> case happyOut252 happy_x_2 of { (HappyWrap252 happy_var_2) -> happyIn252 (happy_var_1 : happy_var_2 )}} happyReduce_638 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_638 = happySpecReduce_0 236# happyReduction_638 happyReduction_638 = happyIn252 ([] ) happyReduce_639 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_639 = happySpecReduce_3 237# happyReduction_639 happyReduction_639 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut254 happy_x_2 of { (HappyWrap254 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn253 (happy_var_2 >>= \ happy_var_2 -> return $ sLL happy_var_1 happy_var_3 ((moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2)) ,(reverse $ snd $ unLoc happy_var_2)) )}}} happyReduce_640 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_640 = happySpecReduce_3 237# happyReduction_640 happyReduction_640 happy_x_3 happy_x_2 happy_x_1 = case happyOut254 happy_x_2 of { (HappyWrap254 happy_var_2) -> happyIn253 (happy_var_2 >>= \ happy_var_2 -> return $ cL (gl happy_var_2) (fst $ unLoc happy_var_2 ,reverse $ snd $ unLoc happy_var_2) )} happyReduce_641 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_641 = happySpecReduce_3 238# happyReduction_641 happyReduction_641 happy_x_3 happy_x_2 happy_x_1 = case happyOut254 happy_x_1 of { (HappyWrap254 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut257 happy_x_3 of { (HappyWrap257 happy_var_3) -> happyIn254 (happy_var_1 >>= \ happy_var_1 -> happy_var_3 >>= \ happy_var_3 -> if null (snd $ unLoc happy_var_1) then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) ,happy_var_3 : (snd $ unLoc happy_var_1))) else do { ams (head $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] ; return $ sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1,happy_var_3 :(snd $ unLoc happy_var_1)) } )}}} happyReduce_642 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_642 = happySpecReduce_2 238# happyReduction_642 happyReduction_642 happy_x_2 happy_x_1 = case happyOut254 happy_x_1 of { (HappyWrap254 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> happyIn254 (happy_var_1 >>= \ happy_var_1 -> if null (snd $ unLoc happy_var_1) then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1),snd $ unLoc happy_var_1)) else do { ams (head $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] ; return happy_var_1 } )}} happyReduce_643 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_643 = happySpecReduce_1 238# happyReduction_643 happyReduction_643 happy_x_1 = case happyOut257 happy_x_1 of { (HappyWrap257 happy_var_1) -> happyIn254 (happy_var_1 >>= \ happy_var_1 -> return $ sL1 happy_var_1 ([],[happy_var_1]) )} happyReduce_644 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_644 = happySpecReduce_0 238# happyReduction_644 happyReduction_644 = happyIn254 (return $ noLoc ([],[]) ) happyReduce_645 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_645 = happyMonadReduce 1# 239# happyReduction_645 happyReduction_645 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut257 happy_x_1 of { (HappyWrap257 happy_var_1) -> ( fmap Just (runPV happy_var_1))}) ) (\r -> happyReturn (happyIn255 r)) happyReduce_646 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_646 = happySpecReduce_0 239# happyReduction_646 happyReduction_646 = happyIn255 (Nothing ) happyReduce_647 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_647 = happyMonadReduce 1# 240# happyReduction_647 happyReduction_647 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut257 happy_x_1 of { (HappyWrap257 happy_var_1) -> ( runPV happy_var_1)}) ) (\r -> happyReturn (happyIn256 r)) happyReduce_648 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_648 = happySpecReduce_1 241# happyReduction_648 happyReduction_648 happy_x_1 = case happyOut258 happy_x_1 of { (HappyWrap258 happy_var_1) -> happyIn257 (happy_var_1 )} happyReduce_649 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_649 = happySpecReduce_2 241# happyReduction_649 happyReduction_649 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut253 happy_x_2 of { (HappyWrap253 happy_var_2) -> happyIn257 (happy_var_2 >>= \ happy_var_2 -> ams (sLL happy_var_1 happy_var_2 $ mkRecStmt (snd $ unLoc happy_var_2)) (mj AnnRec happy_var_1:(fst $ unLoc happy_var_2)) )}} happyReduce_650 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_650 = happySpecReduce_3 242# happyReduction_650 happyReduction_650 happy_x_3 happy_x_2 happy_x_1 = case happyOut250 happy_x_1 of { (HappyWrap250 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut209 happy_x_3 of { (HappyWrap209 happy_var_3) -> happyIn258 (runECP_PV happy_var_3 >>= \ happy_var_3 -> ams (sLL happy_var_1 happy_var_3 $ mkBindStmt happy_var_1 happy_var_3) [mu AnnLarrow happy_var_2] )}}} happyReduce_651 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_651 = happySpecReduce_1 242# happyReduction_651 happyReduction_651 happy_x_1 = case happyOut209 happy_x_1 of { (HappyWrap209 happy_var_1) -> happyIn258 (runECP_PV happy_var_1 >>= \ happy_var_1 -> return $ sL1 happy_var_1 $ mkBodyStmt happy_var_1 )} happyReduce_652 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_652 = happySpecReduce_2 242# happyReduction_652 happyReduction_652 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut127 happy_x_2 of { (HappyWrap127 happy_var_2) -> happyIn258 (ams (sLL happy_var_1 happy_var_2 $ LetStmt noExtField (snd $ unLoc happy_var_2)) (mj AnnLet happy_var_1:(fst $ unLoc happy_var_2)) )}} happyReduce_653 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_653 = happySpecReduce_1 243# happyReduction_653 happyReduction_653 happy_x_1 = case happyOut260 happy_x_1 of { (HappyWrap260 happy_var_1) -> happyIn259 (happy_var_1 )} happyReduce_654 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_654 = happySpecReduce_0 243# happyReduction_654 happyReduction_654 = happyIn259 (return ([],([], Nothing)) ) happyReduce_655 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_655 = happySpecReduce_3 244# happyReduction_655 happyReduction_655 happy_x_3 happy_x_2 happy_x_1 = case happyOut261 happy_x_1 of { (HappyWrap261 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut260 happy_x_3 of { (HappyWrap260 happy_var_3) -> happyIn260 (happy_var_1 >>= \ happy_var_1 -> happy_var_3 >>= \ happy_var_3 -> addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> return (case happy_var_3 of (ma,(flds, dd)) -> (ma,(happy_var_1 : flds, dd))) )}}} happyReduce_656 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_656 = happySpecReduce_1 244# happyReduction_656 happyReduction_656 happy_x_1 = case happyOut261 happy_x_1 of { (HappyWrap261 happy_var_1) -> happyIn260 (happy_var_1 >>= \ happy_var_1 -> return ([],([happy_var_1], Nothing)) )} happyReduce_657 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_657 = happySpecReduce_1 244# happyReduction_657 happyReduction_657 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn260 (return ([mj AnnDotdot happy_var_1],([], Just (getLoc happy_var_1))) )} happyReduce_658 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_658 = happySpecReduce_3 245# happyReduction_658 happyReduction_658 happy_x_3 happy_x_2 happy_x_1 = case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut228 happy_x_3 of { (HappyWrap228 happy_var_3) -> happyIn261 (runECP_PV happy_var_3 >>= \ happy_var_3 -> ams (sLL happy_var_1 happy_var_3 $ HsRecField (sL1 happy_var_1 $ mkFieldOcc happy_var_1) happy_var_3 False) [mj AnnEqual happy_var_2] )}}} happyReduce_659 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_659 = happySpecReduce_1 245# happyReduction_659 happyReduction_659 happy_x_1 = case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> happyIn261 (placeHolderPunRhs >>= \rhs -> return $ sLL happy_var_1 happy_var_1 $ HsRecField (sL1 happy_var_1 $ mkFieldOcc happy_var_1) rhs True )} happyReduce_660 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_660 = happyMonadReduce 3# 246# happyReduction_660 happyReduction_660 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut262 happy_x_1 of { (HappyWrap262 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut263 happy_x_3 of { (HappyWrap263 happy_var_3) -> ( addAnnotation (gl $ last $ unLoc happy_var_1) AnnSemi (gl happy_var_2) >> return (let { this = happy_var_3; rest = unLoc happy_var_1 } in rest `seq` this `seq` sLL happy_var_1 happy_var_3 (this : rest)))}}}) ) (\r -> happyReturn (happyIn262 r)) happyReduce_661 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_661 = happyMonadReduce 2# 246# happyReduction_661 happyReduction_661 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut262 happy_x_1 of { (HappyWrap262 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> ( addAnnotation (gl $ last $ unLoc happy_var_1) AnnSemi (gl happy_var_2) >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))}}) ) (\r -> happyReturn (happyIn262 r)) happyReduce_662 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_662 = happySpecReduce_1 246# happyReduction_662 happyReduction_662 happy_x_1 = case happyOut263 happy_x_1 of { (HappyWrap263 happy_var_1) -> happyIn262 (let this = happy_var_1 in this `seq` sL1 happy_var_1 [this] )} happyReduce_663 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_663 = happyMonadReduce 3# 247# happyReduction_663 happyReduction_663 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut264 happy_x_1 of { (HappyWrap264 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut209 happy_x_3 of { (HappyWrap209 happy_var_3) -> ( runECP_P happy_var_3 >>= \ happy_var_3 -> ams (sLL happy_var_1 happy_var_3 (IPBind noExtField (Left happy_var_1) happy_var_3)) [mj AnnEqual happy_var_2])}}}) ) (\r -> happyReturn (happyIn263 r)) happyReduce_664 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_664 = happySpecReduce_1 248# happyReduction_664 happyReduction_664 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn264 (sL1 happy_var_1 (HsIPName (getIPDUPVARID happy_var_1)) )} happyReduce_665 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_665 = happySpecReduce_1 249# happyReduction_665 happyReduction_665 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn265 (sL1 happy_var_1 (getLABELVARID happy_var_1) )} happyReduce_666 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_666 = happySpecReduce_1 250# happyReduction_666 happyReduction_666 happy_x_1 = case happyOut267 happy_x_1 of { (HappyWrap267 happy_var_1) -> happyIn266 (happy_var_1 )} happyReduce_667 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_667 = happySpecReduce_0 250# happyReduction_667 happyReduction_667 = happyIn266 (noLoc mkTrue ) happyReduce_668 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_668 = happySpecReduce_1 251# happyReduction_668 happyReduction_668 happy_x_1 = case happyOut268 happy_x_1 of { (HappyWrap268 happy_var_1) -> happyIn267 (happy_var_1 )} happyReduce_669 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_669 = happyMonadReduce 3# 251# happyReduction_669 happyReduction_669 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut268 happy_x_1 of { (HappyWrap268 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut267 happy_x_3 of { (HappyWrap267 happy_var_3) -> ( aa happy_var_1 (AnnVbar, happy_var_2) >> return (sLL happy_var_1 happy_var_3 (Or [happy_var_1,happy_var_3])))}}}) ) (\r -> happyReturn (happyIn267 r)) happyReduce_670 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_670 = happySpecReduce_1 252# happyReduction_670 happyReduction_670 happy_x_1 = case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> happyIn268 (sLL (head happy_var_1) (last happy_var_1) (And (happy_var_1)) )} happyReduce_671 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_671 = happySpecReduce_1 253# happyReduction_671 happyReduction_671 happy_x_1 = case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> happyIn269 ([happy_var_1] )} happyReduce_672 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_672 = happyMonadReduce 3# 253# happyReduction_672 happyReduction_672 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut269 happy_x_3 of { (HappyWrap269 happy_var_3) -> ( aa happy_var_1 (AnnComma, happy_var_2) >> return (happy_var_1 : happy_var_3))}}}) ) (\r -> happyReturn (happyIn269 r)) happyReduce_673 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_673 = happyMonadReduce 3# 254# happyReduction_673 happyReduction_673 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut267 happy_x_2 of { (HappyWrap267 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (Parens happy_var_2)) [mop happy_var_1,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn270 r)) happyReduce_674 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_674 = happySpecReduce_1 254# happyReduction_674 happyReduction_674 happy_x_1 = case happyOut272 happy_x_1 of { (HappyWrap272 happy_var_1) -> happyIn270 (sL1 happy_var_1 (Var happy_var_1) )} happyReduce_675 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_675 = happySpecReduce_1 255# happyReduction_675 happyReduction_675 happy_x_1 = case happyOut272 happy_x_1 of { (HappyWrap272 happy_var_1) -> happyIn271 (sL1 happy_var_1 [happy_var_1] )} happyReduce_676 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_676 = happyMonadReduce 3# 255# happyReduction_676 happyReduction_676 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut272 happy_x_1 of { (HappyWrap272 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut271 happy_x_3 of { (HappyWrap271 happy_var_3) -> ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> return (sLL happy_var_1 happy_var_3 (happy_var_1 : unLoc happy_var_3)))}}}) ) (\r -> happyReturn (happyIn271 r)) happyReduce_677 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_677 = happySpecReduce_1 256# happyReduction_677 happyReduction_677 happy_x_1 = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> happyIn272 (happy_var_1 )} happyReduce_678 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_678 = happySpecReduce_1 256# happyReduction_678 happyReduction_678 happy_x_1 = case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> happyIn272 (happy_var_1 )} happyReduce_679 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_679 = happySpecReduce_1 257# happyReduction_679 happyReduction_679 happy_x_1 = case happyOut275 happy_x_1 of { (HappyWrap275 happy_var_1) -> happyIn273 (happy_var_1 )} happyReduce_680 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_680 = happySpecReduce_1 257# happyReduction_680 happyReduction_680 happy_x_1 = case happyOut278 happy_x_1 of { (HappyWrap278 happy_var_1) -> happyIn273 (sL1 happy_var_1 $ nameRdrName (dataConName (unLoc happy_var_1)) )} happyReduce_681 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_681 = happySpecReduce_1 258# happyReduction_681 happyReduction_681 happy_x_1 = case happyOut275 happy_x_1 of { (HappyWrap275 happy_var_1) -> happyIn274 (happy_var_1 )} happyReduce_682 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_682 = happySpecReduce_1 258# happyReduction_682 happyReduction_682 happy_x_1 = case happyOut279 happy_x_1 of { (HappyWrap279 happy_var_1) -> happyIn274 (sL1 happy_var_1 $ nameRdrName (dataConName (unLoc happy_var_1)) )} happyReduce_683 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_683 = happySpecReduce_1 259# happyReduction_683 happyReduction_683 happy_x_1 = case happyOut313 happy_x_1 of { (HappyWrap313 happy_var_1) -> happyIn275 (happy_var_1 )} happyReduce_684 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_684 = happyMonadReduce 3# 259# happyReduction_684 happyReduction_684 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut315 happy_x_2 of { (HappyWrap315 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn275 r)) happyReduce_685 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_685 = happySpecReduce_1 260# happyReduction_685 happyReduction_685 happy_x_1 = case happyOut314 happy_x_1 of { (HappyWrap314 happy_var_1) -> happyIn276 (happy_var_1 )} happyReduce_686 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_686 = happyMonadReduce 3# 260# happyReduction_686 happyReduction_686 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn276 r)) happyReduce_687 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_687 = happySpecReduce_1 260# happyReduction_687 happyReduction_687 happy_x_1 = case happyOut279 happy_x_1 of { (HappyWrap279 happy_var_1) -> happyIn276 (sL1 happy_var_1 $ nameRdrName (dataConName (unLoc happy_var_1)) )} happyReduce_688 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_688 = happySpecReduce_1 261# happyReduction_688 happyReduction_688 happy_x_1 = case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> happyIn277 (sL1 happy_var_1 [happy_var_1] )} happyReduce_689 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_689 = happyMonadReduce 3# 261# happyReduction_689 happyReduction_689 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut277 happy_x_3 of { (HappyWrap277 happy_var_3) -> ( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> return (sLL happy_var_1 happy_var_3 (happy_var_1 : unLoc happy_var_3)))}}}) ) (\r -> happyReturn (happyIn277 r)) happyReduce_690 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_690 = happyMonadReduce 2# 262# happyReduction_690 happyReduction_690 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> ( ams (sLL happy_var_1 happy_var_2 unitDataCon) [mop happy_var_1,mcp happy_var_2])}}) ) (\r -> happyReturn (happyIn278 r)) happyReduce_691 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_691 = happyMonadReduce 3# 262# happyReduction_691 happyReduction_691 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut320 happy_x_2 of { (HappyWrap320 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ tupleDataCon Boxed (snd happy_var_2 + 1)) (mop happy_var_1:mcp happy_var_3:(mcommas (fst happy_var_2))))}}}) ) (\r -> happyReturn (happyIn278 r)) happyReduce_692 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_692 = happyMonadReduce 2# 262# happyReduction_692 happyReduction_692 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> ( ams (sLL happy_var_1 happy_var_2 $ unboxedUnitDataCon) [mo happy_var_1,mc happy_var_2])}}) ) (\r -> happyReturn (happyIn278 r)) happyReduce_693 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_693 = happyMonadReduce 3# 262# happyReduction_693 happyReduction_693 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut320 happy_x_2 of { (HappyWrap320 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ tupleDataCon Unboxed (snd happy_var_2 + 1)) (mo happy_var_1:mc happy_var_3:(mcommas (fst happy_var_2))))}}}) ) (\r -> happyReturn (happyIn278 r)) happyReduce_694 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_694 = happySpecReduce_1 263# happyReduction_694 happyReduction_694 happy_x_1 = case happyOut278 happy_x_1 of { (HappyWrap278 happy_var_1) -> happyIn279 (happy_var_1 )} happyReduce_695 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_695 = happyMonadReduce 2# 263# happyReduction_695 happyReduction_695 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> ( ams (sLL happy_var_1 happy_var_2 nilDataCon) [mos happy_var_1,mcs happy_var_2])}}) ) (\r -> happyReturn (happyIn279 r)) happyReduce_696 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_696 = happySpecReduce_1 264# happyReduction_696 happyReduction_696 happy_x_1 = case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> happyIn280 (happy_var_1 )} happyReduce_697 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_697 = happyMonadReduce 3# 264# happyReduction_697 happyReduction_697 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut314 happy_x_2 of { (HappyWrap314 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 ,mj AnnBackquote happy_var_3])}}}) ) (\r -> happyReturn (happyIn280 r)) happyReduce_698 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_698 = happySpecReduce_1 265# happyReduction_698 happyReduction_698 happy_x_1 = case happyOut315 happy_x_1 of { (HappyWrap315 happy_var_1) -> happyIn281 (happy_var_1 )} happyReduce_699 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_699 = happyMonadReduce 3# 265# happyReduction_699 happyReduction_699 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut313 happy_x_2 of { (HappyWrap313 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 ,mj AnnBackquote happy_var_3])}}}) ) (\r -> happyReturn (happyIn281 r)) happyReduce_700 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_700 = happySpecReduce_1 266# happyReduction_700 happyReduction_700 happy_x_1 = case happyOut283 happy_x_1 of { (HappyWrap283 happy_var_1) -> happyIn282 (happy_var_1 )} happyReduce_701 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_701 = happyMonadReduce 2# 266# happyReduction_701 happyReduction_701 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> ( ams (sLL happy_var_1 happy_var_2 $ getRdrName unitTyCon) [mop happy_var_1,mcp happy_var_2])}}) ) (\r -> happyReturn (happyIn282 r)) happyReduce_702 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_702 = happyMonadReduce 2# 266# happyReduction_702 happyReduction_702 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> ( ams (sLL happy_var_1 happy_var_2 $ getRdrName unboxedUnitTyCon) [mo happy_var_1,mc happy_var_2])}}) ) (\r -> happyReturn (happyIn282 r)) happyReduce_703 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_703 = happySpecReduce_1 267# happyReduction_703 happyReduction_703 happy_x_1 = case happyOut284 happy_x_1 of { (HappyWrap284 happy_var_1) -> happyIn283 (happy_var_1 )} happyReduce_704 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_704 = happyMonadReduce 3# 267# happyReduction_704 happyReduction_704 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut320 happy_x_2 of { (HappyWrap320 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ getRdrName (tupleTyCon Boxed (snd happy_var_2 + 1))) (mop happy_var_1:mcp happy_var_3:(mcommas (fst happy_var_2))))}}}) ) (\r -> happyReturn (happyIn283 r)) happyReduce_705 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_705 = happyMonadReduce 3# 267# happyReduction_705 happyReduction_705 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut320 happy_x_2 of { (HappyWrap320 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ getRdrName (tupleTyCon Unboxed (snd happy_var_2 + 1))) (mo happy_var_1:mc happy_var_3:(mcommas (fst happy_var_2))))}}}) ) (\r -> happyReturn (happyIn283 r)) happyReduce_706 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_706 = happyMonadReduce 3# 267# happyReduction_706 happyReduction_706 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ getRdrName funTyCon) [mop happy_var_1,mu AnnRarrow happy_var_2,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn283 r)) happyReduce_707 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_707 = happyMonadReduce 2# 267# happyReduction_707 happyReduction_707 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> ( ams (sLL happy_var_1 happy_var_2 $ listTyCon_RDR) [mos happy_var_1,mcs happy_var_2])}}) ) (\r -> happyReturn (happyIn283 r)) happyReduce_708 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_708 = happySpecReduce_1 268# happyReduction_708 happyReduction_708 happy_x_1 = case happyOut287 happy_x_1 of { (HappyWrap287 happy_var_1) -> happyIn284 (happy_var_1 )} happyReduce_709 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_709 = happyMonadReduce 3# 268# happyReduction_709 happyReduction_709 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut290 happy_x_2 of { (HappyWrap290 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn284 r)) happyReduce_710 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_710 = happySpecReduce_1 269# happyReduction_710 happyReduction_710 happy_x_1 = case happyOut287 happy_x_1 of { (HappyWrap287 happy_var_1) -> happyIn285 (happy_var_1 )} happyReduce_711 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_711 = happyMonadReduce 3# 269# happyReduction_711 happyReduction_711 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> ( let { name :: Located RdrName ; name = sL1 happy_var_2 $! mkQual tcClsName (getQCONSYM happy_var_2) } in ams (sLL happy_var_1 happy_var_3 (unLoc name)) [mop happy_var_1,mj AnnVal name,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn285 r)) happyReduce_712 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_712 = happyMonadReduce 3# 269# happyReduction_712 happyReduction_712 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> ( let { name :: Located RdrName ; name = sL1 happy_var_2 $! mkUnqual tcClsName (getCONSYM happy_var_2) } in ams (sLL happy_var_1 happy_var_3 (unLoc name)) [mop happy_var_1,mj AnnVal name,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn285 r)) happyReduce_713 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_713 = happyMonadReduce 3# 269# happyReduction_713 happyReduction_713 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> ( let { name :: Located RdrName ; name = sL1 happy_var_2 $! consDataCon_RDR } in ams (sLL happy_var_1 happy_var_3 (unLoc name)) [mop happy_var_1,mj AnnVal name,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn285 r)) happyReduce_714 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_714 = happyMonadReduce 3# 269# happyReduction_714 happyReduction_714 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 $ eqTyCon_RDR) [mop happy_var_1,mj AnnTilde happy_var_2,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn285 r)) happyReduce_715 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_715 = happySpecReduce_1 270# happyReduction_715 happyReduction_715 happy_x_1 = case happyOut290 happy_x_1 of { (HappyWrap290 happy_var_1) -> happyIn286 (happy_var_1 )} happyReduce_716 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_716 = happyMonadReduce 3# 270# happyReduction_716 happyReduction_716 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut287 happy_x_2 of { (HappyWrap287 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 ,mj AnnBackquote happy_var_3])}}}) ) (\r -> happyReturn (happyIn286 r)) happyReduce_717 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_717 = happySpecReduce_1 271# happyReduction_717 happyReduction_717 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn287 (sL1 happy_var_1 $! mkQual tcClsName (getQCONID happy_var_1) )} happyReduce_718 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_718 = happySpecReduce_1 271# happyReduction_718 happyReduction_718 happy_x_1 = case happyOut289 happy_x_1 of { (HappyWrap289 happy_var_1) -> happyIn287 (happy_var_1 )} happyReduce_719 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_719 = happySpecReduce_1 272# happyReduction_719 happyReduction_719 happy_x_1 = case happyOut287 happy_x_1 of { (HappyWrap287 happy_var_1) -> happyIn288 (sL1 happy_var_1 (HsTyVar noExtField NotPromoted happy_var_1) )} happyReduce_720 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_720 = happySpecReduce_2 272# happyReduction_720 happyReduction_720 happy_x_2 happy_x_1 = case happyOut287 happy_x_1 of { (HappyWrap287 happy_var_1) -> case happyOut324 happy_x_2 of { (HappyWrap324 happy_var_2) -> happyIn288 (sLL happy_var_1 happy_var_2 (HsDocTy noExtField (sL1 happy_var_1 (HsTyVar noExtField NotPromoted happy_var_1)) happy_var_2) )}} happyReduce_721 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_721 = happySpecReduce_1 273# happyReduction_721 happyReduction_721 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn289 (sL1 happy_var_1 $! mkUnqual tcClsName (getCONID happy_var_1) )} happyReduce_722 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_722 = happySpecReduce_1 274# happyReduction_722 happyReduction_722 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn290 (sL1 happy_var_1 $! mkQual tcClsName (getQCONSYM happy_var_1) )} happyReduce_723 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_723 = happySpecReduce_1 274# happyReduction_723 happyReduction_723 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn290 (sL1 happy_var_1 $! mkQual tcClsName (getQVARSYM happy_var_1) )} happyReduce_724 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_724 = happySpecReduce_1 274# happyReduction_724 happyReduction_724 happy_x_1 = case happyOut291 happy_x_1 of { (HappyWrap291 happy_var_1) -> happyIn290 (happy_var_1 )} happyReduce_725 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_725 = happySpecReduce_1 275# happyReduction_725 happyReduction_725 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn291 (sL1 happy_var_1 $! mkUnqual tcClsName (getCONSYM happy_var_1) )} happyReduce_726 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_726 = happySpecReduce_1 275# happyReduction_726 happyReduction_726 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn291 (sL1 happy_var_1 $! mkUnqual tcClsName (getVARSYM happy_var_1) )} happyReduce_727 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_727 = happySpecReduce_1 275# happyReduction_727 happyReduction_727 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn291 (sL1 happy_var_1 $! consDataCon_RDR )} happyReduce_728 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_728 = happySpecReduce_1 275# happyReduction_728 happyReduction_728 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn291 (sL1 happy_var_1 $! mkUnqual tcClsName (fsLit "-") )} happyReduce_729 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_729 = happySpecReduce_1 275# happyReduction_729 happyReduction_729 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn291 (sL1 happy_var_1 $! mkUnqual tcClsName (fsLit "!") )} happyReduce_730 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_730 = happySpecReduce_1 275# happyReduction_730 happyReduction_730 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn291 (sL1 happy_var_1 $! mkUnqual tcClsName (fsLit ".") )} happyReduce_731 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_731 = happySpecReduce_1 275# happyReduction_731 happyReduction_731 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn291 (sL1 happy_var_1 $ eqTyCon_RDR )} happyReduce_732 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_732 = happySpecReduce_1 276# happyReduction_732 happyReduction_732 happy_x_1 = case happyOut293 happy_x_1 of { (HappyWrap293 happy_var_1) -> happyIn292 (happy_var_1 )} happyReduce_733 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_733 = happySpecReduce_1 276# happyReduction_733 happyReduction_733 happy_x_1 = case happyOut280 happy_x_1 of { (HappyWrap280 happy_var_1) -> happyIn292 (happy_var_1 )} happyReduce_734 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_734 = happySpecReduce_1 276# happyReduction_734 happyReduction_734 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn292 (sL1 happy_var_1 $ getRdrName funTyCon )} happyReduce_735 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_735 = happySpecReduce_1 276# happyReduction_735 happyReduction_735 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn292 (sL1 happy_var_1 $ eqTyCon_RDR )} happyReduce_736 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_736 = happySpecReduce_1 277# happyReduction_736 happyReduction_736 happy_x_1 = case happyOut309 happy_x_1 of { (HappyWrap309 happy_var_1) -> happyIn293 (happy_var_1 )} happyReduce_737 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_737 = happyMonadReduce 3# 277# happyReduction_737 happyReduction_737 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut305 happy_x_2 of { (HappyWrap305 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 ,mj AnnBackquote happy_var_3])}}}) ) (\r -> happyReturn (happyIn293 r)) happyReduce_738 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_738 = happySpecReduce_1 278# happyReduction_738 happyReduction_738 happy_x_1 = case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> happyIn294 (mkHsVarOpPV happy_var_1 )} happyReduce_739 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_739 = happySpecReduce_1 278# happyReduction_739 happyReduction_739 happy_x_1 = case happyOut281 happy_x_1 of { (HappyWrap281 happy_var_1) -> happyIn294 (mkHsConOpPV happy_var_1 )} happyReduce_740 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_740 = happySpecReduce_1 278# happyReduction_740 happyReduction_740 happy_x_1 = case happyOut296 happy_x_1 of { (HappyWrap296 happy_var_1) -> happyIn294 (happy_var_1 )} happyReduce_741 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_741 = happySpecReduce_1 279# happyReduction_741 happyReduction_741 happy_x_1 = case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> happyIn295 (mkHsVarOpPV happy_var_1 )} happyReduce_742 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_742 = happySpecReduce_1 279# happyReduction_742 happyReduction_742 happy_x_1 = case happyOut281 happy_x_1 of { (HappyWrap281 happy_var_1) -> happyIn295 (mkHsConOpPV happy_var_1 )} happyReduce_743 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_743 = happySpecReduce_1 279# happyReduction_743 happyReduction_743 happy_x_1 = case happyOut296 happy_x_1 of { (HappyWrap296 happy_var_1) -> happyIn295 (happy_var_1 )} happyReduce_744 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_744 = happySpecReduce_3 280# happyReduction_744 happyReduction_744 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> happyIn296 (amms (mkHsInfixHolePV (comb2 happy_var_1 happy_var_3)) [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 ,mj AnnBackquote happy_var_3] )}}} happyReduce_745 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_745 = happySpecReduce_1 281# happyReduction_745 happyReduction_745 happy_x_1 = case happyOut306 happy_x_1 of { (HappyWrap306 happy_var_1) -> happyIn297 (happy_var_1 )} happyReduce_746 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_746 = happyMonadReduce 3# 281# happyReduction_746 happyReduction_746 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut304 happy_x_2 of { (HappyWrap304 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 ,mj AnnBackquote happy_var_3])}}}) ) (\r -> happyReturn (happyIn297 r)) happyReduce_747 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_747 = happySpecReduce_1 282# happyReduction_747 happyReduction_747 happy_x_1 = case happyOut307 happy_x_1 of { (HappyWrap307 happy_var_1) -> happyIn298 (happy_var_1 )} happyReduce_748 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_748 = happyMonadReduce 3# 282# happyReduction_748 happyReduction_748 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut304 happy_x_2 of { (HappyWrap304 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 ,mj AnnBackquote happy_var_3])}}}) ) (\r -> happyReturn (happyIn298 r)) happyReduce_749 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_749 = happySpecReduce_1 283# happyReduction_749 happyReduction_749 happy_x_1 = case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> happyIn299 (happy_var_1 )} happyReduce_750 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_750 = happyMonadReduce 3# 284# happyReduction_750 happyReduction_750 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut301 happy_x_2 of { (HappyWrap301 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 ,mj AnnBackquote happy_var_3])}}}) ) (\r -> happyReturn (happyIn300 r)) happyReduce_751 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_751 = happySpecReduce_1 285# happyReduction_751 happyReduction_751 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn301 (sL1 happy_var_1 $! mkUnqual tvName (getVARID happy_var_1) )} happyReduce_752 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_752 = happySpecReduce_1 285# happyReduction_752 happyReduction_752 happy_x_1 = case happyOut311 happy_x_1 of { (HappyWrap311 happy_var_1) -> happyIn301 (sL1 happy_var_1 $! mkUnqual tvName (unLoc happy_var_1) )} happyReduce_753 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_753 = happySpecReduce_1 285# happyReduction_753 happyReduction_753 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn301 (sL1 happy_var_1 $! mkUnqual tvName (fsLit "unsafe") )} happyReduce_754 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_754 = happySpecReduce_1 285# happyReduction_754 happyReduction_754 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn301 (sL1 happy_var_1 $! mkUnqual tvName (fsLit "safe") )} happyReduce_755 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_755 = happySpecReduce_1 285# happyReduction_755 happyReduction_755 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn301 (sL1 happy_var_1 $! mkUnqual tvName (fsLit "interruptible") )} happyReduce_756 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_756 = happySpecReduce_1 286# happyReduction_756 happyReduction_756 happy_x_1 = case happyOut305 happy_x_1 of { (HappyWrap305 happy_var_1) -> happyIn302 (happy_var_1 )} happyReduce_757 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_757 = happyMonadReduce 3# 286# happyReduction_757 happyReduction_757 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut309 happy_x_2 of { (HappyWrap309 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn302 r)) happyReduce_758 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_758 = happySpecReduce_1 287# happyReduction_758 happyReduction_758 happy_x_1 = case happyOut304 happy_x_1 of { (HappyWrap304 happy_var_1) -> happyIn303 (happy_var_1 )} happyReduce_759 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_759 = happyMonadReduce 3# 287# happyReduction_759 happyReduction_759 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut309 happy_x_2 of { (HappyWrap309 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn303 r)) happyReduce_760 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_760 = happyMonadReduce 3# 287# happyReduction_760 happyReduction_760 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut308 happy_x_2 of { (HappyWrap308 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> ( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])}}}) ) (\r -> happyReturn (happyIn303 r)) happyReduce_761 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_761 = happySpecReduce_1 288# happyReduction_761 happyReduction_761 happy_x_1 = case happyOut305 happy_x_1 of { (HappyWrap305 happy_var_1) -> happyIn304 (happy_var_1 )} happyReduce_762 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_762 = happySpecReduce_1 288# happyReduction_762 happyReduction_762 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn304 (sL1 happy_var_1 $! mkQual varName (getQVARID happy_var_1) )} happyReduce_763 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_763 = happySpecReduce_1 289# happyReduction_763 happyReduction_763 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn305 (sL1 happy_var_1 $! mkUnqual varName (getVARID happy_var_1) )} happyReduce_764 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_764 = happySpecReduce_1 289# happyReduction_764 happyReduction_764 happy_x_1 = case happyOut311 happy_x_1 of { (HappyWrap311 happy_var_1) -> happyIn305 (sL1 happy_var_1 $! mkUnqual varName (unLoc happy_var_1) )} happyReduce_765 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_765 = happySpecReduce_1 289# happyReduction_765 happyReduction_765 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn305 (sL1 happy_var_1 $! mkUnqual varName (fsLit "unsafe") )} happyReduce_766 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_766 = happySpecReduce_1 289# happyReduction_766 happyReduction_766 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn305 (sL1 happy_var_1 $! mkUnqual varName (fsLit "safe") )} happyReduce_767 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_767 = happySpecReduce_1 289# happyReduction_767 happyReduction_767 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn305 (sL1 happy_var_1 $! mkUnqual varName (fsLit "interruptible") )} happyReduce_768 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_768 = happySpecReduce_1 289# happyReduction_768 happyReduction_768 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn305 (sL1 happy_var_1 $! mkUnqual varName (fsLit "forall") )} happyReduce_769 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_769 = happySpecReduce_1 289# happyReduction_769 happyReduction_769 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn305 (sL1 happy_var_1 $! mkUnqual varName (fsLit "family") )} happyReduce_770 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_770 = happySpecReduce_1 289# happyReduction_770 happyReduction_770 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn305 (sL1 happy_var_1 $! mkUnqual varName (fsLit "role") )} happyReduce_771 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_771 = happySpecReduce_1 290# happyReduction_771 happyReduction_771 happy_x_1 = case happyOut309 happy_x_1 of { (HappyWrap309 happy_var_1) -> happyIn306 (happy_var_1 )} happyReduce_772 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_772 = happySpecReduce_1 290# happyReduction_772 happyReduction_772 happy_x_1 = case happyOut308 happy_x_1 of { (HappyWrap308 happy_var_1) -> happyIn306 (happy_var_1 )} happyReduce_773 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_773 = happySpecReduce_1 291# happyReduction_773 happyReduction_773 happy_x_1 = case happyOut310 happy_x_1 of { (HappyWrap310 happy_var_1) -> happyIn307 (happy_var_1 )} happyReduce_774 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_774 = happySpecReduce_1 291# happyReduction_774 happyReduction_774 happy_x_1 = case happyOut308 happy_x_1 of { (HappyWrap308 happy_var_1) -> happyIn307 (happy_var_1 )} happyReduce_775 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_775 = happySpecReduce_1 292# happyReduction_775 happyReduction_775 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn308 (sL1 happy_var_1 $ mkQual varName (getQVARSYM happy_var_1) )} happyReduce_776 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_776 = happySpecReduce_1 293# happyReduction_776 happyReduction_776 happy_x_1 = case happyOut310 happy_x_1 of { (HappyWrap310 happy_var_1) -> happyIn309 (happy_var_1 )} happyReduce_777 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_777 = happySpecReduce_1 293# happyReduction_777 happyReduction_777 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn309 (sL1 happy_var_1 $ mkUnqual varName (fsLit "-") )} happyReduce_778 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_778 = happySpecReduce_1 294# happyReduction_778 happyReduction_778 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn310 (sL1 happy_var_1 $ mkUnqual varName (getVARSYM happy_var_1) )} happyReduce_779 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_779 = happySpecReduce_1 294# happyReduction_779 happyReduction_779 happy_x_1 = case happyOut312 happy_x_1 of { (HappyWrap312 happy_var_1) -> happyIn310 (sL1 happy_var_1 $ mkUnqual varName (unLoc happy_var_1) )} happyReduce_780 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_780 = happySpecReduce_1 295# happyReduction_780 happyReduction_780 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "as") )} happyReduce_781 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_781 = happySpecReduce_1 295# happyReduction_781 happyReduction_781 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "qualified") )} happyReduce_782 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_782 = happySpecReduce_1 295# happyReduction_782 happyReduction_782 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "hiding") )} happyReduce_783 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_783 = happySpecReduce_1 295# happyReduction_783 happyReduction_783 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "export") )} happyReduce_784 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_784 = happySpecReduce_1 295# happyReduction_784 happyReduction_784 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "label") )} happyReduce_785 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_785 = happySpecReduce_1 295# happyReduction_785 happyReduction_785 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "dynamic") )} happyReduce_786 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_786 = happySpecReduce_1 295# happyReduction_786 happyReduction_786 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "stdcall") )} happyReduce_787 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_787 = happySpecReduce_1 295# happyReduction_787 happyReduction_787 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "ccall") )} happyReduce_788 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_788 = happySpecReduce_1 295# happyReduction_788 happyReduction_788 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "capi") )} happyReduce_789 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_789 = happySpecReduce_1 295# happyReduction_789 happyReduction_789 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "prim") )} happyReduce_790 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_790 = happySpecReduce_1 295# happyReduction_790 happyReduction_790 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "javascript") )} happyReduce_791 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_791 = happySpecReduce_1 295# happyReduction_791 happyReduction_791 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "group") )} happyReduce_792 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_792 = happySpecReduce_1 295# happyReduction_792 happyReduction_792 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "stock") )} happyReduce_793 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_793 = happySpecReduce_1 295# happyReduction_793 happyReduction_793 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "anyclass") )} happyReduce_794 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_794 = happySpecReduce_1 295# happyReduction_794 happyReduction_794 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "via") )} happyReduce_795 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_795 = happySpecReduce_1 295# happyReduction_795 happyReduction_795 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "unit") )} happyReduce_796 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_796 = happySpecReduce_1 295# happyReduction_796 happyReduction_796 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "dependency") )} happyReduce_797 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_797 = happySpecReduce_1 295# happyReduction_797 happyReduction_797 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn311 (sL1 happy_var_1 (fsLit "signature") )} happyReduce_798 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_798 = happyMonadReduce 1# 296# happyReduction_798 happyReduction_798 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( ams (sL1 happy_var_1 (fsLit "!")) [mj AnnBang happy_var_1])}) ) (\r -> happyReturn (happyIn312 r)) happyReduce_799 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_799 = happySpecReduce_1 296# happyReduction_799 happyReduction_799 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn312 (sL1 happy_var_1 (fsLit ".") )} happyReduce_800 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_800 = happySpecReduce_1 296# happyReduction_800 happyReduction_800 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn312 (sL1 happy_var_1 (fsLit (starSym (isUnicode happy_var_1))) )} happyReduce_801 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_801 = happySpecReduce_1 297# happyReduction_801 happyReduction_801 happy_x_1 = case happyOut314 happy_x_1 of { (HappyWrap314 happy_var_1) -> happyIn313 (happy_var_1 )} happyReduce_802 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_802 = happySpecReduce_1 297# happyReduction_802 happyReduction_802 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn313 (sL1 happy_var_1 $! mkQual dataName (getQCONID happy_var_1) )} happyReduce_803 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_803 = happySpecReduce_1 298# happyReduction_803 happyReduction_803 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn314 (sL1 happy_var_1 $ mkUnqual dataName (getCONID happy_var_1) )} happyReduce_804 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_804 = happySpecReduce_1 299# happyReduction_804 happyReduction_804 happy_x_1 = case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> happyIn315 (happy_var_1 )} happyReduce_805 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_805 = happySpecReduce_1 299# happyReduction_805 happyReduction_805 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn315 (sL1 happy_var_1 $ mkQual dataName (getQCONSYM happy_var_1) )} happyReduce_806 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_806 = happySpecReduce_1 300# happyReduction_806 happyReduction_806 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn316 (sL1 happy_var_1 $ mkUnqual dataName (getCONSYM happy_var_1) )} happyReduce_807 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_807 = happySpecReduce_1 300# happyReduction_807 happyReduction_807 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn316 (sL1 happy_var_1 $ consDataCon_RDR )} happyReduce_808 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_808 = happySpecReduce_1 301# happyReduction_808 happyReduction_808 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn317 (sL1 happy_var_1 $ HsChar (getCHARs happy_var_1) $ getCHAR happy_var_1 )} happyReduce_809 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_809 = happySpecReduce_1 301# happyReduction_809 happyReduction_809 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn317 (sL1 happy_var_1 $ HsString (getSTRINGs happy_var_1) $ getSTRING happy_var_1 )} happyReduce_810 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_810 = happySpecReduce_1 301# happyReduction_810 happyReduction_810 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn317 (sL1 happy_var_1 $ HsIntPrim (getPRIMINTEGERs happy_var_1) $ getPRIMINTEGER happy_var_1 )} happyReduce_811 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_811 = happySpecReduce_1 301# happyReduction_811 happyReduction_811 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn317 (sL1 happy_var_1 $ HsWordPrim (getPRIMWORDs happy_var_1) $ getPRIMWORD happy_var_1 )} happyReduce_812 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_812 = happySpecReduce_1 301# happyReduction_812 happyReduction_812 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn317 (sL1 happy_var_1 $ HsCharPrim (getPRIMCHARs happy_var_1) $ getPRIMCHAR happy_var_1 )} happyReduce_813 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_813 = happySpecReduce_1 301# happyReduction_813 happyReduction_813 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn317 (sL1 happy_var_1 $ HsStringPrim (getPRIMSTRINGs happy_var_1) $ getPRIMSTRING happy_var_1 )} happyReduce_814 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_814 = happySpecReduce_1 301# happyReduction_814 happyReduction_814 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn317 (sL1 happy_var_1 $ HsFloatPrim noExtField $ getPRIMFLOAT happy_var_1 )} happyReduce_815 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_815 = happySpecReduce_1 301# happyReduction_815 happyReduction_815 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn317 (sL1 happy_var_1 $ HsDoublePrim noExtField $ getPRIMDOUBLE happy_var_1 )} happyReduce_816 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_816 = happySpecReduce_1 302# happyReduction_816 happyReduction_816 happy_x_1 = happyIn318 (() ) happyReduce_817 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_817 = happyMonadReduce 1# 302# happyReduction_817 happyReduction_817 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((( popContext)) ) (\r -> happyReturn (happyIn318 r)) happyReduce_818 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_818 = happySpecReduce_1 303# happyReduction_818 happyReduction_818 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn319 (sL1 happy_var_1 $ mkModuleNameFS (getCONID happy_var_1) )} happyReduce_819 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_819 = happySpecReduce_1 303# happyReduction_819 happyReduction_819 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn319 (sL1 happy_var_1 $ let (mod,c) = getQCONID happy_var_1 in mkModuleNameFS (mkFastString (unpackFS mod ++ '.':unpackFS c)) )} happyReduce_820 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_820 = happySpecReduce_2 304# happyReduction_820 happyReduction_820 happy_x_2 happy_x_1 = case happyOut320 happy_x_1 of { (HappyWrap320 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> happyIn320 (((fst happy_var_1)++[gl happy_var_2],snd happy_var_1 + 1) )}} happyReduce_821 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_821 = happySpecReduce_1 304# happyReduction_821 happyReduction_821 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn320 (([gl happy_var_1],1) )} happyReduce_822 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_822 = happySpecReduce_1 305# happyReduction_822 happyReduction_822 happy_x_1 = case happyOut322 happy_x_1 of { (HappyWrap322 happy_var_1) -> happyIn321 (happy_var_1 )} happyReduce_823 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_823 = happySpecReduce_0 305# happyReduction_823 happyReduction_823 = happyIn321 (([], 0) ) happyReduce_824 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_824 = happySpecReduce_2 306# happyReduction_824 happyReduction_824 happy_x_2 happy_x_1 = case happyOut322 happy_x_1 of { (HappyWrap322 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> happyIn322 (((fst happy_var_1)++[gl happy_var_2],snd happy_var_1 + 1) )}} happyReduce_825 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_825 = happySpecReduce_1 306# happyReduction_825 happyReduction_825 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn322 (([gl happy_var_1],1) )} happyReduce_826 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_826 = happyMonadReduce 1# 307# happyReduction_826 happyReduction_826 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( return (sL1 happy_var_1 (mkHsDocString (getDOCNEXT happy_var_1))))}) ) (\r -> happyReturn (happyIn323 r)) happyReduce_827 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_827 = happyMonadReduce 1# 308# happyReduction_827 happyReduction_827 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( return (sL1 happy_var_1 (mkHsDocString (getDOCPREV happy_var_1))))}) ) (\r -> happyReturn (happyIn324 r)) happyReduce_828 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_828 = happyMonadReduce 1# 309# happyReduction_828 happyReduction_828 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( let string = getDOCNAMED happy_var_1 (name, rest) = break isSpace string in return (sL1 happy_var_1 (name, mkHsDocString rest)))}) ) (\r -> happyReturn (happyIn325 r)) happyReduce_829 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_829 = happyMonadReduce 1# 310# happyReduction_829 happyReduction_829 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( let (n, doc) = getDOCSECTION happy_var_1 in return (sL1 happy_var_1 (n, mkHsDocString doc)))}) ) (\r -> happyReturn (happyIn326 r)) happyReduce_830 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_830 = happyMonadReduce 1# 311# happyReduction_830 happyReduction_830 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( let string = getDOCNEXT happy_var_1 in return (Just (sL1 happy_var_1 (mkHsDocString string))))}) ) (\r -> happyReturn (happyIn327 r)) happyReduce_831 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_831 = happySpecReduce_1 312# happyReduction_831 happyReduction_831 happy_x_1 = case happyOut324 happy_x_1 of { (HappyWrap324 happy_var_1) -> happyIn328 (Just happy_var_1 )} happyReduce_832 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_832 = happySpecReduce_0 312# happyReduction_832 happyReduction_832 = happyIn328 (Nothing ) happyReduce_833 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_833 = happySpecReduce_1 313# happyReduction_833 happyReduction_833 happy_x_1 = case happyOut323 happy_x_1 of { (HappyWrap323 happy_var_1) -> happyIn329 (Just happy_var_1 )} happyReduce_834 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_834 = happySpecReduce_0 313# happyReduction_834 happyReduction_834 = happyIn329 (Nothing ) happyNewToken action sts stk = (lexer True)(\tk -> let cont i = happyDoAction i tk action sts stk in case tk of { L _ ITeof -> happyDoAction 153# tk action sts stk; L _ ITunderscore -> cont 1#; L _ ITas -> cont 2#; L _ ITcase -> cont 3#; L _ ITclass -> cont 4#; L _ ITdata -> cont 5#; L _ ITdefault -> cont 6#; L _ ITderiving -> cont 7#; L _ ITdo -> cont 8#; L _ ITelse -> cont 9#; L _ IThiding -> cont 10#; L _ ITif -> cont 11#; L _ ITimport -> cont 12#; L _ ITin -> cont 13#; L _ ITinfix -> cont 14#; L _ ITinfixl -> cont 15#; L _ ITinfixr -> cont 16#; L _ ITinstance -> cont 17#; L _ ITlet -> cont 18#; L _ ITmodule -> cont 19#; L _ ITnewtype -> cont 20#; L _ ITof -> cont 21#; L _ ITqualified -> cont 22#; L _ ITthen -> cont 23#; L _ ITtype -> cont 24#; L _ ITwhere -> cont 25#; L _ (ITforall _) -> cont 26#; L _ ITforeign -> cont 27#; L _ ITexport -> cont 28#; L _ ITlabel -> cont 29#; L _ ITdynamic -> cont 30#; L _ ITsafe -> cont 31#; L _ ITinterruptible -> cont 32#; L _ ITunsafe -> cont 33#; L _ ITmdo -> cont 34#; L _ ITfamily -> cont 35#; L _ ITrole -> cont 36#; L _ ITstdcallconv -> cont 37#; L _ ITccallconv -> cont 38#; L _ ITcapiconv -> cont 39#; L _ ITprimcallconv -> cont 40#; L _ ITjavascriptcallconv -> cont 41#; L _ ITproc -> cont 42#; L _ ITrec -> cont 43#; L _ ITgroup -> cont 44#; L _ ITby -> cont 45#; L _ ITusing -> cont 46#; L _ ITpattern -> cont 47#; L _ ITstatic -> cont 48#; L _ ITstock -> cont 49#; L _ ITanyclass -> cont 50#; L _ ITvia -> cont 51#; L _ ITunit -> cont 52#; L _ ITsignature -> cont 53#; L _ ITdependency -> cont 54#; L _ (ITinline_prag _ _ _) -> cont 55#; L _ (ITspec_prag _) -> cont 56#; L _ (ITspec_inline_prag _ _) -> cont 57#; L _ (ITsource_prag _) -> cont 58#; L _ (ITrules_prag _) -> cont 59#; L _ (ITcore_prag _) -> cont 60#; L _ (ITscc_prag _) -> cont 61#; L _ (ITgenerated_prag _) -> cont 62#; L _ (ITdeprecated_prag _) -> cont 63#; L _ (ITwarning_prag _) -> cont 64#; L _ (ITunpack_prag _) -> cont 65#; L _ (ITnounpack_prag _) -> cont 66#; L _ (ITann_prag _) -> cont 67#; L _ (ITminimal_prag _) -> cont 68#; L _ (ITctype _) -> cont 69#; L _ (IToverlapping_prag _) -> cont 70#; L _ (IToverlappable_prag _) -> cont 71#; L _ (IToverlaps_prag _) -> cont 72#; L _ (ITincoherent_prag _) -> cont 73#; L _ (ITcomplete_prag _) -> cont 74#; L _ ITclose_prag -> cont 75#; L _ ITdotdot -> cont 76#; L _ ITcolon -> cont 77#; L _ (ITdcolon _) -> cont 78#; L _ ITequal -> cont 79#; L _ ITlam -> cont 80#; L _ ITlcase -> cont 81#; L _ ITvbar -> cont 82#; L _ (ITlarrow _) -> cont 83#; L _ (ITrarrow _) -> cont 84#; L _ ITat -> cont 85#; L _ ITtilde -> cont 86#; L _ (ITdarrow _) -> cont 87#; L _ ITminus -> cont 88#; L _ ITbang -> cont 89#; L _ (ITstar _) -> cont 90#; L _ (ITlarrowtail _) -> cont 91#; L _ (ITrarrowtail _) -> cont 92#; L _ (ITLarrowtail _) -> cont 93#; L _ (ITRarrowtail _) -> cont 94#; L _ ITdot -> cont 95#; L _ ITtypeApp -> cont 96#; L _ ITocurly -> cont 97#; L _ ITccurly -> cont 98#; L _ ITvocurly -> cont 99#; L _ ITvccurly -> cont 100#; L _ ITobrack -> cont 101#; L _ ITcbrack -> cont 102#; L _ ITopabrack -> cont 103#; L _ ITcpabrack -> cont 104#; L _ IToparen -> cont 105#; L _ ITcparen -> cont 106#; L _ IToubxparen -> cont 107#; L _ ITcubxparen -> cont 108#; L _ (IToparenbar _) -> cont 109#; L _ (ITcparenbar _) -> cont 110#; L _ ITsemi -> cont 111#; L _ ITcomma -> cont 112#; L _ ITbackquote -> cont 113#; L _ ITsimpleQuote -> cont 114#; L _ (ITvarid _) -> cont 115#; L _ (ITconid _) -> cont 116#; L _ (ITvarsym _) -> cont 117#; L _ (ITconsym _) -> cont 118#; L _ (ITqvarid _) -> cont 119#; L _ (ITqconid _) -> cont 120#; L _ (ITqvarsym _) -> cont 121#; L _ (ITqconsym _) -> cont 122#; L _ (ITdupipvarid _) -> cont 123#; L _ (ITlabelvarid _) -> cont 124#; L _ (ITchar _ _) -> cont 125#; L _ (ITstring _ _) -> cont 126#; L _ (ITinteger _) -> cont 127#; L _ (ITrational _) -> cont 128#; L _ (ITprimchar _ _) -> cont 129#; L _ (ITprimstring _ _) -> cont 130#; L _ (ITprimint _ _) -> cont 131#; L _ (ITprimword _ _) -> cont 132#; L _ (ITprimfloat _) -> cont 133#; L _ (ITprimdouble _) -> cont 134#; L _ (ITdocCommentNext _) -> cont 135#; L _ (ITdocCommentPrev _) -> cont 136#; L _ (ITdocCommentNamed _) -> cont 137#; L _ (ITdocSection _ _) -> cont 138#; L _ (ITopenExpQuote _ _) -> cont 139#; L _ ITopenPatQuote -> cont 140#; L _ ITopenTypQuote -> cont 141#; L _ ITopenDecQuote -> cont 142#; L _ (ITcloseQuote _) -> cont 143#; L _ (ITopenTExpQuote _) -> cont 144#; L _ ITcloseTExpQuote -> cont 145#; L _ (ITidEscape _) -> cont 146#; L _ ITparenEscape -> cont 147#; L _ (ITidTyEscape _) -> cont 148#; L _ ITparenTyEscape -> cont 149#; L _ ITtyQuote -> cont 150#; L _ (ITquasiQuote _) -> cont 151#; L _ (ITqQuasiQuote _) -> cont 152#; _ -> happyError' (tk, []) }) happyError_ explist 153# tk = happyError' (tk, explist) happyError_ explist _ tk = happyError' (tk, explist) happyThen :: () => P a -> (a -> P b) -> P b happyThen = (>>=) happyReturn :: () => a -> P a happyReturn = (return) happyParse :: () => Happy_GHC_Exts.Int# -> P (HappyAbsSyn ) happyNewToken :: () => Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyDoAction :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduceArr :: () => Happy_Data_Array.Array Int (Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )) happyThen1 :: () => P a -> (a -> P b) -> P b happyThen1 = happyThen happyReturn1 :: () => a -> P a happyReturn1 = happyReturn happyError' :: () => (((Located Token)), [String]) -> P a happyError' tk = (\(tokens, explist) -> happyError) tk parseModule = happySomeParser where happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (let {(HappyWrap34 x') = happyOut34 x} in x')) parseSignature = happySomeParser where happySomeParser = happyThen (happyParse 1#) (\x -> happyReturn (let {(HappyWrap33 x') = happyOut33 x} in x')) parseImport = happySomeParser where happySomeParser = happyThen (happyParse 2#) (\x -> happyReturn (let {(HappyWrap64 x') = happyOut64 x} in x')) parseStatement = happySomeParser where happySomeParser = happyThen (happyParse 3#) (\x -> happyReturn (let {(HappyWrap256 x') = happyOut256 x} in x')) parseDeclaration = happySomeParser where happySomeParser = happyThen (happyParse 4#) (\x -> happyReturn (let {(HappyWrap77 x') = happyOut77 x} in x')) parseExpression = happySomeParser where happySomeParser = happyThen (happyParse 5#) (\x -> happyReturn (let {(HappyWrap209 x') = happyOut209 x} in x')) parsePattern = happySomeParser where happySomeParser = happyThen (happyParse 6#) (\x -> happyReturn (let {(HappyWrap249 x') = happyOut249 x} in x')) parseTypeSignature = happySomeParser where happySomeParser = happyThen (happyParse 7#) (\x -> happyReturn (let {(HappyWrap205 x') = happyOut205 x} in x')) parseStmt = happySomeParser where happySomeParser = happyThen (happyParse 8#) (\x -> happyReturn (let {(HappyWrap255 x') = happyOut255 x} in x')) parseIdentifier = happySomeParser where happySomeParser = happyThen (happyParse 9#) (\x -> happyReturn (let {(HappyWrap16 x') = happyOut16 x} in x')) parseType = happySomeParser where happySomeParser = happyThen (happyParse 10#) (\x -> happyReturn (let {(HappyWrap155 x') = happyOut155 x} in x')) parseBackpack = happySomeParser where happySomeParser = happyThen (happyParse 11#) (\x -> happyReturn (let {(HappyWrap17 x') = happyOut17 x} in x')) parseHeader = happySomeParser where happySomeParser = happyThen (happyParse 12#) (\x -> happyReturn (let {(HappyWrap43 x') = happyOut43 x} in x')) happySeq = happyDoSeq happyError :: P a happyError = srcParseFail getVARID (dL->L _ (ITvarid x)) = x getCONID (dL->L _ (ITconid x)) = x getVARSYM (dL->L _ (ITvarsym x)) = x getCONSYM (dL->L _ (ITconsym x)) = x getQVARID (dL->L _ (ITqvarid x)) = x getQCONID (dL->L _ (ITqconid x)) = x getQVARSYM (dL->L _ (ITqvarsym x)) = x getQCONSYM (dL->L _ (ITqconsym x)) = x getIPDUPVARID (dL->L _ (ITdupipvarid x)) = x getLABELVARID (dL->L _ (ITlabelvarid x)) = x getCHAR (dL->L _ (ITchar _ x)) = x getSTRING (dL->L _ (ITstring _ x)) = x getINTEGER (dL->L _ (ITinteger x)) = x getRATIONAL (dL->L _ (ITrational x)) = x getPRIMCHAR (dL->L _ (ITprimchar _ x)) = x getPRIMSTRING (dL->L _ (ITprimstring _ x)) = x getPRIMINTEGER (dL->L _ (ITprimint _ x)) = x getPRIMWORD (dL->L _ (ITprimword _ x)) = x getPRIMFLOAT (dL->L _ (ITprimfloat x)) = x getPRIMDOUBLE (dL->L _ (ITprimdouble x)) = x getTH_ID_SPLICE (dL->L _ (ITidEscape x)) = x getTH_ID_TY_SPLICE (dL->L _ (ITidTyEscape x)) = x getINLINE (dL->L _ (ITinline_prag _ inl conl)) = (inl,conl) getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) getCOMPLETE_PRAGs (dL->L _ (ITcomplete_prag x)) = x getDOCNEXT (dL->L _ (ITdocCommentNext x)) = x getDOCPREV (dL->L _ (ITdocCommentPrev x)) = x getDOCNAMED (dL->L _ (ITdocCommentNamed x)) = x getDOCSECTION (dL->L _ (ITdocSection n x)) = (n, x) getINTEGERs (dL->L _ (ITinteger (IL src _ _))) = src getCHARs (dL->L _ (ITchar src _)) = src getSTRINGs (dL->L _ (ITstring src _)) = src getPRIMCHARs (dL->L _ (ITprimchar src _)) = src getPRIMSTRINGs (dL->L _ (ITprimstring src _)) = src getPRIMINTEGERs (dL->L _ (ITprimint src _)) = src getPRIMWORDs (dL->L _ (ITprimword src _)) = src -- See Note [Pragma source text] in BasicTypes for the following getINLINE_PRAGs (dL->L _ (ITinline_prag src _ _)) = src getSPEC_PRAGs (dL->L _ (ITspec_prag src)) = src getSPEC_INLINE_PRAGs (dL->L _ (ITspec_inline_prag src _)) = src getSOURCE_PRAGs (dL->L _ (ITsource_prag src)) = src getRULES_PRAGs (dL->L _ (ITrules_prag src)) = src getWARNING_PRAGs (dL->L _ (ITwarning_prag src)) = src getDEPRECATED_PRAGs (dL->L _ (ITdeprecated_prag src)) = src getSCC_PRAGs (dL->L _ (ITscc_prag src)) = src getGENERATED_PRAGs (dL->L _ (ITgenerated_prag src)) = src getCORE_PRAGs (dL->L _ (ITcore_prag src)) = src getUNPACK_PRAGs (dL->L _ (ITunpack_prag src)) = src getNOUNPACK_PRAGs (dL->L _ (ITnounpack_prag src)) = src getANN_PRAGs (dL->L _ (ITann_prag src)) = src getMINIMAL_PRAGs (dL->L _ (ITminimal_prag src)) = src getOVERLAPPABLE_PRAGs (dL->L _ (IToverlappable_prag src)) = src getOVERLAPPING_PRAGs (dL->L _ (IToverlapping_prag src)) = src getOVERLAPS_PRAGs (dL->L _ (IToverlaps_prag src)) = src getINCOHERENT_PRAGs (dL->L _ (ITincoherent_prag src)) = src getCTYPEs (dL->L _ (ITctype src)) = src getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) isUnicode :: Located Token -> Bool isUnicode (dL->L _ (ITforall iu)) = iu == UnicodeSyntax isUnicode (dL->L _ (ITdarrow iu)) = iu == UnicodeSyntax isUnicode (dL->L _ (ITdcolon iu)) = iu == UnicodeSyntax isUnicode (dL->L _ (ITlarrow iu)) = iu == UnicodeSyntax isUnicode (dL->L _ (ITrarrow iu)) = iu == UnicodeSyntax isUnicode (dL->L _ (ITlarrowtail iu)) = iu == UnicodeSyntax isUnicode (dL->L _ (ITrarrowtail iu)) = iu == UnicodeSyntax isUnicode (dL->L _ (ITLarrowtail iu)) = iu == UnicodeSyntax isUnicode (dL->L _ (ITRarrowtail iu)) = iu == UnicodeSyntax isUnicode (dL->L _ (IToparenbar iu)) = iu == UnicodeSyntax isUnicode (dL->L _ (ITcparenbar iu)) = iu == UnicodeSyntax isUnicode (dL->L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax isUnicode (dL->L _ (ITcloseQuote iu)) = iu == UnicodeSyntax isUnicode (dL->L _ (ITstar iu)) = iu == UnicodeSyntax isUnicode _ = False hasE :: Located Token -> Bool hasE (dL->L _ (ITopenExpQuote HasE _)) = True hasE (dL->L _ (ITopenTExpQuote HasE)) = True hasE _ = False getSCC :: Located Token -> P FastString getSCC lt = do let s = getSTRING lt err = "Spaces are not allowed in SCCs" -- We probably actually want to be more restrictive than this if ' ' `elem` unpackFS s then addFatalError (getLoc lt) (text err) else return s -- Utilities for combining source spans comb2 :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan comb2 a b = a `seq` b `seq` combineLocs a b comb3 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => a -> b -> c -> SrcSpan comb3 a b c = a `seq` b `seq` c `seq` combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) comb4 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c , HasSrcSpan d) => a -> b -> c -> d -> SrcSpan comb4 a b c d = a `seq` b `seq` c `seq` d `seq` (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ combineSrcSpans (getLoc c) (getLoc d)) -- strict constructor version: {-# INLINE sL #-} sL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a sL span a = span `seq` a `seq` cL span a -- See Note [Adding location info] for how these utility functions are used -- replaced last 3 CPP macros in this file {-# INLINE sL0 #-} sL0 :: HasSrcSpan a => SrcSpanLess a -> a sL0 = cL noSrcSpan -- #define L0 L noSrcSpan {-# INLINE sL1 #-} sL1 :: (HasSrcSpan a , HasSrcSpan b) => a -> SrcSpanLess b -> b sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) {-# INLINE sLL #-} sLL :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => a -> b -> SrcSpanLess c -> c sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) {- Note [Adding location info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ This is done using the three functions below, sL0, sL1 and sLL. Note that these functions were mechanically converted from the three macros that used to exist before, namely L0, L1 and LL. They each add a SrcSpan to their argument. sL0 adds 'noSrcSpan', used for empty productions -- This doesn't seem to work anymore -=chak sL1 for a production with a single token on the lhs. Grabs the SrcSpan from that token. sLL for a production with >1 token on the lhs. Makes up a SrcSpan from the first and last tokens. These suffice for the majority of cases. However, we must be especially careful with empty productions: sLL won't work if the first or last token on the lhs can represent an empty span. In these cases, we have to calculate the span using more of the tokens from the lhs, eg. | 'newtype' tycl_hdr '=' newconstr deriving { L (comb3 $1 $4 $5) (mkTyData NewType (unLoc $2) $4 (unLoc $5)) } We provide comb3 and comb4 functions which are useful in such cases. Be careful: there's no checking that you actually got this right, the only symptom will be that the SrcSpans of your syntax will be incorrect. -} -- Make a source location for the file. We're a bit lazy here and just -- make a point SrcSpan at line 1, column 0. Strictly speaking we should -- try to find the span of the whole file (ToDo). fileSrcSpan :: P SrcSpan fileSrcSpan = do l <- getRealSrcLoc; let loc = mkSrcLoc (srcLocFile l) 1 1; return (mkSrcSpan loc loc) -- Hint about the MultiWayIf extension hintMultiWayIf :: SrcSpan -> P () hintMultiWayIf span = do mwiEnabled <- getBit MultiWayIfBit unless mwiEnabled $ addError span $ text "Multi-way if-expressions need MultiWayIf turned on" -- Hint about explicit-forall hintExplicitForall :: Located Token -> P () hintExplicitForall tok = do forall <- getBit ExplicitForallBit rulePrag <- getBit InRulePragBit unless (forall || rulePrag) $ addError (getLoc tok) $ vcat [ text "Illegal symbol" <+> quotes forallSymDoc <+> text "in type" , text "Perhaps you intended to use RankNTypes or a similar language" , text "extension to enable explicit-forall syntax:" <+> forallSymDoc <+> text ". " ] where forallSymDoc = text (forallSym (isUnicode tok)) -- When two single quotes don't followed by tyvar or gtycon, we report the -- error as empty character literal, or TH quote that missing proper type -- variable or constructor. See #13450. reportEmptyDoubleQuotes :: SrcSpan -> P a reportEmptyDoubleQuotes span = do thQuotes <- getBit ThQuotesBit if thQuotes then addFatalError span $ vcat [ text "Parser error on `''`" , text "Character literals may not be empty" , text "Or perhaps you intended to use quotation syntax of TemplateHaskell," , text "but the type variable or constructor is missing" ] else addFatalError span $ vcat [ text "Parser error on `''`" , text "Character literals may not be empty" ] {- %************************************************************************ %* * Helper functions for generating annotations in the parser %* * %************************************************************************ For the general principles of the following routines, see Note [Api annotations] in ApiAnnotation.hs -} -- |Construct an AddAnn from the annotation keyword and the location -- of the keyword itself mj :: HasSrcSpan e => AnnKeywordId -> e -> AddAnn mj a l = AddAnn a (gl l) mjL :: AnnKeywordId -> SrcSpan -> AddAnn mjL = AddAnn -- |Construct an AddAnn from the annotation keyword and the Located Token. If -- the token has a unicode equivalent and this has been used, provide the -- unicode variant of the annotation. mu :: AnnKeywordId -> Located Token -> AddAnn mu a lt@(dL->L l t) = AddAnn (toUnicodeAnn a lt) l -- | If the 'Token' is using its unicode variant return the unicode variant of -- the annotation toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a gl :: HasSrcSpan a => a -> SrcSpan gl = getLoc -- |Add an annotation to the located element, and return the located -- element as a pass through aa :: (HasSrcSpan a , HasSrcSpan c) => a -> (AnnKeywordId, c) -> P a aa a@(dL->L l _) (b,s) = addAnnotation l b (gl s) >> return a -- |Add an annotation to a located element resulting from a monadic action am :: (HasSrcSpan a , HasSrcSpan b) => P a -> (AnnKeywordId, b) -> P a am a (b,s) = do av@(dL->L l _) <- a addAnnotation l b (gl s) return av -- | Add a list of AddAnns to the given AST element. For example, -- the parsing rule for @let@ looks like: -- -- @ -- | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) -- (mj AnnLet $1:mj AnnIn $3 -- :(fst $ unLoc $2)) } -- @ -- -- This adds an AnnLet annotation for @let@, an AnnIn for @in@, as well -- as any annotations that may arise in the binds. This will include open -- and closing braces if they are used to delimit the let expressions. -- ams :: (MonadP m, HasSrcSpan a) => a -> [AddAnn] -> m a ams a@(dL->L l _) bs = addAnnsAt l bs >> return a amsL :: SrcSpan -> [AddAnn] -> P () amsL sp bs = addAnnsAt sp bs >> return () -- |Add all [AddAnn] to an AST element, and wrap it in a 'Just' ajs :: (MonadP m, HasSrcSpan a) => a -> [AddAnn] -> m (Maybe a) ajs a bs = Just <$> ams a bs -- |Add a list of AddAnns to the given AST element, where the AST element is the -- result of a monadic action amms :: MonadP m => HasSrcSpan a => m a -> [AddAnn] -> m a amms a bs = do { av@(dL->L l _) <- a ; addAnnsAt l bs ; return av } -- |Add a list of AddAnns to the AST element, and return the element as a -- OrdList amsu :: HasSrcSpan a => a -> [AddAnn] -> P (OrdList a) amsu a@(dL->L l _) bs = addAnnsAt l bs >> return (unitOL a) -- |Synonyms for AddAnn versions of AnnOpen and AnnClose mo,mc :: Located Token -> AddAnn mo ll = mj AnnOpen ll mc ll = mj AnnClose ll moc,mcc :: Located Token -> AddAnn moc ll = mj AnnOpenC ll mcc ll = mj AnnCloseC ll mop,mcp :: Located Token -> AddAnn mop ll = mj AnnOpenP ll mcp ll = mj AnnCloseP ll mos,mcs :: Located Token -> AddAnn mos ll = mj AnnOpenS ll mcs ll = mj AnnCloseS ll -- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma -- entry for each SrcSpan mcommas :: [SrcSpan] -> [AddAnn] mcommas ss = map (mjL AnnCommaTuple) ss -- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar -- entry for each SrcSpan mvbars :: [SrcSpan] -> [AddAnn] mvbars ss = map (mjL AnnVbar) ss -- |Get the location of the last element of a OrdList, or noSrcSpan oll :: HasSrcSpan a => OrdList a -> SrcSpan oll l = if isNilOL l then noSrcSpan else getLoc (lastOL l) -- |Add a semicolon annotation in the right place in a list. If the -- leading list is empty, add it to the tail asl :: (HasSrcSpan a , HasSrcSpan b) => [a] -> b -> a -> P() asl [] (dL->L ls _) (dL->L l _) = addAnnotation l AnnSemi ls asl (x:_xs) (dL->L ls _) _x = addAnnotation (getLoc x) AnnSemi ls {-# LINE 1 "templates/GenericTemplate.hs" #-} -- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $ -- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. #if __GLASGOW_HASKELL__ > 706 #define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) #define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) #define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) #else #define LT(n,m) (n Happy_GHC_Exts.<# m) #define GTE(n,m) (n Happy_GHC_Exts.>=# m) #define EQ(n,m) (n Happy_GHC_Exts.==# m) #endif data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a) ----------------------------------------------------------------------------- -- starting the parse happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll ----------------------------------------------------------------------------- -- Accepting the parse -- If the current token is ERROR_TOK, it means we've just accepted a partial -- parse (a %partial parser). We must ignore the saved token on the top of -- the stack in this case. happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = happyReturn1 ans happyAccept j tk st sts (HappyStk ans _) = (happyTcHack j (happyTcHack st)) (happyReturn1 ans) ----------------------------------------------------------------------------- -- Arrays only: do the next action happyDoAction i tk st = {- nothing -} case action of 0# -> {- nothing -} happyFail (happyExpListPerState ((Happy_GHC_Exts.I# (st)) :: Int)) i tk st -1# -> {- nothing -} happyAccept i tk st n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} (happyReduceArr Happy_Data_Array.! rule) i tk st where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) n -> {- nothing -} happyShift new_state i tk st where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) where off = happyAdjustOffset (indexShortOffAddr happyActOffsets st) off_i = (off Happy_GHC_Exts.+# i) check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) then EQ(indexShortOffAddr happyCheck off_i, i) else False action | check = indexShortOffAddr happyTable off_i | otherwise = indexShortOffAddr happyDefActions st indexShortOffAddr (HappyA# arr) off = Happy_GHC_Exts.narrow16Int# i where i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) off' = off Happy_GHC_Exts.*# 2# {-# INLINE happyLt #-} happyLt x y = LT(x,y) readArrayBit arr bit = Bits.testBit (Happy_GHC_Exts.I# (indexShortOffAddr arr ((unbox_int bit) `Happy_GHC_Exts.iShiftRA#` 4#))) (bit `mod` 16) where unbox_int (Happy_GHC_Exts.I# x) = x data HappyAddr = HappyA# Happy_GHC_Exts.Addr# ----------------------------------------------------------------------------- -- HappyState data type (not arrays) ----------------------------------------------------------------------------- -- Shifting a token happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in -- trace "shifting the error token" $ happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) happyShift new_state i tk st sts stk = happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) -- happyReduce is specialised for the common cases. happySpecReduce_0 i fn 0# tk st sts stk = happyFail [] 0# tk st sts stk happySpecReduce_0 nt fn j tk st@((action)) sts stk = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) happySpecReduce_1 i fn 0# tk st sts stk = happyFail [] 0# tk st sts stk happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') = let r = fn v1 in happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) happySpecReduce_2 i fn 0# tk st sts stk = happyFail [] 0# tk st sts stk happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') = let r = fn v1 v2 in happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) happySpecReduce_3 i fn 0# tk st sts stk = happyFail [] 0# tk st sts stk happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') = let r = fn v1 v2 v3 in happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) happyReduce k i fn 0# tk st sts stk = happyFail [] 0# tk st sts stk happyReduce k nt fn j tk st sts stk = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of sts1@((HappyCons (st1@(action)) (_))) -> let r = fn stk in -- it doesn't hurt to always seq here... happyDoSeq r (happyGoto nt j tk st1 sts1 r) happyMonadReduce k nt fn 0# tk st sts stk = happyFail [] 0# tk st sts stk happyMonadReduce k nt fn j tk st sts stk = case happyDrop k (HappyCons (st) (sts)) of sts1@((HappyCons (st1@(action)) (_))) -> let drop_stk = happyDropStk k stk in happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) happyMonad2Reduce k nt fn 0# tk st sts stk = happyFail [] 0# tk st sts stk happyMonad2Reduce k nt fn j tk st sts stk = case happyDrop k (HappyCons (st) (sts)) of sts1@((HappyCons (st1@(action)) (_))) -> let drop_stk = happyDropStk k stk off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st1) off_i = (off Happy_GHC_Exts.+# nt) new_state = indexShortOffAddr happyTable off_i in happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) happyDrop 0# l = l happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t happyDropStk 0# l = l happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs ----------------------------------------------------------------------------- -- Moving to a new state after a reduction happyGoto nt j tk st = {- nothing -} happyDoAction j tk new_state where off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st) off_i = (off Happy_GHC_Exts.+# nt) new_state = indexShortOffAddr happyTable off_i ----------------------------------------------------------------------------- -- Error recovery (ERROR_TOK is the error token) -- parse error if we are in recovery and we fail again happyFail explist 0# tk old_st _ stk@(x `HappyStk` _) = let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in -- trace "failing" $ happyError_ explist i tk {- We don't need state discarding for our restricted implementation of "error". In fact, it can cause some bogus parses, so I've disabled it for now --SDM -- discard a state happyFail ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) (saved_tok `HappyStk` _ `HappyStk` stk) = -- trace ("discarding state, depth " ++ show (length stk)) $ DO_ACTION(action,ERROR_TOK,tk,sts,(saved_tok`HappyStk`stk)) -} -- Enter error recovery: generate an error token, -- save the old token and carry on. happyFail explist i tk (action) sts stk = -- trace "entering error recovery" $ happyDoAction 0# tk action sts ((Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) -- Internal happy errors: notHappyAtAll :: a notHappyAtAll = error "Internal Happy error\n" ----------------------------------------------------------------------------- -- Hack to get the typechecker to accept our action functions happyTcHack :: Happy_GHC_Exts.Int# -> a -> a happyTcHack x y = y {-# INLINE happyTcHack #-} ----------------------------------------------------------------------------- -- Seq-ing. If the --strict flag is given, then Happy emits -- happySeq = happyDoSeq -- otherwise it emits -- happySeq = happyDontSeq happyDoSeq, happyDontSeq :: a -> b -> b happyDoSeq a b = a `seq` b happyDontSeq a b = b ----------------------------------------------------------------------------- -- Don't inline any functions from the template. GHC has a nasty habit -- of deciding to inline happyGoto everywhere, which increases the size of -- the generated parser quite a bit. {-# NOINLINE happyDoAction #-} {-# NOINLINE happyTable #-} {-# NOINLINE happyCheck #-} {-# NOINLINE happyActOffsets #-} {-# NOINLINE happyGotoOffsets #-} {-# NOINLINE happyDefActions #-} {-# NOINLINE happyShift #-} {-# NOINLINE happySpecReduce_0 #-} {-# NOINLINE happySpecReduce_1 #-} {-# NOINLINE happySpecReduce_2 #-} {-# NOINLINE happySpecReduce_3 #-} {-# NOINLINE happyReduce #-} {-# NOINLINE happyMonadReduce #-} {-# NOINLINE happyGoto #-} {-# NOINLINE happyFail #-} -- end of Happy Template. ghc-lib-parser-8.10.2.20200808/ghc-lib/stage0/compiler/build/Lexer.hs0000644000000000000000000101042713713636237022525 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP,MagicHash #-} {-# LINE 43 "compiler/parser/Lexer.x" #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -funbox-strict-fields #-} module Lexer ( Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..), P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags(..), appendWarning, appendError, allocateComments, MonadP(..), getRealSrcLoc, getPState, withThisPackage, failLocMsgP, srcParseFail, getErrorMessages, getMessages, popContext, pushModuleContext, setLastToken, setSrcLoc, activeContext, nextIsEOF, getLexState, popLexState, pushLexState, ExtBits(..), xtest, lexTokenStream, AddAnn(..),mkParensApiAnn, addAnnsAt, commentToAnnotation ) where import GhcPrelude -- base import Control.Monad import Control.Monad.Fail as MonadFail import Data.Bits import Data.Char import Data.List import Data.Maybe import Data.Word import EnumSet (EnumSet) import qualified EnumSet -- ghc-boot import qualified GHC.LanguageExtensions as LangExt -- bytestring import Data.ByteString (ByteString) -- containers import Data.Map (Map) import qualified Data.Map as Map -- compiler/utils import Bag import Outputable import StringBuffer import FastString import UniqFM import Util ( readRational, readHexRational ) -- compiler/main import ErrUtils import DynFlags -- compiler/basicTypes import SrcLoc import Module import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), IntegralLit(..), FractionalLit(..), SourceText(..) ) -- compiler/parser import Ctype import ApiAnnotation #if __GLASGOW_HASKELL__ >= 603 #include "ghcconfig.h" #elif defined(__GLASGOW_HASKELL__) #include "config.h" #endif #if __GLASGOW_HASKELL__ >= 503 import Data.Array import Data.Array.Base (unsafeAt) #else import Array #endif #if __GLASGOW_HASKELL__ >= 503 import GHC.Exts #else import GlaExts #endif alex_tab_size :: Int alex_tab_size = 8 alex_base :: AlexAddr alex_base = AlexA# "\x01\x00\x00\x00\x7b\x00\x00\x00\x84\x00\x00\x00\xa0\x00\x00\x00\xbc\x00\x00\x00\xc5\x00\x00\x00\xce\x00\x00\x00\xec\x00\x00\x00\x06\x01\x00\x00\x22\x01\x00\x00\x3f\x01\x00\x00\x7b\x01\x00\x00\xd4\xff\xff\xff\x61\x00\x00\x00\xd7\xff\xff\xff\xdb\xff\xff\xff\xa4\xff\xff\xff\xaa\xff\xff\xff\xf8\x01\x00\x00\x72\x02\x00\x00\xec\x02\x00\x00\x93\xff\xff\xff\x94\xff\xff\xff\x66\x03\x00\x00\x95\xff\xff\xff\xb2\xff\xff\xff\xe7\xff\xff\xff\xe8\xff\xff\xff\xe9\xff\xff\xff\xd1\x00\x00\x00\xae\xff\xff\xff\xab\xff\xff\xff\xb0\xff\xff\xff\x59\x01\x00\x00\xdc\x03\x00\x00\xfc\x01\x00\x00\xe6\x03\x00\x00\xb3\xff\xff\xff\xba\xff\xff\xff\xac\xff\xff\xff\x3d\x01\x00\x00\x7a\x01\x00\x00\x50\x02\x00\x00\xca\x02\x00\x00\x1f\x04\x00\x00\xfa\x03\x00\x00\x59\x04\x00\x00\x95\x01\x00\x00\x05\x02\x00\x00\xaf\xff\xff\xff\xb1\xff\xff\xff\xa4\x04\x00\x00\xe5\x04\x00\x00\x63\x02\x00\x00\x44\x03\x00\x00\xdd\x02\x00\x00\xfc\x04\x00\x00\x3d\x05\x00\x00\x57\x03\x00\x00\xc5\x04\x00\x00\x1d\x05\x00\x00\x59\x05\x00\x00\x63\x05\x00\x00\x79\x05\x00\x00\x83\x05\x00\x00\x99\x05\x00\x00\xa9\x05\x00\x00\xb3\x05\x00\x00\xbd\x05\x00\x00\xc9\x05\x00\x00\xd3\x05\x00\x00\xed\x05\x00\x00\x04\x06\x00\x00\x63\x00\x00\x00\x51\x00\x00\x00\x26\x06\x00\x00\x4b\x06\x00\x00\x62\x06\x00\x00\xc4\x03\x00\x00\x6c\x00\x00\x00\x84\x06\x00\x00\xbd\x06\x00\x00\x17\x07\x00\x00\x95\x07\x00\x00\x11\x08\x00\x00\x8d\x08\x00\x00\x09\x09\x00\x00\x85\x09\x00\x00\x01\x0a\x00\x00\xb9\x00\x00\x00\x7d\x0a\x00\x00\xfb\x0a\x00\x00\x12\x00\x00\x00\x16\x00\x00\x00\x2d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\xfa\x01\x00\x00\xe0\x03\x00\x00\x67\x00\x00\x00\x9c\x00\x00\x00\x81\x00\x00\x00\x82\x00\x00\x00\x88\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x00\x00\x76\x0b\x00\x00\x9e\x0b\x00\x00\xe1\x0b\x00\x00\x09\x0c\x00\x00\x4c\x0c\x00\x00\x74\x0c\x00\x00\xb7\x0c\x00\x00\xe7\x04\x00\x00\x94\x07\x00\x00\x10\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x0c\x00\x00\x71\x0d\x00\x00\xeb\x0d\x00\x00\x65\x0e\x00\x00\xdf\x0e\x00\x00\xa8\x00\x00\x00\xa9\x00\x00\x00\x5d\x0f\x00\x00\x9d\x00\x00\x00\xd7\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x10\x00\x00\x00\x00\x00\x00\xcf\x10\x00\x00\x49\x11\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x11\x00\x00\x3d\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x12\x00\x00\x51\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x07\x14\x00\x00\x81\x14\x00\x00\xfb\x14\x00\x00\x75\x15\x00\x00\xef\x15\x00\x00\x69\x16\x00\x00\xe3\x16\x00\x00\x5d\x17\x00\x00\xd7\x17\x00\x00\x51\x18\x00\x00\xcb\x18\x00\x00\x45\x19\x00\x00\xbf\x19\x00\x00\x39\x1a\x00\x00\xa1\x00\x00\x00\xbd\x00\x00\x00\xbe\x00\x00\x00\xbf\x00\x00\x00\xc1\x00\x00\x00\xc3\x00\x00\x00\x93\x1a\x00\x00\xb6\x1a\x00\x00\x12\x1b\x00\x00\x3a\x1b\x00\x00\x5d\x1b\x00\x00\x85\x1b\x00\x00\xc8\x1b\x00\x00\xed\x1b\x00\x00\x66\x1c\x00\x00\xdf\x1c\x00\x00\x58\x1d\x00\x00\xb4\x1d\x00\x00\x58\x0b\x00\x00\xc7\x1d\x00\x00\xdd\x00\x00\x00\xbb\x06\x00\x00\x10\x1e\x00\x00\xc9\x1a\x00\x00\x35\x1e\x00\x00\x20\x01\x00\x00\x71\x07\x00\x00\x7e\x1e\x00\x00\x49\x1c\x00\x00\xf2\x07\x00\x00\xc3\x1c\x00\x00\x6e\x08\x00\x00\xbf\x1e\x00\x00\xe4\x08\x00\x00\x00\x1f\x00\x00\x60\x09\x00\x00\xc4\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# alex_table :: AlexAddr alex_table = AlexA# "\x00\x00\x64\x00\xc1\x00\xba\x00\x6d\x00\xcf\x00\x5e\x00\xa1\x00\x6e\x00\x77\x00\x60\x00\x80\x00\x5e\x00\x5e\x00\x5e\x00\x7d\x00\x8b\x00\x8c\x00\x8e\x00\x5d\x00\x15\x00\x16\x00\x18\x00\x32\x00\x19\x00\x31\x00\x1f\x00\x25\x00\x7a\x00\x11\x00\x26\x00\x10\x00\x79\x00\x5e\x00\xcf\x00\xf6\x00\xd0\x00\xd3\x00\xcf\x00\xcf\x00\xf5\x00\xaa\x00\xab\x00\xcf\x00\xcf\x00\xaf\x00\xcb\x00\xcf\x00\xcf\x00\xd6\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd4\x00\xb0\x00\xcf\x00\xcf\x00\xcf\x00\xd1\x00\xa2\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xad\x00\xcf\x00\xae\x00\xcf\x00\xbb\x00\xb1\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xb3\x00\xcd\x00\xb4\x00\xcf\x00\x5e\x00\xdc\x00\xdc\x00\xff\xff\x60\x00\x76\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x12\x00\xff\xff\xff\xff\x60\x00\x6e\x00\x5e\x00\x5e\x00\x5e\x00\xff\xff\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\x5e\x00\xd7\x00\xd7\x00\x78\x00\xff\xff\xff\xff\xff\xff\x64\x00\x20\x00\x5e\x00\x5e\x00\xff\xff\xff\xff\x0f\x00\x60\x00\x7c\x00\x5e\x00\x5e\x00\x5e\x00\x93\x00\x5c\x00\x4a\x00\x0f\x00\xff\xff\xff\xff\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x95\x00\x88\x00\x5e\x00\x5e\x00\x49\x00\x7e\x00\xc3\x00\x60\x00\x7c\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x4f\x00\x62\x00\x0f\x00\x60\x00\x7c\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x63\x00\x65\x00\x70\x00\x60\x00\xa7\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x91\x00\x8b\x00\x7e\x00\xc4\x00\xc5\x00\xc7\x00\x91\x00\xc5\x00\x5e\x00\xc8\x00\xef\x00\x7e\x00\x0f\x00\xf0\x00\xf1\x00\xf2\x00\xf4\x00\x5e\x00\x00\x00\x00\x00\x5e\x00\x0f\x00\x00\x00\x00\x00\x60\x00\x0c\x00\x5e\x00\x5e\x00\x5e\x00\x1e\x00\x0f\x00\x00\x00\x00\x00\x27\x00\x0c\x00\xe8\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x5f\x00\x5e\x00\xd7\x00\xd7\x00\x61\x00\xff\xff\x5f\x00\x5f\x00\x5f\x00\x00\x00\x00\x00\x3d\x00\x91\x00\x00\x00\x0f\x00\x00\x00\x7b\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x5f\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x5e\x00\x5e\x00\x5e\x00\x1d\x00\xa3\x00\x5e\x00\x87\x00\x00\x00\x91\x00\x3d\x00\x7b\x00\x5e\x00\x5e\x00\x5e\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x7f\x00\x5e\x00\xec\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x60\x00\x0c\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x00\x00\x0f\x00\xdc\x00\xdc\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x00\x00\x30\x00\x5e\x00\x00\x00\x00\x00\x1a\x00\x5f\x00\x30\x00\x30\x00\x30\x00\x0c\x00\xff\xff\x5f\x00\x5f\x00\x5f\x00\x0d\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\xc2\x00\xc0\x00\x5f\x00\x4a\x00\x5e\x00\x86\x00\x00\x00\x00\x00\x60\x00\x80\x00\x5e\x00\x5e\x00\x5e\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x5e\x00\x28\x00\x0c\x00\x1c\x00\x00\x00\x2f\x00\x2f\x00\x2f\x00\xa9\x00\xab\x00\x00\x00\x00\x00\xaf\x00\x0e\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x2f\x00\xb0\x00\x5a\x00\x2a\x00\x00\x00\x0c\x00\x00\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xac\x00\x00\x00\xae\x00\x29\x00\xc0\x00\xb1\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xb2\x00\x00\x00\xb4\x00\x81\x00\x81\x00\x81\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x23\x00\x12\x00\x12\x00\x12\x00\x12\x00\x23\x00\x23\x00\x23\x00\x23\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x30\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x59\x00\x00\x00\x23\x00\x8f\x00\x91\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x00\x30\x00\x00\x00\x5b\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x91\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x83\x00\x83\x00\x83\x00\x91\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x13\x00\x13\x00\x13\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x37\x00\x00\x00\x13\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x84\x00\x84\x00\x84\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x3c\x00\x00\x00\x17\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x2f\x00\x2f\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x23\x00\x23\x00\x23\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x90\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x1b\x00\x91\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x2c\x00\x2c\x00\x2c\x00\x4e\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x41\x00\x00\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x91\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x1d\x00\x2c\x00\x53\x00\x91\x00\x00\x00\x00\x00\x3d\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x35\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x35\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x6a\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x3a\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x40\x00\x00\x00\x40\x00\x00\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\x00\x00\x45\x00\x00\x00\x45\x00\x00\x00\x3f\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\x00\x00\x42\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x44\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x47\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x35\x00\x00\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x00\x00\x4c\x00\x00\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x3a\x00\x00\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xb8\x00\xb6\x00\x00\x00\x4d\x00\x00\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb7\x00\xb5\x00\x4e\x00\xc9\x00\xb6\x00\x00\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\xc9\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xb5\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\xc9\x00\xed\x00\xc9\x00\x53\x00\x53\x00\x53\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\xff\xff\x00\x00\x00\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x00\x00\x00\x00\x68\x00\x00\x00\x53\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x68\x00\xa0\x00\x54\x00\x54\x00\x54\x00\xf3\x00\x00\x00\x00\x00\x54\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x69\x00\x00\x00\x54\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x69\x00\x9f\x00\x54\x00\x54\x00\x54\x00\xf3\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x98\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x97\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x96\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x94\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x8a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5b\x00\x85\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\xff\xff\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x42\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x73\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x6c\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x89\x00\x6c\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x89\x00\x89\x00\x00\x00\x6f\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x89\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x89\x00\x89\x00\xcf\x00\x6f\x00\x89\x00\x89\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\x71\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\x71\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x81\x00\x81\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x82\x00\x82\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x83\x00\x83\x00\x83\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x84\x00\x84\x00\x84\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5b\x00\x85\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x82\x00\x82\x00\x82\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x88\x00\x88\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x8a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x83\x00\x83\x00\x83\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x13\x00\x13\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x84\x00\x84\x00\x84\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x9b\x00\x9b\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9c\x00\x9c\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x9c\x00\x00\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xa5\x00\xa5\x00\xa5\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\x00\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa6\x00\xa6\x00\xa6\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\x00\x00\x2c\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x54\x00\x54\x00\x54\x00\x56\x00\x58\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x57\x00\x54\x00\x54\x00\x54\x00\x55\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x92\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb6\x00\xb6\x00\xb6\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x00\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xbd\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xbd\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xbd\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xbd\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x45\x00\x00\x00\x00\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc1\x00\xc1\x00\xc1\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc2\x00\xc2\x00\xc2\x00\x00\x00\x00\x00\x00\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\x00\x00\x00\x00\x00\x00\xc9\x00\xc2\x00\x00\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xca\x00\x00\x00\x00\x00\xc9\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\x00\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\xc9\x00\xca\x00\xc9\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x41\x00\x00\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\xc9\x00\x00\x00\xc9\x00\xca\x00\x00\x00\xca\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\xca\x00\xcf\x00\xca\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x72\x00\xcf\x00\xcf\x00\xdb\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x2b\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\xa4\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\x8e\x00\xcf\x00\xcf\x00\x99\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x9a\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xa6\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\xa8\x00\xcf\x00\xcf\x00\x00\x00\xcc\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xa6\x00\x00\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa5\x00\xcf\x00\xcf\x00\xcf\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x42\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xa5\x00\x00\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\x9c\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x9e\x00\x3d\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x9c\x00\x00\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9b\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xd2\x00\xcf\x00\xcf\x00\x00\x00\x9d\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x9b\x00\xd4\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x00\x00\xcf\x00\xd4\x00\xcf\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\xd4\x00\xd4\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x46\x00\x00\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\xd4\x00\xea\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x4c\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x41\x00\x00\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\x4d\x00\x00\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x4a\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x47\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# alex_check :: AlexAddr alex_check = AlexA# "\xff\xff\x2d\x00\x01\x00\x02\x00\x2d\x00\x04\x00\x05\x00\x06\x00\x2d\x00\x65\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x65\x00\x7d\x00\x7d\x00\x7d\x00\x61\x00\x2d\x00\x2d\x00\x2d\x00\x69\x00\x6d\x00\x69\x00\x67\x00\x61\x00\x0a\x00\x6e\x00\x72\x00\x6e\x00\x0a\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x05\x00\x30\x00\x31\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x23\x00\x0a\x00\x0a\x00\x09\x00\x2d\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x20\x00\x30\x00\x31\x00\x23\x00\x0a\x00\x0a\x00\x0a\x00\x2d\x00\x6c\x00\x20\x00\x05\x00\x0a\x00\x0a\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x7c\x00\x21\x00\x5f\x00\x2d\x00\x0a\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x7c\x00\x23\x00\x20\x00\x05\x00\x5f\x00\x23\x00\x23\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x5f\x00\x2d\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x2d\x00\x2d\x00\x2d\x00\x09\x00\x23\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x24\x00\x7d\x00\x23\x00\x23\x00\x23\x00\x23\x00\x2a\x00\x23\x00\x20\x00\x23\x00\x23\x00\x23\x00\x2d\x00\x23\x00\x23\x00\x23\x00\x23\x00\x20\x00\xff\xff\xff\xff\x05\x00\x2d\x00\xff\xff\xff\xff\x09\x00\x7b\x00\x0b\x00\x0c\x00\x0d\x00\x6c\x00\x2d\x00\xff\xff\xff\xff\x70\x00\x7b\x00\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x05\x00\x20\x00\x30\x00\x31\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\x45\x00\x5e\x00\xff\xff\x2d\x00\xff\xff\x7b\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x5f\x00\x7c\x00\x05\x00\x2d\x00\xff\xff\x7c\x00\x65\x00\x7b\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x20\x00\x23\x00\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x7b\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\xff\xff\x2d\x00\x30\x00\x31\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x05\x00\x20\x00\xff\xff\xff\xff\x23\x00\x05\x00\x0b\x00\x0c\x00\x0d\x00\x7b\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x01\x00\x02\x00\x20\x00\x5f\x00\x05\x00\x7b\x00\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x00\x20\x00\x5f\x00\x7b\x00\x23\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\x2d\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x20\x00\x3b\x00\x22\x00\x5f\x00\xff\xff\x7b\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\x5d\x00\x5f\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\x7d\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x05\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x20\x00\xff\xff\x20\x00\x23\x00\x24\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x20\x00\xff\xff\x22\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x5e\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x7c\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x20\x00\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x2a\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\x02\x00\x03\x00\x5f\x00\xff\xff\xff\xff\x07\x00\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x5e\x00\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\x01\x00\x02\x00\x7c\x00\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x50\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\x5e\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x50\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x5f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x5f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x50\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x50\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\x02\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x5f\x00\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x23\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\x0a\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\x5e\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7c\x00\x7c\x00\x01\x00\x02\x00\x03\x00\x23\x00\xff\xff\xff\xff\x07\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\x5e\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7c\x00\x7c\x00\x01\x00\x02\x00\x03\x00\x23\x00\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x04\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x45\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\x7c\x00\xff\xff\x7e\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x29\x00\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x02\x00\xff\xff\x04\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x02\x00\x7c\x00\x04\x00\x7e\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x45\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x02\x00\x7c\x00\x04\x00\x7e\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x45\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x02\x00\x7c\x00\x04\x00\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x04\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x42\x00\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x23\x00\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x42\x00\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# alex_deflt :: AlexAddr alex_deflt = AlexA# "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\xff\xff\x89\x00\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\x89\x00\x66\x00\x67\x00\x68\x00\x69\x00\x68\x00\x6b\x00\x6b\x00\x67\x00\x67\x00\x6b\x00\x67\x00\x6b\x00\x67\x00\x66\x00\x66\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\x89\x00\x89\x00\x89\x00\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# alex_accept = listArray (0 :: Int, 246) [ AlexAccNone , AlexAcc 178 , AlexAccNone , AlexAcc 177 , AlexAcc 176 , AlexAcc 175 , AlexAcc 174 , AlexAcc 173 , AlexAcc 172 , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccNone , AlexAccSkip , AlexAccSkip , AlexAcc 171 , AlexAcc 170 , AlexAccPred 169 ( isNormalComment )(AlexAccNone) , AlexAccPred 168 ( isNormalComment )(AlexAccNone) , AlexAccPred 167 ( isNormalComment )(AlexAccNone) , AlexAccPred 166 ( isNormalComment )(AlexAcc 165) , AlexAcc 164 , AlexAcc 163 , AlexAccPred 162 ( alexNotPred (ifExtension HaddockBit) )(AlexAccNone) , AlexAccPred 161 ( alexNotPred (ifExtension HaddockBit) )(AlexAcc 160) , AlexAccPred 159 ( alexNotPred (ifExtension HaddockBit) )(AlexAccPred 158 ( ifExtension HaddockBit )(AlexAccNone)) , AlexAcc 157 , AlexAccPred 156 ( atEOL )(AlexAccNone) , AlexAccPred 155 ( atEOL )(AlexAccNone) , AlexAccPred 154 ( atEOL )(AlexAccNone) , AlexAccPred 153 ( atEOL )(AlexAcc 152) , AlexAccPred 151 ( atEOL )(AlexAcc 150) , AlexAccPred 149 ( atEOL )(AlexAcc 148) , AlexAccPred 147 ( atEOL )(AlexAcc 146) , AlexAccPred 145 ( atEOL )(AlexAccNone) , AlexAccPred 144 ( atEOL )(AlexAccNone) , AlexAccPred 143 ( atEOL )(AlexAcc 142) , AlexAccSkip , AlexAccPred 141 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) , AlexAccPred 140 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False) `alexAndPred` followedByDigit )(AlexAccNone) , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) , AlexAccPred 139 ( notFollowedBy '-' )(AlexAccNone) , AlexAccSkip , AlexAccPred 138 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) , AlexAccPred 137 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) , AlexAccPred 136 ( notFollowedBySymbol )(AlexAccNone) , AlexAcc 135 , AlexAccPred 134 ( known_pragma linePrags )(AlexAccNone) , AlexAccPred 133 ( known_pragma linePrags )(AlexAcc 132) , AlexAccPred 131 ( known_pragma linePrags )(AlexAccPred 130 ( known_pragma oneWordPrags )(AlexAccPred 129 ( known_pragma ignoredPrags )(AlexAccPred 128 ( known_pragma fileHeaderPrags )(AlexAccNone)))) , AlexAccPred 127 ( known_pragma linePrags )(AlexAccPred 126 ( known_pragma oneWordPrags )(AlexAccPred 125 ( known_pragma ignoredPrags )(AlexAccPred 124 ( known_pragma fileHeaderPrags )(AlexAccNone)))) , AlexAcc 123 , AlexAcc 122 , AlexAcc 121 , AlexAcc 120 , AlexAcc 119 , AlexAcc 118 , AlexAcc 117 , AlexAcc 116 , AlexAccPred 115 ( known_pragma twoWordPrags )(AlexAccNone) , AlexAcc 114 , AlexAcc 113 , AlexAcc 112 , AlexAccPred 111 ( ifExtension HaddockBit )(AlexAccNone) , AlexAccPred 110 ( ifExtension ThQuotesBit )(AlexAccNone) , AlexAccPred 109 ( ifExtension ThQuotesBit )(AlexAccNone) , AlexAccPred 108 ( ifExtension ThQuotesBit )(AlexAccPred 107 ( ifExtension QqBit )(AlexAccNone)) , AlexAccPred 106 ( ifExtension ThQuotesBit )(AlexAccNone) , AlexAccPred 105 ( ifExtension ThQuotesBit )(AlexAccPred 104 ( ifExtension QqBit )(AlexAccNone)) , AlexAccPred 103 ( ifExtension ThQuotesBit )(AlexAccPred 102 ( ifExtension QqBit )(AlexAccNone)) , AlexAccPred 101 ( ifExtension ThQuotesBit )(AlexAccPred 100 ( ifExtension QqBit )(AlexAccNone)) , AlexAccPred 99 ( ifExtension ThQuotesBit )(AlexAccNone) , AlexAccPred 98 ( ifExtension ThQuotesBit )(AlexAccNone) , AlexAccPred 97 ( ifExtension ThBit )(AlexAccNone) , AlexAccPred 96 ( ifExtension ThBit )(AlexAccNone) , AlexAccPred 95 ( ifExtension ThBit )(AlexAccNone) , AlexAccPred 94 ( ifExtension ThBit )(AlexAccNone) , AlexAccPred 93 ( ifExtension QqBit )(AlexAccNone) , AlexAccPred 92 ( ifExtension QqBit )(AlexAccNone) , AlexAccPred 91 ( ifCurrentChar '⟦' `alexAndPred` ifExtension UnicodeSyntaxBit `alexAndPred` ifExtension ThQuotesBit )(AlexAccPred 90 ( ifCurrentChar '⟧' `alexAndPred` ifExtension UnicodeSyntaxBit `alexAndPred` ifExtension ThQuotesBit )(AlexAccPred 89 ( ifCurrentChar '⦇' `alexAndPred` ifExtension UnicodeSyntaxBit `alexAndPred` ifExtension ArrowsBit )(AlexAccPred 88 ( ifCurrentChar '⦈' `alexAndPred` ifExtension UnicodeSyntaxBit `alexAndPred` ifExtension ArrowsBit )(AlexAccNone)))) , AlexAccPred 87 (alexPrevCharMatches(\c -> True && c < '\SOH' || c > '\ETX' && c < '\a' || c > '\a' && c < '\n' || c > '\n' && c < '\'' || c > '\'' && c < ')' || c > ')' && c < '0' || c > '9' && c < 'A' || c > 'Z' && c < '_' || c > '_' && c < 'a' || c > 'z' && True || False) `alexAndPred` ifExtension TypeApplicationsBit `alexAndPred` notFollowedBySymbol )(AlexAcc 86) , AlexAccPred 85 ( ifExtension ArrowsBit `alexAndPred` notFollowedBySymbol )(AlexAccNone) , AlexAccPred 84 ( ifExtension ArrowsBit )(AlexAccNone) , AlexAccPred 83 ( ifExtension IpBit )(AlexAccNone) , AlexAccPred 82 ( ifExtension OverloadedLabelsBit )(AlexAccNone) , AlexAccPred 81 ( ifExtension UnboxedTuplesBit `alexOrPred` ifExtension UnboxedSumsBit )(AlexAccNone) , AlexAccPred 80 ( ifExtension UnboxedTuplesBit `alexOrPred` ifExtension UnboxedSumsBit )(AlexAccNone) , AlexAcc 79 , AlexAcc 78 , AlexAcc 77 , AlexAcc 76 , AlexAcc 75 , AlexAcc 74 , AlexAcc 73 , AlexAcc 72 , AlexAcc 71 , AlexAcc 70 , AlexAcc 69 , AlexAcc 68 , AlexAcc 67 , AlexAcc 66 , AlexAcc 65 , AlexAcc 64 , AlexAcc 63 , AlexAcc 62 , AlexAcc 61 , AlexAcc 60 , AlexAcc 59 , AlexAcc 58 , AlexAcc 57 , AlexAcc 56 , AlexAcc 55 , AlexAcc 54 , AlexAccPred 53 ( ifExtension MagicHashBit )(AlexAccNone) , AlexAccPred 52 ( ifExtension MagicHashBit )(AlexAccNone) , AlexAccPred 51 ( ifExtension MagicHashBit )(AlexAccNone) , AlexAccPred 50 ( ifExtension MagicHashBit )(AlexAccPred 49 ( ifExtension MagicHashBit )(AlexAccNone)) , AlexAccPred 48 ( ifExtension MagicHashBit )(AlexAccPred 47 ( ifExtension MagicHashBit )(AlexAccNone)) , AlexAccPred 46 ( ifExtension MagicHashBit )(AlexAccNone) , AlexAcc 45 , AlexAcc 44 , AlexAcc 43 , AlexAcc 42 , AlexAcc 41 , AlexAcc 40 , AlexAcc 39 , AlexAcc 38 , AlexAcc 37 , AlexAcc 36 , AlexAcc 35 , AlexAcc 34 , AlexAcc 33 , AlexAcc 32 , AlexAccPred 31 ( ifExtension BinaryLiteralsBit )(AlexAccNone) , AlexAcc 30 , AlexAcc 29 , AlexAccPred 28 ( ifExtension NegativeLiteralsBit )(AlexAccNone) , AlexAccPred 27 ( ifExtension NegativeLiteralsBit )(AlexAccNone) , AlexAccPred 26 ( ifExtension NegativeLiteralsBit `alexAndPred` ifExtension BinaryLiteralsBit )(AlexAccNone) , AlexAccPred 25 ( ifExtension NegativeLiteralsBit )(AlexAccNone) , AlexAccPred 24 ( ifExtension NegativeLiteralsBit )(AlexAccNone) , AlexAcc 23 , AlexAcc 22 , AlexAccPred 21 ( ifExtension NegativeLiteralsBit )(AlexAccNone) , AlexAccPred 20 ( ifExtension NegativeLiteralsBit )(AlexAccNone) , AlexAccPred 19 ( ifExtension HexFloatLiteralsBit )(AlexAccNone) , AlexAccPred 18 ( ifExtension HexFloatLiteralsBit )(AlexAccNone) , AlexAccPred 17 ( ifExtension HexFloatLiteralsBit `alexAndPred` ifExtension NegativeLiteralsBit )(AlexAccNone) , AlexAccPred 16 ( ifExtension HexFloatLiteralsBit `alexAndPred` ifExtension NegativeLiteralsBit )(AlexAccNone) , AlexAccPred 15 ( ifExtension MagicHashBit )(AlexAccNone) , AlexAccPred 14 ( ifExtension MagicHashBit `alexAndPred` ifExtension BinaryLiteralsBit )(AlexAccNone) , AlexAccPred 13 ( ifExtension MagicHashBit )(AlexAccNone) , AlexAccPred 12 ( ifExtension MagicHashBit )(AlexAccNone) , AlexAccPred 11 ( ifExtension MagicHashBit )(AlexAccNone) , AlexAccPred 10 ( ifExtension MagicHashBit `alexAndPred` ifExtension BinaryLiteralsBit )(AlexAccNone) , AlexAccPred 9 ( ifExtension MagicHashBit )(AlexAccNone) , AlexAccPred 8 ( ifExtension MagicHashBit )(AlexAccNone) , AlexAccPred 7 ( ifExtension MagicHashBit )(AlexAccNone) , AlexAccPred 6 ( ifExtension MagicHashBit `alexAndPred` ifExtension BinaryLiteralsBit )(AlexAccNone) , AlexAccPred 5 ( ifExtension MagicHashBit )(AlexAccNone) , AlexAccPred 4 ( ifExtension MagicHashBit )(AlexAccNone) , AlexAccPred 3 ( ifExtension MagicHashBit )(AlexAccNone) , AlexAccPred 2 ( ifExtension MagicHashBit )(AlexAccNone) , AlexAcc 1 , AlexAcc 0 ] alex_actions = array (0 :: Int, 179) [ (178,alex_action_14) , (177,alex_action_20) , (176,alex_action_21) , (175,alex_action_19) , (174,alex_action_22) , (173,alex_action_26) , (172,alex_action_27) , (171,alex_action_1) , (170,alex_action_1) , (169,alex_action_2) , (168,alex_action_2) , (167,alex_action_2) , (166,alex_action_2) , (165,alex_action_27) , (164,alex_action_3) , (163,alex_action_4) , (162,alex_action_5) , (161,alex_action_5) , (160,alex_action_27) , (159,alex_action_5) , (158,alex_action_38) , (157,alex_action_6) , (156,alex_action_7) , (155,alex_action_7) , (154,alex_action_7) , (153,alex_action_7) , (152,alex_action_27) , (151,alex_action_7) , (150,alex_action_27) , (149,alex_action_7) , (148,alex_action_85) , (147,alex_action_7) , (146,alex_action_85) , (145,alex_action_8) , (144,alex_action_8) , (143,alex_action_8) , (142,alex_action_27) , (141,alex_action_10) , (140,alex_action_11) , (139,alex_action_15) , (138,alex_action_17) , (137,alex_action_17) , (136,alex_action_18) , (135,alex_action_23) , (134,alex_action_24) , (133,alex_action_24) , (132,alex_action_27) , (131,alex_action_24) , (130,alex_action_32) , (129,alex_action_33) , (128,alex_action_35) , (127,alex_action_24) , (126,alex_action_32) , (125,alex_action_33) , (124,alex_action_36) , (123,alex_action_25) , (122,alex_action_27) , (121,alex_action_27) , (120,alex_action_27) , (119,alex_action_27) , (118,alex_action_28) , (117,alex_action_29) , (116,alex_action_30) , (115,alex_action_31) , (114,alex_action_34) , (113,alex_action_37) , (112,alex_action_37) , (111,alex_action_39) , (110,alex_action_40) , (109,alex_action_41) , (108,alex_action_42) , (107,alex_action_53) , (106,alex_action_43) , (105,alex_action_44) , (104,alex_action_53) , (103,alex_action_45) , (102,alex_action_53) , (101,alex_action_46) , (100,alex_action_53) , (99,alex_action_47) , (98,alex_action_48) , (97,alex_action_49) , (96,alex_action_50) , (95,alex_action_51) , (94,alex_action_52) , (93,alex_action_53) , (92,alex_action_54) , (91,alex_action_55) , (90,alex_action_56) , (89,alex_action_60) , (88,alex_action_61) , (87,alex_action_57) , (86,alex_action_85) , (85,alex_action_58) , (84,alex_action_59) , (83,alex_action_62) , (82,alex_action_63) , (81,alex_action_64) , (80,alex_action_65) , (79,alex_action_66) , (78,alex_action_66) , (77,alex_action_67) , (76,alex_action_68) , (75,alex_action_68) , (74,alex_action_69) , (73,alex_action_70) , (72,alex_action_71) , (71,alex_action_72) , (70,alex_action_73) , (69,alex_action_73) , (68,alex_action_74) , (67,alex_action_75) , (66,alex_action_75) , (65,alex_action_76) , (64,alex_action_76) , (63,alex_action_77) , (62,alex_action_77) , (61,alex_action_77) , (60,alex_action_77) , (59,alex_action_77) , (58,alex_action_77) , (57,alex_action_77) , (56,alex_action_77) , (55,alex_action_78) , (54,alex_action_78) , (53,alex_action_79) , (52,alex_action_80) , (51,alex_action_81) , (50,alex_action_81) , (49,alex_action_111) , (48,alex_action_81) , (47,alex_action_112) , (46,alex_action_82) , (45,alex_action_83) , (44,alex_action_84) , (43,alex_action_85) , (42,alex_action_85) , (41,alex_action_85) , (40,alex_action_85) , (39,alex_action_85) , (38,alex_action_85) , (37,alex_action_85) , (36,alex_action_85) , (35,alex_action_85) , (34,alex_action_86) , (33,alex_action_87) , (32,alex_action_87) , (31,alex_action_88) , (30,alex_action_89) , (29,alex_action_90) , (28,alex_action_91) , (27,alex_action_91) , (26,alex_action_92) , (25,alex_action_93) , (24,alex_action_94) , (23,alex_action_95) , (22,alex_action_95) , (21,alex_action_96) , (20,alex_action_96) , (19,alex_action_97) , (18,alex_action_97) , (17,alex_action_98) , (16,alex_action_98) , (15,alex_action_99) , (14,alex_action_100) , (13,alex_action_101) , (12,alex_action_102) , (11,alex_action_103) , (10,alex_action_104) , (9,alex_action_105) , (8,alex_action_106) , (7,alex_action_107) , (6,alex_action_108) , (5,alex_action_109) , (4,alex_action_110) , (3,alex_action_111) , (2,alex_action_112) , (1,alex_action_113) , (0,alex_action_114) ] {-# LINE 583 "compiler/parser/Lexer.x" #-} -- ----------------------------------------------------------------------------- -- The token type data Token = ITas -- Haskell keywords | ITcase | ITclass | ITdata | ITdefault | ITderiving | ITdo | ITelse | IThiding | ITforeign | ITif | ITimport | ITin | ITinfix | ITinfixl | ITinfixr | ITinstance | ITlet | ITmodule | ITnewtype | ITof | ITqualified | ITthen | ITtype | ITwhere | ITforall IsUnicodeSyntax -- GHC extension keywords | ITexport | ITlabel | ITdynamic | ITsafe | ITinterruptible | ITunsafe | ITstdcallconv | ITccallconv | ITcapiconv | ITprimcallconv | ITjavascriptcallconv | ITmdo | ITfamily | ITrole | ITgroup | ITby | ITusing | ITpattern | ITstatic | ITstock | ITanyclass | ITvia -- Backpack tokens | ITunit | ITsignature | ITdependency | ITrequires -- Pragmas, see note [Pragma source text] in BasicTypes | ITinline_prag SourceText InlineSpec RuleMatchInfo | ITspec_prag SourceText -- SPECIALISE | ITspec_inline_prag SourceText Bool -- SPECIALISE INLINE (or NOINLINE) | ITsource_prag SourceText | ITrules_prag SourceText | ITwarning_prag SourceText | ITdeprecated_prag SourceText | ITline_prag SourceText -- not usually produced, see 'UsePosPragsBit' | ITcolumn_prag SourceText -- not usually produced, see 'UsePosPragsBit' | ITscc_prag SourceText | ITgenerated_prag SourceText | ITcore_prag SourceText -- hdaume: core annotations | ITunpack_prag SourceText | ITnounpack_prag SourceText | ITann_prag SourceText | ITcomplete_prag SourceText | ITclose_prag | IToptions_prag String | ITinclude_prag String | ITlanguage_prag | ITminimal_prag SourceText | IToverlappable_prag SourceText -- instance overlap mode | IToverlapping_prag SourceText -- instance overlap mode | IToverlaps_prag SourceText -- instance overlap mode | ITincoherent_prag SourceText -- instance overlap mode | ITctype SourceText | ITcomment_line_prag -- See Note [Nested comment line pragmas] | ITdotdot -- reserved symbols | ITcolon | ITdcolon IsUnicodeSyntax | ITequal | ITlam | ITlcase | ITvbar | ITlarrow IsUnicodeSyntax | ITrarrow IsUnicodeSyntax | ITat | ITtilde | ITdarrow IsUnicodeSyntax | ITminus | ITbang | ITstar IsUnicodeSyntax | ITdot | ITbiglam -- GHC-extension symbols | ITocurly -- special symbols | ITccurly | ITvocurly | ITvccurly | ITobrack | ITopabrack -- [:, for parallel arrays with -XParallelArrays | ITcpabrack -- :], for parallel arrays with -XParallelArrays | ITcbrack | IToparen | ITcparen | IToubxparen | ITcubxparen | ITsemi | ITcomma | ITunderscore | ITbackquote | ITsimpleQuote -- ' | ITvarid FastString -- identifiers | ITconid FastString | ITvarsym FastString | ITconsym FastString | ITqvarid (FastString,FastString) | ITqconid (FastString,FastString) | ITqvarsym (FastString,FastString) | ITqconsym (FastString,FastString) | ITdupipvarid FastString -- GHC extension: implicit param: ?x | ITlabelvarid FastString -- Overloaded label: #x | ITchar SourceText Char -- Note [Literal source text] in BasicTypes | ITstring SourceText FastString -- Note [Literal source text] in BasicTypes | ITinteger IntegralLit -- Note [Literal source text] in BasicTypes | ITrational FractionalLit | ITprimchar SourceText Char -- Note [Literal source text] in BasicTypes | ITprimstring SourceText ByteString -- Note [Literal source text] @BasicTypes | ITprimint SourceText Integer -- Note [Literal source text] in BasicTypes | ITprimword SourceText Integer -- Note [Literal source text] in BasicTypes | ITprimfloat FractionalLit | ITprimdouble FractionalLit -- Template Haskell extension tokens | ITopenExpQuote HasE IsUnicodeSyntax -- [| or [e| | ITopenPatQuote -- [p| | ITopenDecQuote -- [d| | ITopenTypQuote -- [t| | ITcloseQuote IsUnicodeSyntax -- |] | ITopenTExpQuote HasE -- [|| or [e|| | ITcloseTExpQuote -- ||] | ITidEscape FastString -- $x | ITparenEscape -- $( | ITidTyEscape FastString -- $$x | ITparenTyEscape -- $$( | ITtyQuote -- '' | ITquasiQuote (FastString,FastString,RealSrcSpan) -- ITquasiQuote(quoter, quote, loc) -- represents a quasi-quote of the form -- [quoter| quote |] | ITqQuasiQuote (FastString,FastString,FastString,RealSrcSpan) -- ITqQuasiQuote(Qual, quoter, quote, loc) -- represents a qualified quasi-quote of the form -- [Qual.quoter| quote |] -- Arrow notation extension | ITproc | ITrec | IToparenbar IsUnicodeSyntax -- ^ @(|@ | ITcparenbar IsUnicodeSyntax -- ^ @|)@ | ITlarrowtail IsUnicodeSyntax -- ^ @-<@ | ITrarrowtail IsUnicodeSyntax -- ^ @>-@ | ITLarrowtail IsUnicodeSyntax -- ^ @-<<@ | ITRarrowtail IsUnicodeSyntax -- ^ @>>-@ -- | Type application '@' (lexed differently than as-pattern '@', -- due to checking for preceding whitespace) | ITtypeApp | ITunknown String -- ^ Used when the lexer can't make sense of it | ITeof -- ^ end of file token -- Documentation annotations | ITdocCommentNext String -- ^ something beginning @-- |@ | ITdocCommentPrev String -- ^ something beginning @-- ^@ | ITdocCommentNamed String -- ^ something beginning @-- $@ | ITdocSection Int String -- ^ a section heading | ITdocOptions String -- ^ doc options (prune, ignore-exports, etc) | ITlineComment String -- ^ comment starting by "--" | ITblockComment String -- ^ comment in {- -} deriving Show instance Outputable Token where ppr x = text (show x) -- the bitmap provided as the third component indicates whether the -- corresponding extension keyword is valid under the extension options -- provided to the compiler; if the extension corresponding to *any* of the -- bits set in the bitmap is enabled, the keyword is valid (this setup -- facilitates using a keyword in two different extensions that can be -- activated independently) -- reservedWordsFM :: UniqFM (Token, ExtsBitmap) reservedWordsFM = listToUFM $ map (\(x, y, z) -> (mkFastString x, (y, z))) [( "_", ITunderscore, 0 ), ( "as", ITas, 0 ), ( "case", ITcase, 0 ), ( "class", ITclass, 0 ), ( "data", ITdata, 0 ), ( "default", ITdefault, 0 ), ( "deriving", ITderiving, 0 ), ( "do", ITdo, 0 ), ( "else", ITelse, 0 ), ( "hiding", IThiding, 0 ), ( "if", ITif, 0 ), ( "import", ITimport, 0 ), ( "in", ITin, 0 ), ( "infix", ITinfix, 0 ), ( "infixl", ITinfixl, 0 ), ( "infixr", ITinfixr, 0 ), ( "instance", ITinstance, 0 ), ( "let", ITlet, 0 ), ( "module", ITmodule, 0 ), ( "newtype", ITnewtype, 0 ), ( "of", ITof, 0 ), ( "qualified", ITqualified, 0 ), ( "then", ITthen, 0 ), ( "type", ITtype, 0 ), ( "where", ITwhere, 0 ), ( "forall", ITforall NormalSyntax, 0), ( "mdo", ITmdo, xbit RecursiveDoBit), -- See Note [Lexing type pseudo-keywords] ( "family", ITfamily, 0 ), ( "role", ITrole, 0 ), ( "pattern", ITpattern, xbit PatternSynonymsBit), ( "static", ITstatic, xbit StaticPointersBit ), ( "stock", ITstock, 0 ), ( "anyclass", ITanyclass, 0 ), ( "via", ITvia, 0 ), ( "group", ITgroup, xbit TransformComprehensionsBit), ( "by", ITby, xbit TransformComprehensionsBit), ( "using", ITusing, xbit TransformComprehensionsBit), ( "foreign", ITforeign, xbit FfiBit), ( "export", ITexport, xbit FfiBit), ( "label", ITlabel, xbit FfiBit), ( "dynamic", ITdynamic, xbit FfiBit), ( "safe", ITsafe, xbit FfiBit .|. xbit SafeHaskellBit), ( "interruptible", ITinterruptible, xbit InterruptibleFfiBit), ( "unsafe", ITunsafe, xbit FfiBit), ( "stdcall", ITstdcallconv, xbit FfiBit), ( "ccall", ITccallconv, xbit FfiBit), ( "capi", ITcapiconv, xbit CApiFfiBit), ( "prim", ITprimcallconv, xbit FfiBit), ( "javascript", ITjavascriptcallconv, xbit FfiBit), ( "unit", ITunit, 0 ), ( "dependency", ITdependency, 0 ), ( "signature", ITsignature, 0 ), ( "rec", ITrec, xbit ArrowsBit .|. xbit RecursiveDoBit), ( "proc", ITproc, xbit ArrowsBit) ] {----------------------------------- Note [Lexing type pseudo-keywords] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ One might think that we wish to treat 'family' and 'role' as regular old varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively. But, there is no need to do so. These pseudo-keywords are not stolen syntax: they are only used after the keyword 'type' at the top-level, where varids are not allowed. Furthermore, checks further downstream (TcTyClsDecls) ensure that type families and role annotations are never declared without their extensions on. In fact, by unconditionally lexing these pseudo-keywords as special, we can get better error messages. Also, note that these are included in the `varid` production in the parser -- a key detail to make all this work. -------------------------------------} reservedSymsFM :: UniqFM (Token, IsUnicodeSyntax, ExtsBitmap) reservedSymsFM = listToUFM $ map (\ (x,w,y,z) -> (mkFastString x,(w,y,z))) [ ("..", ITdotdot, NormalSyntax, 0 ) -- (:) is a reserved op, meaning only list cons ,(":", ITcolon, NormalSyntax, 0 ) ,("::", ITdcolon NormalSyntax, NormalSyntax, 0 ) ,("=", ITequal, NormalSyntax, 0 ) ,("\\", ITlam, NormalSyntax, 0 ) ,("|", ITvbar, NormalSyntax, 0 ) ,("<-", ITlarrow NormalSyntax, NormalSyntax, 0 ) ,("->", ITrarrow NormalSyntax, NormalSyntax, 0 ) ,("@", ITat, NormalSyntax, 0 ) ,("~", ITtilde, NormalSyntax, 0 ) ,("=>", ITdarrow NormalSyntax, NormalSyntax, 0 ) ,("-", ITminus, NormalSyntax, 0 ) ,("!", ITbang, NormalSyntax, 0 ) ,("*", ITstar NormalSyntax, NormalSyntax, xbit StarIsTypeBit) -- For 'forall a . t' ,(".", ITdot, NormalSyntax, 0 ) ,("-<", ITlarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) ,(">-", ITrarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) ,("-<<", ITLarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) ,(">>-", ITRarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) ,("∷", ITdcolon UnicodeSyntax, UnicodeSyntax, 0 ) ,("⇒", ITdarrow UnicodeSyntax, UnicodeSyntax, 0 ) ,("∀", ITforall UnicodeSyntax, UnicodeSyntax, 0 ) ,("→", ITrarrow UnicodeSyntax, UnicodeSyntax, 0 ) ,("←", ITlarrow UnicodeSyntax, UnicodeSyntax, 0 ) ,("⤙", ITlarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) ,("⤚", ITrarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) ,("⤛", ITLarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) ,("⤜", ITRarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) ,("★", ITstar UnicodeSyntax, UnicodeSyntax, xbit StarIsTypeBit) -- ToDo: ideally, → and ∷ should be "specials", so that they cannot -- form part of a large operator. This would let us have a better -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe). ] -- ----------------------------------------------------------------------------- -- Lexer actions type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token) special :: Token -> Action special tok span _buf _len = return (L span tok) token, layout_token :: Token -> Action token t span _buf _len = return (L span t) layout_token t span _buf _len = pushLexState layout >> return (L span t) idtoken :: (StringBuffer -> Int -> Token) -> Action idtoken f span buf len = return (L span $! (f buf len)) skip_one_varid :: (FastString -> Token) -> Action skip_one_varid f span buf len = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) skip_two_varid :: (FastString -> Token) -> Action skip_two_varid f span buf len = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2))) strtoken :: (String -> Token) -> Action strtoken f span buf len = return (L span $! (f $! lexemeToString buf len)) begin :: Int -> Action begin code _span _str _len = do pushLexState code; lexToken pop :: Action pop _span _buf _len = do _ <- popLexState lexToken -- See Note [Nested comment line pragmas] failLinePrag1 :: Action failLinePrag1 span _buf _len = do b <- getBit InNestedCommentBit if b then return (L span ITcomment_line_prag) else lexError "lexical error in pragma" -- See Note [Nested comment line pragmas] popLinePrag1 :: Action popLinePrag1 span _buf _len = do b <- getBit InNestedCommentBit if b then return (L span ITcomment_line_prag) else do _ <- popLexState lexToken hopefully_open_brace :: Action hopefully_open_brace span buf len = do relaxed <- getBit RelaxedLayoutBit ctx <- getContext (AI l _) <- getInput let offset = srcLocCol l isOK = relaxed || case ctx of Layout prev_off _ : _ -> prev_off < offset _ -> True if isOK then pop_and open_brace span buf len else addFatalError (RealSrcSpan span) (text "Missing block") pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState act span buf len {-# INLINE nextCharIs #-} nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool nextCharIs buf p = not (atEnd buf) && p (currentChar buf) {-# INLINE nextCharIsNot #-} nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool nextCharIsNot buf p = not (nextCharIs buf p) notFollowedBy :: Char -> AlexAccPred ExtsBitmap notFollowedBy char _ _ _ (AI _ buf) = nextCharIsNot buf (== char) notFollowedBySymbol :: AlexAccPred ExtsBitmap notFollowedBySymbol _ _ _ (AI _ buf) = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~") followedByDigit :: AlexAccPred ExtsBitmap followedByDigit _ _ _ (AI _ buf) = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9'])) ifCurrentChar :: Char -> AlexAccPred ExtsBitmap ifCurrentChar char _ (AI _ buf) _ _ = nextCharIs buf (== char) -- We must reject doc comments as being ordinary comments everywhere. -- In some cases the doc comment will be selected as the lexeme due to -- maximal munch, but not always, because the nested comment rule is -- valid in all states, but the doc-comment rules are only valid in -- the non-layout states. isNormalComment :: AlexAccPred ExtsBitmap isNormalComment bits _ _ (AI _ buf) | HaddockBit `xtest` bits = notFollowedByDocOrPragma | otherwise = nextCharIsNot buf (== '#') where notFollowedByDocOrPragma = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#")) afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool afterOptionalSpace buf p = if nextCharIs buf (== ' ') then p (snd (nextChar buf)) else p buf atEOL :: AlexAccPred ExtsBitmap atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' ifExtension :: ExtBits -> AlexAccPred ExtsBitmap ifExtension extBits bits _ _ _ = extBits `xtest` bits alexNotPred p userState in1 len in2 = not (p userState in1 len in2) alexOrPred p1 p2 userState in1 len in2 = p1 userState in1 len in2 || p2 userState in1 len in2 multiline_doc_comment :: Action multiline_doc_comment span buf _len = withLexedDocType (worker "") where worker commentAcc input docType checkNextLine = case alexGetChar' input of Just ('\n', input') | checkNextLine -> case checkIfCommentLine input' of Just input -> worker ('\n':commentAcc) input docType checkNextLine Nothing -> docCommentEnd input commentAcc docType buf span | otherwise -> docCommentEnd input commentAcc docType buf span Just (c, input) -> worker (c:commentAcc) input docType checkNextLine Nothing -> docCommentEnd input commentAcc docType buf span -- Check if the next line of input belongs to this doc comment as well. -- A doc comment continues onto the next line when the following -- conditions are met: -- * The line starts with "--" -- * The line doesn't start with "---". -- * The line doesn't start with "-- $", because that would be the -- start of a /new/ named haddock chunk (#10398). checkIfCommentLine :: AlexInput -> Maybe AlexInput checkIfCommentLine input = check (dropNonNewlineSpace input) where check input = do ('-', input) <- alexGetChar' input ('-', input) <- alexGetChar' input (c, after_c) <- alexGetChar' input case c of '-' -> Nothing ' ' -> case alexGetChar' after_c of Just ('$', _) -> Nothing _ -> Just input _ -> Just input dropNonNewlineSpace input = case alexGetChar' input of Just (c, input') | isSpace c && c /= '\n' -> dropNonNewlineSpace input' | otherwise -> input Nothing -> input lineCommentToken :: Action lineCommentToken span buf len = do b <- getBit RawTokenStreamBit if b then strtoken ITlineComment span buf len else lexToken {- nested comments require traversing by hand, they can't be parsed using regular expressions. -} nested_comment :: P (RealLocated Token) -> Action nested_comment cont span buf len = do input <- getInput go (reverse $ lexemeToString buf len) (1::Int) input where go commentAcc 0 input = do setInput input b <- getBit RawTokenStreamBit if b then docCommentEnd input commentAcc ITblockComment buf span else cont go commentAcc n input = case alexGetChar' input of Nothing -> errBrace input span Just ('-',input) -> case alexGetChar' input of Nothing -> errBrace input span Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}' Just (_,_) -> go ('-':commentAcc) n input Just ('\123',input) -> case alexGetChar' input of -- '{' char Nothing -> errBrace input span Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input Just (_,_) -> go ('\123':commentAcc) n input -- See Note [Nested comment line pragmas] Just ('\n',input) -> case alexGetChar' input of Nothing -> errBrace input span Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input go (parsedAcc ++ '\n':commentAcc) n input Just (_,_) -> go ('\n':commentAcc) n input Just (c,input) -> go (c:commentAcc) n input nested_doc_comment :: Action nested_doc_comment span buf _len = withLexedDocType (go "") where go commentAcc input docType _ = case alexGetChar' input of Nothing -> errBrace input span Just ('-',input) -> case alexGetChar' input of Nothing -> errBrace input span Just ('\125',input) -> docCommentEnd input commentAcc docType buf span Just (_,_) -> go ('-':commentAcc) input docType False Just ('\123', input) -> case alexGetChar' input of Nothing -> errBrace input span Just ('-',input) -> do setInput input let cont = do input <- getInput; go commentAcc input docType False nested_comment cont span buf _len Just (_,_) -> go ('\123':commentAcc) input docType False -- See Note [Nested comment line pragmas] Just ('\n',input) -> case alexGetChar' input of Nothing -> errBrace input span Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input go (parsedAcc ++ '\n':commentAcc) input docType False Just (_,_) -> go ('\n':commentAcc) input docType False Just (c,input) -> go (c:commentAcc) input docType False -- See Note [Nested comment line pragmas] parseNestedPragma :: AlexInput -> P (String,AlexInput) parseNestedPragma input@(AI _ buf) = do origInput <- getInput setInput input setExts (.|. xbit InNestedCommentBit) pushLexState bol lt <- lexToken _ <- popLexState setExts (.&. complement (xbit InNestedCommentBit)) postInput@(AI _ postBuf) <- getInput setInput origInput case unRealSrcSpan lt of ITcomment_line_prag -> do let bytes = byteDiff buf postBuf diff = lexemeToString buf bytes return (reverse diff, postInput) lt' -> panic ("parseNestedPragma: unexpected token" ++ (show lt')) {- Note [Nested comment line pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to ignore cpp-preprocessor-generated #line pragmas if they were inside nested comments. Now, when parsing a nested comment, if we encounter a line starting with '#' we call parseNestedPragma, which executes the following: 1. Save the current lexer input (loc, buf) for later 2. Set the current lexer input to the beginning of the line starting with '#' 3. Turn the 'InNestedComment' extension on 4. Push the 'bol' lexer state 5. Lex a token. Due to (2), (3), and (4), this should always lex a single line or less and return the ITcomment_line_prag token. This may set source line and file location if a #line pragma is successfully parsed 6. Restore lexer input and state to what they were before we did all this 7. Return control to the function parsing a nested comment, informing it of what the lexer parsed Regarding (5) above: Every exit from the 'bol' lexer state (do_bol, popLinePrag1, failLinePrag1) checks if the 'InNestedComment' extension is set. If it is, that function will return control to parseNestedPragma by returning the ITcomment_line_prag token. See #314 for more background on the bug this fixes. -} withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token)) -> P (RealLocated Token) withLexedDocType lexDocComment = do input@(AI _ buf) <- getInput case prevChar buf ' ' of -- The `Bool` argument to lexDocComment signals whether or not the next -- line of input might also belong to this doc comment. '|' -> lexDocComment input ITdocCommentNext True '^' -> lexDocComment input ITdocCommentPrev True '$' -> lexDocComment input ITdocCommentNamed True '*' -> lexDocSection 1 input _ -> panic "withLexedDocType: Bad doc type" where lexDocSection n input = case alexGetChar' input of Just ('*', input) -> lexDocSection (n+1) input Just (_, _) -> lexDocComment input (ITdocSection n) False Nothing -> do setInput input; lexToken -- eof reached, lex it normally -- RULES pragmas turn on the forall and '.' keywords, and we turn them -- off again at the end of the pragma. rulePrag :: Action rulePrag span buf len = do setExts (.|. xbit InRulePragBit) let !src = lexemeToString buf len return (L span (ITrules_prag (SourceText src))) -- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead -- of updating the position in 'PState' linePrag :: Action linePrag span buf len = do usePosPrags <- getBit UsePosPragsBit if usePosPrags then begin line_prag2 span buf len else let !src = lexemeToString buf len in return (L span (ITline_prag (SourceText src))) -- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead -- of updating the position in 'PState' columnPrag :: Action columnPrag span buf len = do usePosPrags <- getBit UsePosPragsBit let !src = lexemeToString buf len if usePosPrags then begin column_prag span buf len else let !src = lexemeToString buf len in return (L span (ITcolumn_prag (SourceText src))) endPrag :: Action endPrag span _buf _len = do setExts (.&. complement (xbit InRulePragBit)) return (L span ITclose_prag) -- docCommentEnd ------------------------------------------------------------------------------- -- This function is quite tricky. We can't just return a new token, we also -- need to update the state of the parser. Why? Because the token is longer -- than what was lexed by Alex, and the lexToken function doesn't know this, so -- it writes the wrong token length to the parser state. This function is -- called afterwards, so it can just update the state. docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> RealSrcSpan -> P (RealLocated Token) docCommentEnd input commentAcc docType buf span = do setInput input let (AI loc nextBuf) = input comment = reverse commentAcc span' = mkRealSrcSpan (realSrcSpanStart span) loc last_len = byteDiff buf nextBuf span `seq` setLastToken span' last_len return (L span' (docType comment)) errBrace :: AlexInput -> RealSrcSpan -> P a errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'" open_brace, close_brace :: Action open_brace span _str _len = do ctx <- getContext setContext (NoLayout:ctx) return (L span ITocurly) close_brace span _str _len = do popContext return (L span ITccurly) qvarid, qconid :: StringBuffer -> Int -> Token qvarid buf len = ITqvarid $! splitQualName buf len False qconid buf len = ITqconid $! splitQualName buf len False splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString) -- takes a StringBuffer and a length, and returns the module name -- and identifier parts of a qualified name. Splits at the *last* dot, -- because of hierarchical module names. splitQualName orig_buf len parens = split orig_buf orig_buf where split buf dot_buf | orig_buf `byteDiff` buf >= len = done dot_buf | c == '.' = found_dot buf' | otherwise = split buf' dot_buf where (c,buf') = nextChar buf -- careful, we might get names like M.... -- so, if the character after the dot is not upper-case, this is -- the end of the qualifier part. found_dot buf -- buf points after the '.' | isUpper c = split buf' buf | otherwise = done buf where (c,buf') = nextChar buf done dot_buf = (lexemeToFastString orig_buf (qual_size - 1), if parens -- Prelude.(+) then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) else lexemeToFastString dot_buf (len - qual_size)) where qual_size = orig_buf `byteDiff` dot_buf varid :: Action varid span buf len = case lookupUFM reservedWordsFM fs of Just (ITcase, _) -> do lastTk <- getLastTk keyword <- case lastTk of Just ITlam -> do lambdaCase <- getBit LambdaCaseBit unless lambdaCase $ do pState <- getPState addError (RealSrcSpan (last_loc pState)) $ text "Illegal lambda-case (use LambdaCase)" return ITlcase _ -> return ITcase maybe_layout keyword return $ L span keyword Just (keyword, 0) -> do maybe_layout keyword return $ L span keyword Just (keyword, i) -> do exts <- getExts if exts .&. i /= 0 then do maybe_layout keyword return $ L span keyword else return $ L span $ ITvarid fs Nothing -> return $ L span $ ITvarid fs where !fs = lexemeToFastString buf len conid :: StringBuffer -> Int -> Token conid buf len = ITconid $! lexemeToFastString buf len qvarsym, qconsym :: StringBuffer -> Int -> Token qvarsym buf len = ITqvarsym $! splitQualName buf len False qconsym buf len = ITqconsym $! splitQualName buf len False varsym, consym :: Action varsym = sym ITvarsym consym = sym ITconsym sym :: (FastString -> Token) -> Action sym con span buf len = case lookupUFM reservedSymsFM fs of Just (keyword, NormalSyntax, 0) -> return $ L span keyword Just (keyword, NormalSyntax, i) -> do exts <- getExts if exts .&. i /= 0 then return $ L span keyword else return $ L span (con fs) Just (keyword, UnicodeSyntax, 0) -> do exts <- getExts if xtest UnicodeSyntaxBit exts then return $ L span keyword else return $ L span (con fs) Just (keyword, UnicodeSyntax, i) -> do exts <- getExts if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts then return $ L span keyword else return $ L span (con fs) Nothing -> return $ L span $! con fs where !fs = lexemeToFastString buf len -- Variations on the integral numeric literal. tok_integral :: (SourceText -> Integer -> Token) -> (Integer -> Integer) -> Int -> Int -> (Integer, (Char -> Int)) -> Action tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = do numericUnderscores <- getBit NumericUnderscoresBit -- #14473 let src = lexemeToString buf len when ((not numericUnderscores) && ('_' `elem` src)) $ do pState <- getPState addError (RealSrcSpan (last_loc pState)) $ text "Use NumericUnderscores to allow underscores in integer literals" return $ L span $ itint (SourceText src) $! transint $ parseUnsignedInteger (offsetBytes transbuf buf) (subtract translen len) radix char_to_int tok_num :: (Integer -> Integer) -> Int -> Int -> (Integer, (Char->Int)) -> Action tok_num = tok_integral $ \case st@(SourceText ('-':_)) -> itint st (const True) st@(SourceText _) -> itint st (const False) st@NoSourceText -> itint st (< 0) where itint :: SourceText -> (Integer -> Bool) -> Integer -> Token itint !st is_negative !val = ITinteger ((IL st $! is_negative val) val) tok_primint :: (Integer -> Integer) -> Int -> Int -> (Integer, (Char->Int)) -> Action tok_primint = tok_integral ITprimint tok_primword :: Int -> Int -> (Integer, (Char->Int)) -> Action tok_primword = tok_integral ITprimword positive positive, negative :: (Integer -> Integer) positive = id negative = negate decimal, octal, hexadecimal :: (Integer, Char -> Int) decimal = (10,octDecDigit) binary = (2,octDecDigit) octal = (8,octDecDigit) hexadecimal = (16,hexDigit) -- readRational can understand negative rationals, exponents, everything. tok_frac :: Int -> (String -> Token) -> Action tok_frac drop f span buf len = do numericUnderscores <- getBit NumericUnderscoresBit -- #14473 let src = lexemeToString buf (len-drop) when ((not numericUnderscores) && ('_' `elem` src)) $ do pState <- getPState addError (RealSrcSpan (last_loc pState)) $ text "Use NumericUnderscores to allow underscores in floating literals" return (L span $! (f $! src)) tok_float, tok_primfloat, tok_primdouble :: String -> Token tok_float str = ITrational $! readFractionalLit str tok_hex_float str = ITrational $! readHexFractionalLit str tok_primfloat str = ITprimfloat $! readFractionalLit str tok_primdouble str = ITprimdouble $! readFractionalLit str readFractionalLit :: String -> FractionalLit readFractionalLit str = ((FL $! (SourceText str)) $! is_neg) $! readRational str where is_neg = case str of ('-':_) -> True _ -> False readHexFractionalLit :: String -> FractionalLit readHexFractionalLit str = FL { fl_text = SourceText str , fl_neg = case str of '-' : _ -> True _ -> False , fl_value = readHexRational str } -- ----------------------------------------------------------------------------- -- Layout processing -- we're at the first token on a line, insert layout tokens if necessary do_bol :: Action do_bol span _str _len = do -- See Note [Nested comment line pragmas] b <- getBit InNestedCommentBit if b then return (L span ITcomment_line_prag) else do (pos, gen_semic) <- getOffside case pos of LT -> do --trace "layout: inserting '}'" $ do popContext -- do NOT pop the lex state, we might have a ';' to insert return (L span ITvccurly) EQ | gen_semic -> do --trace "layout: inserting ';'" $ do _ <- popLexState return (L span ITsemi) _ -> do _ <- popLexState lexToken -- certain keywords put us in the "layout" state, where we might -- add an opening curly brace. maybe_layout :: Token -> P () maybe_layout t = do -- If the alternative layout rule is enabled then -- we never create an implicit layout context here. -- Layout is handled XXX instead. -- The code for closing implicit contexts, or -- inserting implicit semi-colons, is therefore -- irrelevant as it only applies in an implicit -- context. alr <- getBit AlternativeLayoutRuleBit unless alr $ f t where f ITdo = pushLexState layout_do f ITmdo = pushLexState layout_do f ITof = pushLexState layout f ITlcase = pushLexState layout f ITlet = pushLexState layout f ITwhere = pushLexState layout f ITrec = pushLexState layout f ITif = pushLexState layout_if f _ = return () -- Pushing a new implicit layout context. If the indentation of the -- next token is not greater than the previous layout context, then -- Haskell 98 says that the new layout context should be empty; that is -- the lexer must generate {}. -- -- We are slightly more lenient than this: when the new context is started -- by a 'do', then we allow the new context to be at the same indentation as -- the previous context. This is what the 'strict' argument is for. new_layout_context :: Bool -> Bool -> Token -> Action new_layout_context strict gen_semic tok span _buf len = do _ <- popLexState (AI l _) <- getInput let offset = srcLocCol l - len ctx <- getContext nondecreasing <- getBit NondecreasingIndentationBit let strict' = strict || not nondecreasing case ctx of Layout prev_off _ : _ | (strict' && prev_off >= offset || not strict' && prev_off > offset) -> do -- token is indented to the left of the previous context. -- we must generate a {} sequence now. pushLexState layout_left return (L span tok) _ -> do setContext (Layout offset gen_semic : ctx) return (L span tok) do_layout_left :: Action do_layout_left span _buf _len = do _ <- popLexState pushLexState bol -- we must be at the start of a line return (L span ITvccurly) -- ----------------------------------------------------------------------------- -- LINE pragmas setLineAndFile :: Int -> Action setLineAndFile code span buf len = do let src = lexemeToString buf (len - 1) -- drop trailing quotation mark linenumLen = length $ head $ words src linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit file = mkFastString $ go $ drop 1 $ dropWhile (/= '"') src -- skip everything through first quotation mark to get to the filename where go ('\\':c:cs) = c : go cs go (c:cs) = c : go cs go [] = [] -- decode escapes in the filename. e.g. on Windows -- when our filenames have backslashes in, gcc seems to -- escape the backslashes. One symptom of not doing this -- is that filenames in error messages look a bit strange: -- C:\\foo\bar.hs -- only the first backslash is doubled, because we apply -- System.FilePath.normalise before printing out -- filenames and it does not remove duplicate -- backslashes after the drive letter (should it?). setAlrLastLoc $ alrInitialLoc file setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span)) -- subtract one: the line number refers to the *following* line addSrcFile file _ <- popLexState pushLexState code lexToken setColumn :: Action setColumn span buf len = do let column = case reads (lexemeToString buf len) of [(column, _)] -> column _ -> error "setColumn: expected integer" -- shouldn't happen setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span) (fromIntegral (column :: Integer))) _ <- popLexState lexToken alrInitialLoc :: FastString -> RealSrcSpan alrInitialLoc file = mkRealSrcSpan loc loc where -- This is a hack to ensure that the first line in a file -- looks like it is after the initial location: loc = mkRealSrcLoc file (-1) (-1) -- ----------------------------------------------------------------------------- -- Options, includes and language pragmas. lex_string_prag :: (String -> Token) -> Action lex_string_prag mkTok span _buf _len = do input <- getInput start <- getRealSrcLoc tok <- go [] input end <- getRealSrcLoc return (L (mkRealSrcSpan start end) tok) where go acc input = if isString input "#-}" then do setInput input return (mkTok (reverse acc)) else case alexGetChar input of Just (c,i) -> go (c:acc) i Nothing -> err input isString _ [] = True isString i (x:xs) = case alexGetChar i of Just (c,i') | c == x -> isString i' xs _other -> False err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma" -- ----------------------------------------------------------------------------- -- Strings & Chars -- This stuff is horrible. I hates it. lex_string_tok :: Action lex_string_tok span buf _len = do tok <- lex_string "" (AI end bufEnd) <- getInput let tok' = case tok of ITprimstring _ bs -> ITprimstring (SourceText src) bs ITstring _ s -> ITstring (SourceText src) s _ -> panic "lex_string_tok" src = lexemeToString buf (cur bufEnd - cur buf) return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok') lex_string :: String -> P Token lex_string s = do i <- getInput case alexGetChar' i of Nothing -> lit_error i Just ('"',i) -> do setInput i let s' = reverse s magicHash <- getBit MagicHashBit if magicHash then do i <- getInput case alexGetChar' i of Just ('#',i) -> do setInput i when (any (> '\xFF') s') $ do pState <- getPState addError (RealSrcSpan (last_loc pState)) $ text "primitive string literal must contain only characters <= \'\\xFF\'" return (ITprimstring (SourceText s') (unsafeMkByteString s')) _other -> return (ITstring (SourceText s') (mkFastString s')) else return (ITstring (SourceText s') (mkFastString s')) Just ('\\',i) | Just ('&',i) <- next -> do setInput i; lex_string s | Just (c,i) <- next, c <= '\x7f' && is_space c -> do -- is_space only works for <= '\x7f' (#3751, #5425) setInput i; lex_stringgap s where next = alexGetChar' i Just (c, i1) -> do case c of '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s) c | isAny c -> do setInput i1; lex_string (c:s) _other -> lit_error i lex_stringgap :: String -> P Token lex_stringgap s = do i <- getInput c <- getCharOrFail i case c of '\\' -> lex_string s c | c <= '\x7f' && is_space c -> lex_stringgap s -- is_space only works for <= '\x7f' (#3751, #5425) _other -> lit_error i lex_char_tok :: Action -- Here we are basically parsing character literals, such as 'x' or '\n' -- but we additionally spot 'x and ''T, returning ITsimpleQuote and -- ITtyQuote respectively, but WITHOUT CONSUMING the x or T part -- (the parser does that). -- So we have to do two characters of lookahead: when we see 'x we need to -- see if there's a trailing quote lex_char_tok span buf _len = do -- We've seen ' i1 <- getInput -- Look ahead to first character let loc = realSrcSpanStart span case alexGetChar' i1 of Nothing -> lit_error i1 Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' setInput i2 return (L (mkRealSrcSpan loc end2) ITtyQuote) Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash setInput i2 lit_ch <- lex_escape i3 <- getInput mc <- getCharOrFail i3 -- Trailing quote if mc == '\'' then finish_char_tok buf loc lit_ch else lit_error i3 Just (c, i2@(AI _end2 _)) | not (isAny c) -> lit_error i1 | otherwise -> -- We've seen 'x, where x is a valid character -- (i.e. not newline etc) but not a quote or backslash case alexGetChar' i2 of -- Look ahead one more character Just ('\'', i3) -> do -- We've seen 'x' setInput i3 finish_char_tok buf loc c _other -> do -- We've seen 'x not followed by quote -- (including the possibility of EOF) -- Just parse the quote only let (AI end _) = i1 return (L (mkRealSrcSpan loc end) ITsimpleQuote) finish_char_tok :: StringBuffer -> RealSrcLoc -> Char -> P (RealLocated Token) finish_char_tok buf loc ch -- We've already seen the closing quote -- Just need to check for trailing # = do magicHash <- getBit MagicHashBit i@(AI end bufEnd) <- getInput let src = lexemeToString buf (cur bufEnd - cur buf) if magicHash then do case alexGetChar' i of Just ('#',i@(AI end _)) -> do setInput i return (L (mkRealSrcSpan loc end) (ITprimchar (SourceText src) ch)) _other -> return (L (mkRealSrcSpan loc end) (ITchar (SourceText src) ch)) else do return (L (mkRealSrcSpan loc end) (ITchar (SourceText src) ch)) isAny :: Char -> Bool isAny c | c > '\x7f' = isPrint c | otherwise = is_any c lex_escape :: P Char lex_escape = do i0 <- getInput c <- getCharOrFail i0 case c of 'a' -> return '\a' 'b' -> return '\b' 'f' -> return '\f' 'n' -> return '\n' 'r' -> return '\r' 't' -> return '\t' 'v' -> return '\v' '\\' -> return '\\' '"' -> return '\"' '\'' -> return '\'' '^' -> do i1 <- getInput c <- getCharOrFail i1 if c >= '@' && c <= '_' then return (chr (ord c - ord '@')) else lit_error i1 'x' -> readNum is_hexdigit 16 hexDigit 'o' -> readNum is_octdigit 8 octDecDigit x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) c1 -> do i <- getInput case alexGetChar' i of Nothing -> lit_error i0 Just (c2,i2) -> case alexGetChar' i2 of Nothing -> do lit_error i0 Just (c3,i3) -> let str = [c1,c2,c3] in case [ (c,rest) | (p,c) <- silly_escape_chars, Just rest <- [stripPrefix p str] ] of (escape_char,[]):_ -> do setInput i3 return escape_char (escape_char,_:_):_ -> do setInput i2 return escape_char [] -> lit_error i0 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char readNum is_digit base conv = do i <- getInput c <- getCharOrFail i if is_digit c then readNum2 is_digit base conv (conv c) else lit_error i readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char readNum2 is_digit base conv i = do input <- getInput read i input where read i input = do case alexGetChar' input of Just (c,input') | is_digit c -> do let i' = i*base + conv c if i' > 0x10ffff then setInput input >> lexError "numeric escape sequence out of range" else read i' input' _other -> do setInput input; return (chr i) silly_escape_chars :: [(String, Char)] silly_escape_chars = [ ("NUL", '\NUL'), ("SOH", '\SOH'), ("STX", '\STX'), ("ETX", '\ETX'), ("EOT", '\EOT'), ("ENQ", '\ENQ'), ("ACK", '\ACK'), ("BEL", '\BEL'), ("BS", '\BS'), ("HT", '\HT'), ("LF", '\LF'), ("VT", '\VT'), ("FF", '\FF'), ("CR", '\CR'), ("SO", '\SO'), ("SI", '\SI'), ("DLE", '\DLE'), ("DC1", '\DC1'), ("DC2", '\DC2'), ("DC3", '\DC3'), ("DC4", '\DC4'), ("NAK", '\NAK'), ("SYN", '\SYN'), ("ETB", '\ETB'), ("CAN", '\CAN'), ("EM", '\EM'), ("SUB", '\SUB'), ("ESC", '\ESC'), ("FS", '\FS'), ("GS", '\GS'), ("RS", '\RS'), ("US", '\US'), ("SP", '\SP'), ("DEL", '\DEL') ] -- before calling lit_error, ensure that the current input is pointing to -- the position of the error in the buffer. This is so that we can report -- a correct location to the user, but also so we can detect UTF-8 decoding -- errors if they occur. lit_error :: AlexInput -> P a lit_error i = do setInput i; lexError "lexical error in string/character literal" getCharOrFail :: AlexInput -> P Char getCharOrFail i = do case alexGetChar' i of Nothing -> lexError "unexpected end-of-file in string/character literal" Just (c,i) -> do setInput i; return c -- ----------------------------------------------------------------------------- -- QuasiQuote lex_qquasiquote_tok :: Action lex_qquasiquote_tok span buf len = do let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False quoteStart <- getRealSrcLoc quote <- lex_quasiquote quoteStart "" end <- getRealSrcLoc return (L (mkRealSrcSpan (realSrcSpanStart span) end) (ITqQuasiQuote (qual, quoter, mkFastString (reverse quote), mkRealSrcSpan quoteStart end))) lex_quasiquote_tok :: Action lex_quasiquote_tok span buf len = do let quoter = tail (lexemeToString buf (len - 1)) -- 'tail' drops the initial '[', -- while the -1 drops the trailing '|' quoteStart <- getRealSrcLoc quote <- lex_quasiquote quoteStart "" end <- getRealSrcLoc return (L (mkRealSrcSpan (realSrcSpanStart span) end) (ITquasiQuote (mkFastString quoter, mkFastString (reverse quote), mkRealSrcSpan quoteStart end))) lex_quasiquote :: RealSrcLoc -> String -> P String lex_quasiquote start s = do i <- getInput case alexGetChar' i of Nothing -> quasiquote_error start -- NB: The string "|]" terminates the quasiquote, -- with absolutely no escaping. See the extensive -- discussion on #5348 for why there is no -- escape handling. Just ('|',i) | Just (']',i) <- alexGetChar' i -> do { setInput i; return s } Just (c, i) -> do setInput i; lex_quasiquote start (c : s) quasiquote_error :: RealSrcLoc -> P a quasiquote_error start = do (AI end buf) <- getInput reportLexError start end buf "unterminated quasiquotation" -- ----------------------------------------------------------------------------- -- Warnings warnTab :: Action warnTab srcspan _buf _len = do addTabWarning srcspan lexToken warnThen :: WarningFlag -> SDoc -> Action -> Action warnThen option warning action srcspan buf len = do addWarning option (RealSrcSpan srcspan) warning action srcspan buf len -- ----------------------------------------------------------------------------- -- The Parse Monad -- | Do we want to generate ';' layout tokens? In some cases we just want to -- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates -- alternatives (unlike a `case` expression where we need ';' to as a separator -- between alternatives). type GenSemic = Bool generateSemic, dontGenerateSemic :: GenSemic generateSemic = True dontGenerateSemic = False data LayoutContext = NoLayout | Layout !Int !GenSemic deriving Show -- | The result of running a parser. data ParseResult a = POk -- ^ The parser has consumed a (possibly empty) prefix -- of the input and produced a result. Use 'getMessages' -- to check for accumulated warnings and non-fatal errors. PState -- ^ The resulting parsing state. Can be used to resume parsing. a -- ^ The resulting value. | PFailed -- ^ The parser has consumed a (possibly empty) prefix -- of the input and failed. PState -- ^ The parsing state right before failure, including the fatal -- parse error. 'getMessages' and 'getErrorMessages' must return -- a non-empty bag of errors. -- | Test whether a 'WarningFlag' is set warnopt :: WarningFlag -> ParserFlags -> Bool warnopt f options = f `EnumSet.member` pWarningFlags options -- | The subset of the 'DynFlags' used by the parser. -- See 'mkParserFlags' or 'mkParserFlags'' for ways to construct this. data ParserFlags = ParserFlags { pWarningFlags :: EnumSet WarningFlag , pThisPackage :: UnitId -- ^ key of package currently being compiled , pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions } data PState = PState { buffer :: StringBuffer, options :: ParserFlags, -- This needs to take DynFlags as an argument until -- we have a fix for #10143 messages :: DynFlags -> Messages, tab_first :: Maybe RealSrcSpan, -- pos of first tab warning in the file tab_count :: !Int, -- number of tab warnings in the file last_tk :: Maybe Token, last_loc :: RealSrcSpan, -- pos of previous token last_len :: !Int, -- len of previous token loc :: RealSrcLoc, -- current loc (end of prev token + 1) context :: [LayoutContext], lex_state :: [Int], srcfiles :: [FastString], -- Used in the alternative layout rule: -- These tokens are the next ones to be sent out. They are -- just blindly emitted, without the rule looking at them again: alr_pending_implicit_tokens :: [RealLocated Token], -- This is the next token to be considered or, if it is Nothing, -- we need to get the next token from the input stream: alr_next_token :: Maybe (RealLocated Token), -- This is what we consider to be the location of the last token -- emitted: alr_last_loc :: RealSrcSpan, -- The stack of layout contexts: alr_context :: [ALRContext], -- Are we expecting a '{'? If it's Just, then the ALRLayout tells -- us what sort of layout the '{' will open: alr_expecting_ocurly :: Maybe ALRLayout, -- Have we just had the '}' for a let block? If so, than an 'in' -- token doesn't need to close anything: alr_justClosedExplicitLetBlock :: Bool, -- The next three are used to implement Annotations giving the -- locations of 'noise' tokens in the source, so that users of -- the GHC API can do source to source conversions. -- See note [Api annotations] in ApiAnnotation.hs annotations :: [(ApiAnnKey,[SrcSpan])], comment_q :: [Located AnnotationComment], annotations_comments :: [(SrcSpan,[Located AnnotationComment])] } -- last_loc and last_len are used when generating error messages, -- and in pushCurrentContext only. Sigh, if only Happy passed the -- current token to happyError, we could at least get rid of last_len. -- Getting rid of last_loc would require finding another way to -- implement pushCurrentContext (which is only called from one place). data ALRContext = ALRNoLayout Bool{- does it contain commas? -} Bool{- is it a 'let' block? -} | ALRLayout ALRLayout Int data ALRLayout = ALRLayoutLet | ALRLayoutWhere | ALRLayoutOf | ALRLayoutDo -- | The parsing monad, isomorphic to @StateT PState Maybe@. newtype P a = P { unP :: PState -> ParseResult a } instance Functor P where fmap = liftM instance Applicative P where pure = returnP (<*>) = ap instance Monad P where (>>=) = thenP #if !MIN_VERSION_base(4,13,0) fail = MonadFail.fail #endif instance MonadFail.MonadFail P where fail = failMsgP returnP :: a -> P a returnP a = a `seq` (P $ \s -> POk s a) thenP :: P a -> (a -> P b) -> P b (P m) `thenP` k = P $ \ s -> case m s of POk s1 a -> (unP (k a)) s1 PFailed s1 -> PFailed s1 failMsgP :: String -> P a failMsgP msg = do pState <- getPState addFatalError (RealSrcSpan (last_loc pState)) (text msg) failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a failLocMsgP loc1 loc2 str = addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str) getPState :: P PState getPState = P $ \s -> POk s s withThisPackage :: (UnitId -> a) -> P a withThisPackage f = P $ \s@(PState{options = o}) -> POk s (f (pThisPackage o)) getExts :: P ExtsBitmap getExts = P $ \s -> POk s (pExtsBitmap . options $ s) setExts :: (ExtsBitmap -> ExtsBitmap) -> P () setExts f = P $ \s -> POk s { options = let p = options s in p { pExtsBitmap = f (pExtsBitmap p) } } () setSrcLoc :: RealSrcLoc -> P () setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () getRealSrcLoc :: P RealSrcLoc getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc addSrcFile :: FastString -> P () addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () setLastToken :: RealSrcSpan -> Int -> P () setLastToken loc len = P $ \s -> POk s { last_loc=loc, last_len=len } () setLastTk :: Token -> P () setLastTk tk = P $ \s -> POk s { last_tk = Just tk } () getLastTk :: P (Maybe Token) getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk data AlexInput = AI RealSrcLoc StringBuffer {- Note [Unicode in Alex] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Although newer versions of Alex support unicode, this grammar is processed with the old style '--latin1' behaviour. This means that when implementing the functions alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) alexInputPrevChar :: AlexInput -> Char which Alex uses to take apart our 'AlexInput', we must * return a latin1 character in the 'Word8' that 'alexGetByte' expects * return a latin1 character in 'alexInputPrevChar'. We handle this in 'adjustChar' by squishing entire classes of unicode characters into single bytes. -} {-# INLINE adjustChar #-} adjustChar :: Char -> Word8 adjustChar c = fromIntegral $ ord adj_c where non_graphic = '\x00' upper = '\x01' lower = '\x02' digit = '\x03' symbol = '\x04' space = '\x05' other_graphic = '\x06' uniidchar = '\x07' adj_c | c <= '\x07' = non_graphic | c <= '\x7f' = c -- Alex doesn't handle Unicode, so when Unicode -- character is encountered we output these values -- with the actual character value hidden in the state. | otherwise = -- NB: The logic behind these definitions is also reflected -- in basicTypes/Lexeme.hs -- Any changes here should likely be reflected there. case generalCategory c of UppercaseLetter -> upper LowercaseLetter -> lower TitlecaseLetter -> upper ModifierLetter -> uniidchar -- see #10196 OtherLetter -> lower -- see #1103 NonSpacingMark -> uniidchar -- see #7650 SpacingCombiningMark -> other_graphic EnclosingMark -> other_graphic DecimalNumber -> digit LetterNumber -> other_graphic OtherNumber -> digit -- see #4373 ConnectorPunctuation -> symbol DashPunctuation -> symbol OpenPunctuation -> other_graphic ClosePunctuation -> other_graphic InitialQuote -> other_graphic FinalQuote -> other_graphic OtherPunctuation -> symbol MathSymbol -> symbol CurrencySymbol -> symbol ModifierSymbol -> symbol OtherSymbol -> symbol Space -> space _other -> non_graphic -- Getting the previous 'Char' isn't enough here - we need to convert it into -- the same format that 'alexGetByte' would have produced. -- -- See Note [Unicode in Alex] and #13986. alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (AI _ buf) = chr (fromIntegral (adjustChar pc)) where pc = prevChar buf '\n' -- backwards compatibility for Alex 2.x alexGetChar :: AlexInput -> Maybe (Char,AlexInput) alexGetChar inp = case alexGetByte inp of Nothing -> Nothing Just (b,i) -> c `seq` Just (c,i) where c = chr $ fromIntegral b -- See Note [Unicode in Alex] alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) alexGetByte (AI loc s) | atEnd s = Nothing | otherwise = byte `seq` loc' `seq` s' `seq` --trace (show (ord c)) $ Just (byte, (AI loc' s')) where (c,s') = nextChar s loc' = advanceSrcLoc loc c byte = adjustChar c -- This version does not squash unicode characters, it is used when -- lexing strings. alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) alexGetChar' (AI loc s) | atEnd s = Nothing | otherwise = c `seq` loc' `seq` s' `seq` --trace (show (ord c)) $ Just (c, (AI loc' s')) where (c,s') = nextChar s loc' = advanceSrcLoc loc c getInput :: P AlexInput getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) setInput :: AlexInput -> P () setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () nextIsEOF :: P Bool nextIsEOF = do AI _ s <- getInput return $ atEnd s pushLexState :: Int -> P () pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () popLexState :: P Int popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls getLexState :: P Int getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls popNextToken :: P (Maybe (RealLocated Token)) popNextToken = P $ \s@PState{ alr_next_token = m } -> POk (s {alr_next_token = Nothing}) m activeContext :: P Bool activeContext = do ctxt <- getALRContext expc <- getAlrExpectingOCurly impt <- implicitTokenPending case (ctxt,expc) of ([],Nothing) -> return impt _other -> return True setAlrLastLoc :: RealSrcSpan -> P () setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () getAlrLastLoc :: P RealSrcSpan getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l getALRContext :: P [ALRContext] getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs setALRContext :: [ALRContext] -> P () setALRContext cs = P $ \s -> POk (s {alr_context = cs}) () getJustClosedExplicitLetBlock :: P Bool getJustClosedExplicitLetBlock = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b setJustClosedExplicitLetBlock :: Bool -> P () setJustClosedExplicitLetBlock b = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () setNextToken :: RealLocated Token -> P () setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () implicitTokenPending :: P Bool implicitTokenPending = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> case ts of [] -> POk s False _ -> POk s True popPendingImplicitToken :: P (Maybe (RealLocated Token)) popPendingImplicitToken = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> case ts of [] -> POk s Nothing (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) setPendingImplicitTokens :: [RealLocated Token] -> P () setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () getAlrExpectingOCurly :: P (Maybe ALRLayout) getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b setAlrExpectingOCurly :: Maybe ALRLayout -> P () setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () -- | For reasons of efficiency, boolean parsing flags (eg, language extensions -- or whether we are currently in a @RULE@ pragma) are represented by a bitmap -- stored in a @Word64@. type ExtsBitmap = Word64 xbit :: ExtBits -> ExtsBitmap xbit = bit . fromEnum xtest :: ExtBits -> ExtsBitmap -> Bool xtest ext xmap = testBit xmap (fromEnum ext) -- | Various boolean flags, mostly language extensions, that impact lexing and -- parsing. Note that a handful of these can change during lexing/parsing. data ExtBits -- Flags that are constant once parsing starts = FfiBit | InterruptibleFfiBit | CApiFfiBit | ArrowsBit | ThBit | ThQuotesBit | IpBit | OverloadedLabelsBit -- #x overloaded labels | ExplicitForallBit -- the 'forall' keyword | BangPatBit -- Tells the parser to understand bang-patterns -- (doesn't affect the lexer) | PatternSynonymsBit -- pattern synonyms | HaddockBit-- Lex and parse Haddock comments | MagicHashBit -- "#" in both functions and operators | RecursiveDoBit -- mdo | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc | UnboxedTuplesBit -- (# and #) | UnboxedSumsBit -- (# and #) | DatatypeContextsBit | MonadComprehensionsBit | TransformComprehensionsBit | QqBit -- enable quasiquoting | RawTokenStreamBit -- producing a token stream with all comments included | AlternativeLayoutRuleBit | ALRTransitionalBit | RelaxedLayoutBit | NondecreasingIndentationBit | SafeHaskellBit | TraditionalRecordSyntaxBit | ExplicitNamespacesBit | LambdaCaseBit | BinaryLiteralsBit | NegativeLiteralsBit | HexFloatLiteralsBit | TypeApplicationsBit | StaticPointersBit | NumericUnderscoresBit | StarIsTypeBit | BlockArgumentsBit | NPlusKPatternsBit | DoAndIfThenElseBit | MultiWayIfBit | GadtSyntaxBit | ImportQualifiedPostBit -- Flags that are updated once parsing starts | InRulePragBit | InNestedCommentBit -- See Note [Nested comment line pragmas] | UsePosPragsBit -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' -- update the internal position. Otherwise, those pragmas are lexed as -- tokens of their own. deriving Enum -- PState for parsing options pragmas -- pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState pragState dynflags buf loc = (mkPState dynflags buf loc) { lex_state = [bol, option_prags, 0] } {-# INLINE mkParserFlags' #-} mkParserFlags' :: EnumSet WarningFlag -- ^ warnings flags enabled -> EnumSet LangExt.Extension -- ^ permitted language extensions enabled -> UnitId -- ^ key of package currently being compiled -> Bool -- ^ are safe imports on? -> Bool -- ^ keeping Haddock comment tokens -> Bool -- ^ keep regular comment tokens -> Bool -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' update -- the internal position kept by the parser. Otherwise, those pragmas are -- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens. -> ParserFlags -- ^ Given exactly the information needed, set up the 'ParserFlags' mkParserFlags' warningFlags extensionFlags thisPackage safeImports isHaddock rawTokStream usePosPrags = ParserFlags { pWarningFlags = warningFlags , pThisPackage = thisPackage , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits } where safeHaskellBit = SafeHaskellBit `setBitIf` safeImports langExtBits = FfiBit `xoptBit` LangExt.ForeignFunctionInterface .|. InterruptibleFfiBit `xoptBit` LangExt.InterruptibleFFI .|. CApiFfiBit `xoptBit` LangExt.CApiFFI .|. ArrowsBit `xoptBit` LangExt.Arrows .|. ThBit `xoptBit` LangExt.TemplateHaskell .|. ThQuotesBit `xoptBit` LangExt.TemplateHaskellQuotes .|. QqBit `xoptBit` LangExt.QuasiQuotes .|. IpBit `xoptBit` LangExt.ImplicitParams .|. OverloadedLabelsBit `xoptBit` LangExt.OverloadedLabels .|. ExplicitForallBit `xoptBit` LangExt.ExplicitForAll .|. BangPatBit `xoptBit` LangExt.BangPatterns .|. MagicHashBit `xoptBit` LangExt.MagicHash .|. RecursiveDoBit `xoptBit` LangExt.RecursiveDo .|. UnicodeSyntaxBit `xoptBit` LangExt.UnicodeSyntax .|. UnboxedTuplesBit `xoptBit` LangExt.UnboxedTuples .|. UnboxedSumsBit `xoptBit` LangExt.UnboxedSums .|. DatatypeContextsBit `xoptBit` LangExt.DatatypeContexts .|. TransformComprehensionsBit `xoptBit` LangExt.TransformListComp .|. MonadComprehensionsBit `xoptBit` LangExt.MonadComprehensions .|. AlternativeLayoutRuleBit `xoptBit` LangExt.AlternativeLayoutRule .|. ALRTransitionalBit `xoptBit` LangExt.AlternativeLayoutRuleTransitional .|. RelaxedLayoutBit `xoptBit` LangExt.RelaxedLayout .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation .|. TraditionalRecordSyntaxBit `xoptBit` LangExt.TraditionalRecordSyntax .|. ExplicitNamespacesBit `xoptBit` LangExt.ExplicitNamespaces .|. LambdaCaseBit `xoptBit` LangExt.LambdaCase .|. BinaryLiteralsBit `xoptBit` LangExt.BinaryLiterals .|. NegativeLiteralsBit `xoptBit` LangExt.NegativeLiterals .|. HexFloatLiteralsBit `xoptBit` LangExt.HexFloatLiterals .|. PatternSynonymsBit `xoptBit` LangExt.PatternSynonyms .|. TypeApplicationsBit `xoptBit` LangExt.TypeApplications .|. StaticPointersBit `xoptBit` LangExt.StaticPointers .|. NumericUnderscoresBit `xoptBit` LangExt.NumericUnderscores .|. StarIsTypeBit `xoptBit` LangExt.StarIsType .|. BlockArgumentsBit `xoptBit` LangExt.BlockArguments .|. NPlusKPatternsBit `xoptBit` LangExt.NPlusKPatterns .|. DoAndIfThenElseBit `xoptBit` LangExt.DoAndIfThenElse .|. MultiWayIfBit `xoptBit` LangExt.MultiWayIf .|. GadtSyntaxBit `xoptBit` LangExt.GADTSyntax .|. ImportQualifiedPostBit `xoptBit` LangExt.ImportQualifiedPost optBits = HaddockBit `setBitIf` isHaddock .|. RawTokenStreamBit `setBitIf` rawTokStream .|. UsePosPragsBit `setBitIf` usePosPrags xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags setBitIf :: ExtBits -> Bool -> ExtsBitmap b `setBitIf` cond | cond = xbit b | otherwise = 0 -- | Extracts the flag information needed for parsing mkParserFlags :: DynFlags -> ParserFlags mkParserFlags = mkParserFlags' <$> DynFlags.warningFlags <*> DynFlags.extensionFlags <*> DynFlags.thisPackage <*> safeImportsOn <*> gopt Opt_Haddock <*> gopt Opt_KeepRawTokenStream <*> const True -- | Creates a parse state from a 'DynFlags' value mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState mkPState flags = mkPStatePure (mkParserFlags flags) -- | Creates a parse state from a 'ParserFlags' value mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState mkPStatePure options buf loc = PState { buffer = buf, options = options, messages = const emptyMessages, tab_first = Nothing, tab_count = 0, last_tk = Nothing, last_loc = mkRealSrcSpan loc loc, last_len = 0, loc = loc, context = [], lex_state = [bol, 0], srcfiles = [], alr_pending_implicit_tokens = [], alr_next_token = Nothing, alr_last_loc = alrInitialLoc (fsLit ""), alr_context = [], alr_expecting_ocurly = Nothing, alr_justClosedExplicitLetBlock = False, annotations = [], comment_q = [], annotations_comments = [] } -- | An mtl-style class for monads that support parsing-related operations. -- For example, sometimes we make a second pass over the parsing results to validate, -- disambiguate, or rearrange them, and we do so in the PV monad which cannot consume -- input but can report parsing errors, check for extension bits, and accumulate -- parsing annotations. Both P and PV are instances of MonadP. -- -- MonadP grants us convenient overloading. The other option is to have separate operations -- for each monad: addErrorP vs addErrorPV, getBitP vs getBitPV, and so on. -- class Monad m => MonadP m where -- | Add a non-fatal error. Use this when the parser can produce a result -- despite the error. -- -- For example, when GHC encounters a @forall@ in a type, -- but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@ -- as if @-XExplicitForAll@ was enabled, adding a non-fatal error to -- the accumulator. -- -- Control flow wise, non-fatal errors act like warnings: they are added -- to the accumulator and parsing continues. This allows GHC to report -- more than one parse error per file. -- addError :: SrcSpan -> SDoc -> m () -- | Add a warning to the accumulator. -- Use 'getMessages' to get the accumulated warnings. addWarning :: WarningFlag -> SrcSpan -> SDoc -> m () -- | Add a fatal error. This will be the last error reported by the parser, and -- the parser will not produce any result, ending in a 'PFailed' state. addFatalError :: SrcSpan -> SDoc -> m a -- | Check if a given flag is currently set in the bitmap. getBit :: ExtBits -> m Bool -- | Given a location and a list of AddAnn, apply them all to the location. addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct -> AnnKeywordId -- The first two parameters are the key -> SrcSpan -- The location of the keyword itself -> m () appendError :: SrcSpan -> SDoc -> (DynFlags -> Messages) -> (DynFlags -> Messages) appendError srcspan msg m = \d -> let (ws, es) = m d errormsg = mkErrMsg d srcspan alwaysQualify msg es' = es `snocBag` errormsg in (ws, es') appendWarning :: ParserFlags -> WarningFlag -> SrcSpan -> SDoc -> (DynFlags -> Messages) -> (DynFlags -> Messages) appendWarning o option srcspan warning m = \d -> let (ws, es) = m d warning' = makeIntoWarning (Reason option) $ mkWarnMsg d srcspan alwaysQualify warning ws' = if warnopt option o then ws `snocBag` warning' else ws in (ws', es) instance MonadP P where addError srcspan msg = P $ \s@PState{messages=m} -> POk s{messages=appendError srcspan msg m} () addWarning option srcspan warning = P $ \s@PState{messages=m, options=o} -> POk s{messages=appendWarning o option srcspan warning m} () addFatalError span msg = addError span msg >> P PFailed getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s) in b `seq` POk s b addAnnotation l a v = do addAnnotationOnly l a v allocateCommentsP l addAnnsAt :: MonadP m => SrcSpan -> [AddAnn] -> m () addAnnsAt l = mapM_ (\(AddAnn a v) -> addAnnotation l a v) addTabWarning :: RealSrcSpan -> P () addTabWarning srcspan = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} -> let tf' = if isJust tf then tf else Just srcspan tc' = tc + 1 s' = if warnopt Opt_WarnTabs o then s{tab_first = tf', tab_count = tc'} else s in POk s' () mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg mkTabWarning PState{tab_first=tf, tab_count=tc} d = let middle = if tc == 1 then text "" else text ", and in" <+> speakNOf (tc - 1) (text "further location") message = text "Tab character found here" <> middle <> text "." $+$ text "Please use spaces instead." in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $ mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf -- | Get a bag of the errors that have been accumulated so far. -- Does not take -Werror into account. getErrorMessages :: PState -> DynFlags -> ErrorMessages getErrorMessages PState{messages=m} d = let (_, es) = m d in es -- | Get the warnings and errors accumulated so far. -- Does not take -Werror into account. getMessages :: PState -> DynFlags -> Messages getMessages p@PState{messages=m} d = let (ws, es) = m d tabwarning = mkTabWarning p d ws' = maybe ws (`consBag` ws) tabwarning in (ws', es) getContext :: P [LayoutContext] getContext = P $ \s@PState{context=ctx} -> POk s ctx setContext :: [LayoutContext] -> P () setContext ctx = P $ \s -> POk s{context=ctx} () popContext :: P () popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx, last_len = len, last_loc = last_loc }) -> case ctx of (_:tl) -> POk s{ context = tl } () [] -> unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s -- Push a new layout context at the indentation of the last token read. pushCurrentContext :: GenSemic -> P () pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } -> POk s{context = Layout (srcSpanStartCol loc) gen_semic : ctx} () -- This is only used at the outer level of a module when the 'module' keyword is -- missing. pushModuleContext :: P () pushModuleContext = pushCurrentContext generateSemic getOffside :: P (Ordering, Bool) getOffside = P $ \s@PState{last_loc=loc, context=stk} -> let offs = srcSpanStartCol loc in let ord = case stk of Layout n gen_semic : _ -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ (compare offs n, gen_semic) _ -> (GT, dontGenerateSemic) in POk s ord -- --------------------------------------------------------------------------- -- Construct a parse error srcParseErr :: ParserFlags -> StringBuffer -- current buffer (placed just after the last token) -> Int -- length of the previous token -> MsgDoc srcParseErr options buf len = if null token then text "parse error (possibly incorrect indentation or mismatched brackets)" else text "parse error on input" <+> quotes (text token) $$ ppWhen (not th_enabled && token == "$") -- #7396 (text "Perhaps you intended to use TemplateHaskell") $$ ppWhen (token == "<-") (if mdoInLast100 then text "Perhaps you intended to use RecursiveDo" else text "Perhaps this statement should be within a 'do' block?") $$ ppWhen (token == "=" && doInLast100) -- #15849 (text "Perhaps you need a 'let' in a 'do' block?" $$ text "e.g. 'let x = 5' instead of 'x = 5'") $$ ppWhen (not ps_enabled && pattern == "pattern ") -- #12429 (text "Perhaps you intended to use PatternSynonyms") where token = lexemeToString (offsetBytes (-len) buf) len pattern = decodePrevNChars 8 buf last100 = decodePrevNChars 100 buf doInLast100 = "do" `isInfixOf` last100 mdoInLast100 = "mdo" `isInfixOf` last100 th_enabled = ThBit `xtest` pExtsBitmap options ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options -- Report a parse failure, giving the span of the previous token as -- the location of the error. This is the entry point for errors -- detected during parsing. srcParseFail :: P a srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len, last_loc = last_loc } -> unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s -- A lexical error is reported at a particular position in the source file, -- not over a token range. lexError :: String -> P a lexError str = do loc <- getRealSrcLoc (AI end buf) <- getInput reportLexError loc end buf str -- ----------------------------------------------------------------------------- -- This is the top-level function: called from the parser each time a -- new token is to be read from the input. lexer :: Bool -> (Located Token -> P a) -> P a lexer queueComments cont = do alr <- getBit AlternativeLayoutRuleBit let lexTokenFun = if alr then lexTokenAlr else lexToken (L span tok) <- lexTokenFun --trace ("token: " ++ show tok) $ do case tok of ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span) _ -> return () if (queueComments && isDocComment tok) then queueComment (L (RealSrcSpan span) tok) else return () if (queueComments && isComment tok) then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont else cont (L (RealSrcSpan span) tok) lexTokenAlr :: P (RealLocated Token) lexTokenAlr = do mPending <- popPendingImplicitToken t <- case mPending of Nothing -> do mNext <- popNextToken t <- case mNext of Nothing -> lexToken Just next -> return next alternativeLayoutRuleToken t Just t -> return t setAlrLastLoc (getRealSrcSpan t) case unRealSrcSpan t of ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) ITlcase -> setAlrExpectingOCurly (Just ALRLayoutOf) ITdo -> setAlrExpectingOCurly (Just ALRLayoutDo) ITmdo -> setAlrExpectingOCurly (Just ALRLayoutDo) ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo) _ -> return () return t alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token) alternativeLayoutRuleToken t = do context <- getALRContext lastLoc <- getAlrLastLoc mExpectingOCurly <- getAlrExpectingOCurly transitional <- getBit ALRTransitionalBit justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock setJustClosedExplicitLetBlock False let thisLoc = getRealSrcSpan t thisCol = srcSpanStartCol thisLoc newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc case (unRealSrcSpan t, context, mExpectingOCurly) of -- This case handles a GHC extension to the original H98 -- layout rule... (ITocurly, _, Just alrLayout) -> do setAlrExpectingOCurly Nothing let isLet = case alrLayout of ALRLayoutLet -> True _ -> False setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context) return t -- ...and makes this case unnecessary {- -- I think our implicit open-curly handling is slightly -- different to John's, in how it interacts with newlines -- and "in" (ITocurly, _, Just _) -> do setAlrExpectingOCurly Nothing setNextToken t lexTokenAlr -} (_, ALRLayout _ col : _ls, Just expectingOCurly) | (thisCol > col) || (thisCol == col && isNonDecreasingIndentation expectingOCurly) -> do setAlrExpectingOCurly Nothing setALRContext (ALRLayout expectingOCurly thisCol : context) setNextToken t return (L thisLoc ITvocurly) | otherwise -> do setAlrExpectingOCurly Nothing setPendingImplicitTokens [L lastLoc ITvccurly] setNextToken t return (L lastLoc ITvocurly) (_, _, Just expectingOCurly) -> do setAlrExpectingOCurly Nothing setALRContext (ALRLayout expectingOCurly thisCol : context) setNextToken t return (L thisLoc ITvocurly) -- We do the [] cases earlier than in the spec, as we -- have an actual EOF token (ITeof, ALRLayout _ _ : ls, _) -> do setALRContext ls setNextToken t return (L thisLoc ITvccurly) (ITeof, _, _) -> return t -- the other ITeof case omitted; general case below covers it (ITin, _, _) | justClosedExplicitLetBlock -> return t (ITin, ALRLayout ALRLayoutLet _ : ls, _) | newLine -> do setPendingImplicitTokens [t] setALRContext ls return (L thisLoc ITvccurly) -- This next case is to handle a transitional issue: (ITwhere, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> do addWarning Opt_WarnAlternativeLayoutRuleTransitional (RealSrcSpan thisLoc) (transitionalAlternativeLayoutWarning "`where' clause at the same depth as implicit layout block") setALRContext ls setNextToken t -- Note that we use lastLoc, as we may need to close -- more layouts, or give a semicolon return (L lastLoc ITvccurly) -- This next case is to handle a transitional issue: (ITvbar, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> do addWarning Opt_WarnAlternativeLayoutRuleTransitional (RealSrcSpan thisLoc) (transitionalAlternativeLayoutWarning "`|' at the same depth as implicit layout block") setALRContext ls setNextToken t -- Note that we use lastLoc, as we may need to close -- more layouts, or give a semicolon return (L lastLoc ITvccurly) (_, ALRLayout _ col : ls, _) | newLine && thisCol == col -> do setNextToken t let loc = realSrcSpanStart thisLoc zeroWidthLoc = mkRealSrcSpan loc loc return (L zeroWidthLoc ITsemi) | newLine && thisCol < col -> do setALRContext ls setNextToken t -- Note that we use lastLoc, as we may need to close -- more layouts, or give a semicolon return (L lastLoc ITvccurly) -- We need to handle close before open, as 'then' is both -- an open and a close (u, _, _) | isALRclose u -> case context of ALRLayout _ _ : ls -> do setALRContext ls setNextToken t return (L thisLoc ITvccurly) ALRNoLayout _ isLet : ls -> do let ls' = if isALRopen u then ALRNoLayout (containsCommas u) False : ls else ls setALRContext ls' when isLet $ setJustClosedExplicitLetBlock True return t [] -> do let ls = if isALRopen u then [ALRNoLayout (containsCommas u) False] else [] setALRContext ls -- XXX This is an error in John's code, but -- it looks reachable to me at first glance return t (u, _, _) | isALRopen u -> do setALRContext (ALRNoLayout (containsCommas u) False : context) return t (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> do setALRContext ls setPendingImplicitTokens [t] return (L thisLoc ITvccurly) (ITin, ALRLayout _ _ : ls, _) -> do setALRContext ls setNextToken t return (L thisLoc ITvccurly) -- the other ITin case omitted; general case below covers it (ITcomma, ALRLayout _ _ : ls, _) | topNoLayoutContainsCommas ls -> do setALRContext ls setNextToken t return (L thisLoc ITvccurly) (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) -> do setALRContext ls setPendingImplicitTokens [t] return (L thisLoc ITvccurly) -- the other ITwhere case omitted; general case below covers it (_, _, _) -> return t transitionalAlternativeLayoutWarning :: String -> SDoc transitionalAlternativeLayoutWarning msg = text "transitional layout will not be accepted in the future:" $$ text msg isALRopen :: Token -> Bool isALRopen ITcase = True isALRopen ITif = True isALRopen ITthen = True isALRopen IToparen = True isALRopen ITobrack = True isALRopen ITocurly = True -- GHC Extensions: isALRopen IToubxparen = True isALRopen ITparenEscape = True isALRopen ITparenTyEscape = True isALRopen _ = False isALRclose :: Token -> Bool isALRclose ITof = True isALRclose ITthen = True isALRclose ITelse = True isALRclose ITcparen = True isALRclose ITcbrack = True isALRclose ITccurly = True -- GHC Extensions: isALRclose ITcubxparen = True isALRclose _ = False isNonDecreasingIndentation :: ALRLayout -> Bool isNonDecreasingIndentation ALRLayoutDo = True isNonDecreasingIndentation _ = False containsCommas :: Token -> Bool containsCommas IToparen = True containsCommas ITobrack = True -- John doesn't have {} as containing commas, but records contain them, -- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs -- (defaultInstallDirs). containsCommas ITocurly = True -- GHC Extensions: containsCommas IToubxparen = True containsCommas _ = False topNoLayoutContainsCommas :: [ALRContext] -> Bool topNoLayoutContainsCommas [] = False topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b lexToken :: P (RealLocated Token) lexToken = do inp@(AI loc1 buf) <- getInput sc <- getLexState exts <- getExts case alexScanUser exts inp sc of AlexEOF -> do let span = mkRealSrcSpan loc1 loc1 setLastToken span 0 return (L span ITeof) AlexError (AI loc2 buf) -> reportLexError loc1 loc2 buf "lexical error" AlexSkip inp2 _ -> do setInput inp2 lexToken AlexToken inp2@(AI end buf2) _ t -> do setInput inp2 let span = mkRealSrcSpan loc1 end let bytes = byteDiff buf buf2 span `seq` setLastToken span bytes lt <- t span buf bytes case unRealSrcSpan lt of ITlineComment _ -> return lt ITblockComment _ -> return lt lt' -> do setLastTk lt' return lt reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a reportLexError loc1 loc2 buf str | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input") | otherwise = let c = fst (nextChar buf) in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] lexTokenStream buf loc dflags = unP go initState{ options = opts' } where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream initState@PState{ options = opts } = mkPState dflags' buf loc opts' = opts{ pExtsBitmap = complement (xbit UsePosPragsBit) .&. pExtsBitmap opts } go = do ltok <- lexer False return case ltok of L _ ITeof -> return [] _ -> liftM (ltok:) go linePrags = Map.singleton "line" linePrag fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag), ("options_ghc", lex_string_prag IToptions_prag), ("options_haddock", lex_string_prag ITdocOptions), ("language", token ITlanguage_prag), ("include", lex_string_prag ITinclude_prag)]) ignoredPrags = Map.fromList (map ignored pragmas) where ignored opt = (opt, nested_comment lexToken) impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"] options_pragmas = map ("options_" ++) impls -- CFILES is a hugs-only thing. pragmas = options_pragmas ++ ["cfiles", "contract"] oneWordPrags = Map.fromList [ ("rules", rulePrag), ("inline", strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))), ("inlinable", strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), ("inlineable", strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), -- Spelling variant ("notinline", strtoken (\s -> (ITinline_prag (SourceText s) NoInline FunLike))), ("specialize", strtoken (\s -> ITspec_prag (SourceText s))), ("source", strtoken (\s -> ITsource_prag (SourceText s))), ("warning", strtoken (\s -> ITwarning_prag (SourceText s))), ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))), ("scc", strtoken (\s -> ITscc_prag (SourceText s))), ("generated", strtoken (\s -> ITgenerated_prag (SourceText s))), ("core", strtoken (\s -> ITcore_prag (SourceText s))), ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))), ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))), ("ann", strtoken (\s -> ITann_prag (SourceText s))), ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))), ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))), ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))), ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))), ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))), ("ctype", strtoken (\s -> ITctype (SourceText s))), ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))), ("column", columnPrag) ] twoWordPrags = Map.fromList [ ("inline conlike", strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))), ("notinline conlike", strtoken (\s -> (ITinline_prag (SourceText s) NoInline ConLike))), ("specialize inline", strtoken (\s -> (ITspec_inline_prag (SourceText s) True))), ("specialize notinline", strtoken (\s -> (ITspec_inline_prag (SourceText s) False))) ] dispatch_pragmas :: Map String Action -> Action dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of Just found -> found span buf len Nothing -> lexError "unknown pragma" known_pragma :: Map String Action -> AlexAccPred ExtsBitmap known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) = isKnown && nextCharIsNot curbuf pragmaNameChar where l = lexemeToString startbuf (byteDiff startbuf curbuf) isKnown = isJust $ Map.lookup (clean_pragma l) prags pragmaNameChar c = isAlphaNum c || c == '_' clean_pragma :: String -> String clean_pragma prag = canon_ws (map toLower (unprefix prag)) where unprefix prag' = case stripPrefix "{-#" prag' of Just rest -> rest Nothing -> prag' canonical prag' = case prag' of "noinline" -> "notinline" "specialise" -> "specialize" "constructorlike" -> "conlike" _ -> prag' canon_ws s = unwords (map canonical (words s)) {- %************************************************************************ %* * Helper functions for generating annotations in the parser %* * %************************************************************************ -} -- | Encapsulated call to addAnnotation, requiring only the SrcSpan of -- the AST construct the annotation belongs to; together with the -- AnnKeywordId, this is the key of the annotation map. -- -- This type is useful for places in the parser where it is not yet -- known what SrcSpan an annotation should be added to. The most -- common situation is when we are parsing a list: the annotations -- need to be associated with the AST element that *contains* the -- list, not the list itself. 'AddAnn' lets us defer adding the -- annotations until we finish parsing the list and are now parsing -- the enclosing element; we then apply the 'AddAnn' to associate -- the annotations. Another common situation is where a common fragment of -- the AST has been factored out but there is no separate AST node for -- this fragment (this occurs in class and data declarations). In this -- case, the annotation belongs to the parent data declaration. -- -- The usual way an 'AddAnn' is created is using the 'mj' ("make jump") -- function, and then it can be discharged using the 'ams' function. data AddAnn = AddAnn AnnKeywordId SrcSpan addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () addAnnotationOnly l a v = P $ \s -> POk s { annotations = ((l,a), [v]) : annotations s } () -- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate -- 'AddAnn' values for the opening and closing bordering on the start -- and end of the span mkParensApiAnn :: SrcSpan -> [AddAnn] mkParensApiAnn (UnhelpfulSpan _) = [] mkParensApiAnn s@(RealSrcSpan ss) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc] where f = srcSpanFile ss sl = srcSpanStartLine ss sc = srcSpanStartCol ss el = srcSpanEndLine ss ec = srcSpanEndCol ss lo = mkSrcSpan (srcSpanStart s) (mkSrcLoc f sl (sc+1)) lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s) queueComment :: Located Token -> P() queueComment c = P $ \s -> POk s { comment_q = commentToAnnotation c : comment_q s } () -- | Go through the @comment_q@ in @PState@ and remove all comments -- that belong within the given span allocateCommentsP :: SrcSpan -> P () allocateCommentsP ss = P $ \s -> let (comment_q', newAnns) = allocateComments ss (comment_q s) in POk s { comment_q = comment_q' , annotations_comments = newAnns ++ (annotations_comments s) } () allocateComments :: SrcSpan -> [Located AnnotationComment] -> ([Located AnnotationComment], [(SrcSpan,[Located AnnotationComment])]) allocateComments ss comment_q = let (before,rest) = break (\(L l _) -> isSubspanOf l ss) comment_q (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest comment_q' = before ++ after newAnns = if null middle then [] else [(ss,middle)] in (comment_q', newAnns) commentToAnnotation :: Located Token -> Located AnnotationComment commentToAnnotation (L l (ITdocCommentNext s)) = L l (AnnDocCommentNext s) commentToAnnotation (L l (ITdocCommentPrev s)) = L l (AnnDocCommentPrev s) commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s) commentToAnnotation (L l (ITdocSection n s)) = L l (AnnDocSection n s) commentToAnnotation (L l (ITdocOptions s)) = L l (AnnDocOptions s) commentToAnnotation (L l (ITlineComment s)) = L l (AnnLineComment s) commentToAnnotation (L l (ITblockComment s)) = L l (AnnBlockComment s) commentToAnnotation _ = panic "commentToAnnotation" -- --------------------------------------------------------------------- isComment :: Token -> Bool isComment (ITlineComment _) = True isComment (ITblockComment _) = True isComment _ = False isDocComment :: Token -> Bool isDocComment (ITdocCommentNext _) = True isDocComment (ITdocCommentPrev _) = True isDocComment (ITdocCommentNamed _) = True isDocComment (ITdocSection _ _) = True isDocComment (ITdocOptions _) = True isDocComment _ = False bol,column_prag,layout,layout_do,layout_if,layout_left,line_prag1,line_prag1a,line_prag2,line_prag2a,option_prags :: Int bol = 1 column_prag = 2 layout = 3 layout_do = 4 layout_if = 5 layout_left = 6 line_prag1 = 7 line_prag1a = 8 line_prag2 = 9 line_prag2a = 10 option_prags = 11 alex_action_1 = warnTab alex_action_2 = nested_comment lexToken alex_action_3 = lineCommentToken alex_action_4 = lineCommentToken alex_action_5 = lineCommentToken alex_action_6 = lineCommentToken alex_action_7 = lineCommentToken alex_action_8 = lineCommentToken alex_action_10 = begin line_prag1 alex_action_11 = begin line_prag1 alex_action_14 = do_bol alex_action_15 = hopefully_open_brace alex_action_17 = begin line_prag1 alex_action_18 = new_layout_context True dontGenerateSemic ITvbar alex_action_19 = pop alex_action_20 = new_layout_context True generateSemic ITvocurly alex_action_21 = new_layout_context False generateSemic ITvocurly alex_action_22 = do_layout_left alex_action_23 = begin bol alex_action_24 = dispatch_pragmas linePrags alex_action_25 = setLineAndFile line_prag1a alex_action_26 = failLinePrag1 alex_action_27 = popLinePrag1 alex_action_28 = setLineAndFile line_prag2a alex_action_29 = pop alex_action_30 = setColumn alex_action_31 = dispatch_pragmas twoWordPrags alex_action_32 = dispatch_pragmas oneWordPrags alex_action_33 = dispatch_pragmas ignoredPrags alex_action_34 = endPrag alex_action_35 = dispatch_pragmas fileHeaderPrags alex_action_36 = nested_comment lexToken alex_action_37 = warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma") (nested_comment lexToken) alex_action_38 = multiline_doc_comment alex_action_39 = nested_doc_comment alex_action_40 = token (ITopenExpQuote NoE NormalSyntax) alex_action_41 = token (ITopenTExpQuote NoE) alex_action_42 = token (ITopenExpQuote HasE NormalSyntax) alex_action_43 = token (ITopenTExpQuote HasE) alex_action_44 = token ITopenPatQuote alex_action_45 = layout_token ITopenDecQuote alex_action_46 = token ITopenTypQuote alex_action_47 = token (ITcloseQuote NormalSyntax) alex_action_48 = token ITcloseTExpQuote alex_action_49 = skip_one_varid ITidEscape alex_action_50 = skip_two_varid ITidTyEscape alex_action_51 = token ITparenEscape alex_action_52 = token ITparenTyEscape alex_action_53 = lex_quasiquote_tok alex_action_54 = lex_qquasiquote_tok alex_action_55 = token (ITopenExpQuote NoE UnicodeSyntax) alex_action_56 = token (ITcloseQuote UnicodeSyntax) alex_action_57 = token ITtypeApp alex_action_58 = special (IToparenbar NormalSyntax) alex_action_59 = special (ITcparenbar NormalSyntax) alex_action_60 = special (IToparenbar UnicodeSyntax) alex_action_61 = special (ITcparenbar UnicodeSyntax) alex_action_62 = skip_one_varid ITdupipvarid alex_action_63 = skip_one_varid ITlabelvarid alex_action_64 = token IToubxparen alex_action_65 = token ITcubxparen alex_action_66 = special IToparen alex_action_67 = special ITcparen alex_action_68 = special ITobrack alex_action_69 = special ITcbrack alex_action_70 = special ITcomma alex_action_71 = special ITsemi alex_action_72 = special ITbackquote alex_action_73 = open_brace alex_action_74 = close_brace alex_action_75 = idtoken qvarid alex_action_76 = idtoken qconid alex_action_77 = varid alex_action_78 = idtoken conid alex_action_79 = idtoken qvarid alex_action_80 = idtoken qconid alex_action_81 = varid alex_action_82 = idtoken conid alex_action_83 = idtoken qvarsym alex_action_84 = idtoken qconsym alex_action_85 = varsym alex_action_86 = consym alex_action_87 = tok_num positive 0 0 decimal alex_action_88 = tok_num positive 2 2 binary alex_action_89 = tok_num positive 2 2 octal alex_action_90 = tok_num positive 2 2 hexadecimal alex_action_91 = tok_num negative 1 1 decimal alex_action_92 = tok_num negative 3 3 binary alex_action_93 = tok_num negative 3 3 octal alex_action_94 = tok_num negative 3 3 hexadecimal alex_action_95 = tok_frac 0 tok_float alex_action_96 = tok_frac 0 tok_float alex_action_97 = tok_frac 0 tok_hex_float alex_action_98 = tok_frac 0 tok_hex_float alex_action_99 = tok_primint positive 0 1 decimal alex_action_100 = tok_primint positive 2 3 binary alex_action_101 = tok_primint positive 2 3 octal alex_action_102 = tok_primint positive 2 3 hexadecimal alex_action_103 = tok_primint negative 1 2 decimal alex_action_104 = tok_primint negative 3 4 binary alex_action_105 = tok_primint negative 3 4 octal alex_action_106 = tok_primint negative 3 4 hexadecimal alex_action_107 = tok_primword 0 2 decimal alex_action_108 = tok_primword 2 4 binary alex_action_109 = tok_primword 2 4 octal alex_action_110 = tok_primword 2 4 hexadecimal alex_action_111 = tok_frac 1 tok_primfloat alex_action_112 = tok_frac 2 tok_primdouble alex_action_113 = lex_char_tok alex_action_114 = lex_string_tok {-# LINE 1 "templates/GenericTemplate.hs" #-} -- ----------------------------------------------------------------------------- -- ALEX TEMPLATE -- -- This code is in the PUBLIC DOMAIN; you may copy it freely and use -- it for any purpose whatsoever. -- ----------------------------------------------------------------------------- -- INTERNALS and main scanner engine -- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. #if __GLASGOW_HASKELL__ > 706 #define GTE(n,m) (tagToEnum# (n >=# m)) #define EQ(n,m) (tagToEnum# (n ==# m)) #else #define GTE(n,m) (n >=# m) #define EQ(n,m) (n ==# m) #endif data AlexAddr = AlexA# Addr# -- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. #if __GLASGOW_HASKELL__ < 503 uncheckedShiftL# = shiftL# #endif {-# INLINE alexIndexInt16OffAddr #-} alexIndexInt16OffAddr (AlexA# arr) off = #ifdef WORDS_BIGENDIAN narrow16Int# i where i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) low = int2Word# (ord# (indexCharOffAddr# arr off')) off' = off *# 2# #else indexInt16OffAddr# arr off #endif {-# INLINE alexIndexInt32OffAddr #-} alexIndexInt32OffAddr (AlexA# arr) off = #ifdef WORDS_BIGENDIAN narrow32Int# i where i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` (b2 `uncheckedShiftL#` 16#) `or#` (b1 `uncheckedShiftL#` 8#) `or#` b0) b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) b0 = int2Word# (ord# (indexCharOffAddr# arr off')) off' = off *# 4# #else indexInt32OffAddr# arr off #endif #if __GLASGOW_HASKELL__ < 503 quickIndex arr i = arr ! i #else -- GHC >= 503, unsafeAt is available from Data.Array.Base. quickIndex = unsafeAt #endif -- ----------------------------------------------------------------------------- -- Main lexing routines data AlexReturn a = AlexEOF | AlexError !AlexInput | AlexSkip !AlexInput !Int | AlexToken !AlexInput !Int a -- alexScan :: AlexInput -> StartCode -> AlexReturn a alexScan input__ (I# (sc)) = alexScanUser undefined input__ (I# (sc)) alexScanUser user__ input__ (I# (sc)) = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of (AlexNone, input__') -> case alexGetByte input__ of Nothing -> AlexEOF Just _ -> AlexError input__' (AlexLastSkip input__'' len, _) -> AlexSkip input__'' len (AlexLastAcc k input__''' len, _) -> AlexToken input__''' len (alex_actions ! k) -- Push the input through the DFA, remembering the most recent accepting -- state it encountered. alex_scan_tkn user__ orig_input len input__ s last_acc = input__ `seq` -- strict in the input let new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) in new_acc `seq` case alexGetByte input__ of Nothing -> (new_acc, input__) Just (c, new_input) -> case fromIntegral c of { (I# (ord_c)) -> let base = alexIndexInt32OffAddr alex_base s offset = (base +# ord_c) check = alexIndexInt16OffAddr alex_check offset new_s = if GTE(offset,0#) && EQ(check,ord_c) then alexIndexInt16OffAddr alex_table offset else alexIndexInt16OffAddr alex_deflt s in case new_s of -1# -> (new_acc, input__) -- on an error, we want to keep the input *before* the -- character that failed, not after. _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) -- note that the length is increased ONLY if this is the 1st byte in a char encoding) new_input new_s new_acc } where check_accs (AlexAccNone) = last_acc check_accs (AlexAcc a ) = AlexLastAcc a input__ (I# (len)) check_accs (AlexAccSkip) = AlexLastSkip input__ (I# (len)) check_accs (AlexAccPred a predx rest) | predx user__ orig_input (I# (len)) input__ = AlexLastAcc a input__ (I# (len)) | otherwise = check_accs rest check_accs (AlexAccSkipPred predx rest) | predx user__ orig_input (I# (len)) input__ = AlexLastSkip input__ (I# (len)) | otherwise = check_accs rest data AlexLastAcc = AlexNone | AlexLastAcc !Int !AlexInput !Int | AlexLastSkip !AlexInput !Int data AlexAcc user = AlexAccNone | AlexAcc Int | AlexAccSkip | AlexAccPred Int (AlexAccPred user) (AlexAcc user) | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool -- ----------------------------------------------------------------------------- -- Predicates on a rule alexAndPred p1 p2 user__ in1 len in2 = p1 user__ in1 len in2 && p2 user__ in1 len in2 --alexPrevCharIsPred :: Char -> AlexAccPred _ alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) --alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ --alexRightContext :: Int -> AlexAccPred _ alexRightContext (I# (sc)) user__ _ _ input__ = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of (AlexNone, _) -> False _ -> True -- TODO: there's no need to find the longest -- match when checking the right context, just -- the first match will do. ghc-lib-parser-8.10.2.20200808/includes/ghcconfig.h0000644000000000000000000000010013713635662017402 0ustar0000000000000000#pragma once #include "ghcautoconf.h" #include "ghcplatform.h" ghc-lib-parser-8.10.2.20200808/includes/MachDeps.h0000644000000000000000000000760013713635665017156 0ustar0000000000000000/* ----------------------------------------------------------------------------- * * (c) The University of Glasgow 2002 * * Definitions that characterise machine specific properties of basic * types (C & Haskell) of a target platform. * * NB: Keep in sync with HsFFI.h and StgTypes.h. * NB: THIS FILE IS INCLUDED IN HASKELL SOURCE! * * To understand the structure of the RTS headers, see the wiki: * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes * * ---------------------------------------------------------------------------*/ #pragma once /* Don't allow stage1 (cross-)compiler embed assumptions about target * platform. When ghc-stage1 is being built by ghc-stage0 is should not * refer to target defines. A few past examples: * - https://gitlab.haskell.org/ghc/ghc/issues/13491 * - https://phabricator.haskell.org/D3122 * - https://phabricator.haskell.org/D3405 * * In those cases code change assumed target defines like SIZEOF_HSINT * are applied to host platform, not target platform. * * So what should be used instead in GHC_STAGE=1? * * To get host's equivalent of SIZEOF_HSINT you can use Bits instances: * Data.Bits.finiteBitSize (0 :: Int) * * To get target's values it is preferred to use runtime target * configuration from 'targetPlatform :: DynFlags -> Platform' * record. A few wrappers are already defined and used throughout GHC: * wORD_SIZE :: DynFlags -> Int * wORD_SIZE dflags = pc_WORD_SIZE (platformConstants dflags) * * Hence we hide these macros from GHC_STAGE=1 */ /* Sizes of C types come from here... */ #include "ghcautoconf.h" /* Sizes of Haskell types follow. These sizes correspond to: * - the number of bytes in the primitive type (eg. Int#) * - the number of bytes in the external representation (eg. HsInt) * - the scale offset used by writeFooOffAddr# * * In the heap, the type may take up more space: eg. SIZEOF_INT8 == 1, * but it takes up SIZEOF_HSWORD (4 or 8) bytes in the heap. */ #define SIZEOF_HSCHAR SIZEOF_WORD32 #define ALIGNMENT_HSCHAR ALIGNMENT_WORD32 #define SIZEOF_HSINT SIZEOF_VOID_P #define ALIGNMENT_HSINT ALIGNMENT_VOID_P #define SIZEOF_HSWORD SIZEOF_VOID_P #define ALIGNMENT_HSWORD ALIGNMENT_VOID_P #define SIZEOF_HSDOUBLE SIZEOF_DOUBLE #define ALIGNMENT_HSDOUBLE ALIGNMENT_DOUBLE #define SIZEOF_HSFLOAT SIZEOF_FLOAT #define ALIGNMENT_HSFLOAT ALIGNMENT_FLOAT #define SIZEOF_HSPTR SIZEOF_VOID_P #define ALIGNMENT_HSPTR ALIGNMENT_VOID_P #define SIZEOF_HSFUNPTR SIZEOF_VOID_P #define ALIGNMENT_HSFUNPTR ALIGNMENT_VOID_P #define SIZEOF_HSSTABLEPTR SIZEOF_VOID_P #define ALIGNMENT_HSSTABLEPTR ALIGNMENT_VOID_P #define SIZEOF_INT8 SIZEOF_INT8_T #define ALIGNMENT_INT8 ALIGNMENT_INT8_T #define SIZEOF_WORD8 SIZEOF_UINT8_T #define ALIGNMENT_WORD8 ALIGNMENT_UINT8_T #define SIZEOF_INT16 SIZEOF_INT16_T #define ALIGNMENT_INT16 ALIGNMENT_INT16_T #define SIZEOF_WORD16 SIZEOF_UINT16_T #define ALIGNMENT_WORD16 ALIGNMENT_UINT16_T #define SIZEOF_INT32 SIZEOF_INT32_T #define ALIGNMENT_INT32 ALIGNMENT_INT32_T #define SIZEOF_WORD32 SIZEOF_UINT32_T #define ALIGNMENT_WORD32 ALIGNMENT_UINT32_T #define SIZEOF_INT64 SIZEOF_INT64_T #define ALIGNMENT_INT64 ALIGNMENT_INT64_T #define SIZEOF_WORD64 SIZEOF_UINT64_T #define ALIGNMENT_WORD64 ALIGNMENT_UINT64_T #if !defined(WORD_SIZE_IN_BITS) #if SIZEOF_HSWORD == 4 #define WORD_SIZE_IN_BITS 32 #define WORD_SIZE_IN_BITS_FLOAT 32.0 #else #define WORD_SIZE_IN_BITS 64 #define WORD_SIZE_IN_BITS_FLOAT 64.0 #endif #endif #if !defined(TAG_BITS) #if SIZEOF_HSWORD == 4 #define TAG_BITS 2 #else #define TAG_BITS 3 #endif #endif #define TAG_MASK ((1 << TAG_BITS) - 1) ghc-lib-parser-8.10.2.20200808/includes/stg/MachRegs.h0000644000000000000000000005377013713635665017771 0ustar0000000000000000/* ----------------------------------------------------------------------------- * * (c) The GHC Team, 1998-2014 * * Registers used in STG code. Might or might not correspond to * actual machine registers. * * Do not #include this file directly: #include "Rts.h" instead. * * To understand the structure of the RTS headers, see the wiki: * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes * * ---------------------------------------------------------------------------*/ #pragma once /* This file is #included into Haskell code in the compiler: #defines * only in here please. */ /* * Undefine these as a precaution: some of them were found to be * defined by system headers on ARM/Linux. */ #undef REG_R1 #undef REG_R2 #undef REG_R3 #undef REG_R4 #undef REG_R5 #undef REG_R6 #undef REG_R7 #undef REG_R8 #undef REG_R9 #undef REG_R10 /* * Defining MACHREGS_NO_REGS to 1 causes no global registers to be used. * MACHREGS_NO_REGS is typically controlled by NO_REGS, which is * typically defined by GHC, via a command-line option passed to gcc, * when the -funregisterised flag is given. * * NB. When MACHREGS_NO_REGS to 1, calling & return conventions may be * different. For example, all function arguments will be passed on * the stack, and components of an unboxed tuple will be returned on * the stack rather than in registers. */ #if MACHREGS_NO_REGS == 1 /* Nothing */ #elif MACHREGS_NO_REGS == 0 /* ---------------------------------------------------------------------------- Caller saves and callee-saves regs. Caller-saves regs have to be saved around C-calls made from STG land, so this file defines CALLER_SAVES_ for each that is designated caller-saves in that machine's C calling convention. As it stands, the only registers that are ever marked caller saves are the RX, FX, DX and USER registers; as a result, if you decide to caller save a system register (e.g. SP, HP, etc), note that this code path is completely untested! -- EZY -------------------------------------------------------------------------- */ /* ----------------------------------------------------------------------------- The x86 register mapping Ok, we've only got 6 general purpose registers, a frame pointer and a stack pointer. \tr{%eax} and \tr{%edx} are return values from C functions, hence they get trashed across ccalls and are caller saves. \tr{%ebx}, \tr{%esi}, \tr{%edi}, \tr{%ebp} are all callee-saves. Reg STG-Reg --------------- ebx Base ebp Sp esi R1 edi Hp Leaving SpLim out of the picture. -------------------------------------------------------------------------- */ #if defined(MACHREGS_i386) #define REG(x) __asm__("%" #x) #if !defined(not_doing_dynamic_linking) #define REG_Base ebx #endif #define REG_Sp ebp #if !defined(STOLEN_X86_REGS) #define STOLEN_X86_REGS 4 #endif #if STOLEN_X86_REGS >= 3 # define REG_R1 esi #endif #if STOLEN_X86_REGS >= 4 # define REG_Hp edi #endif #define REG_MachSp esp #define REG_XMM1 xmm0 #define REG_XMM2 xmm1 #define REG_XMM3 xmm2 #define REG_XMM4 xmm3 #define REG_YMM1 ymm0 #define REG_YMM2 ymm1 #define REG_YMM3 ymm2 #define REG_YMM4 ymm3 #define REG_ZMM1 zmm0 #define REG_ZMM2 zmm1 #define REG_ZMM3 zmm2 #define REG_ZMM4 zmm3 #define MAX_REAL_VANILLA_REG 1 /* always, since it defines the entry conv */ #define MAX_REAL_FLOAT_REG 0 #define MAX_REAL_DOUBLE_REG 0 #define MAX_REAL_LONG_REG 0 #define MAX_REAL_XMM_REG 4 #define MAX_REAL_YMM_REG 4 #define MAX_REAL_ZMM_REG 4 /* ----------------------------------------------------------------------------- The x86-64 register mapping %rax caller-saves, don't steal this one %rbx YES %rcx arg reg, caller-saves %rdx arg reg, caller-saves %rsi arg reg, caller-saves %rdi arg reg, caller-saves %rbp YES (our *prime* register) %rsp (unavailable - stack pointer) %r8 arg reg, caller-saves %r9 arg reg, caller-saves %r10 caller-saves %r11 caller-saves %r12 YES %r13 YES %r14 YES %r15 YES %xmm0-7 arg regs, caller-saves %xmm8-15 caller-saves Use the caller-saves regs for Rn, because we don't always have to save those (as opposed to Sp/Hp/SpLim etc. which always have to be saved). --------------------------------------------------------------------------- */ #elif defined(MACHREGS_x86_64) #define REG(x) __asm__("%" #x) #define REG_Base r13 #define REG_Sp rbp #define REG_Hp r12 #define REG_R1 rbx #define REG_R2 r14 #define REG_R3 rsi #define REG_R4 rdi #define REG_R5 r8 #define REG_R6 r9 #define REG_SpLim r15 #define REG_MachSp rsp /* Map both Fn and Dn to register xmmn so that we can pass a function any combination of up to six Float# or Double# arguments without touching the stack. See Note [Overlapping global registers] for implications. */ #define REG_F1 xmm1 #define REG_F2 xmm2 #define REG_F3 xmm3 #define REG_F4 xmm4 #define REG_F5 xmm5 #define REG_F6 xmm6 #define REG_D1 xmm1 #define REG_D2 xmm2 #define REG_D3 xmm3 #define REG_D4 xmm4 #define REG_D5 xmm5 #define REG_D6 xmm6 #define REG_XMM1 xmm1 #define REG_XMM2 xmm2 #define REG_XMM3 xmm3 #define REG_XMM4 xmm4 #define REG_XMM5 xmm5 #define REG_XMM6 xmm6 #define REG_YMM1 ymm1 #define REG_YMM2 ymm2 #define REG_YMM3 ymm3 #define REG_YMM4 ymm4 #define REG_YMM5 ymm5 #define REG_YMM6 ymm6 #define REG_ZMM1 zmm1 #define REG_ZMM2 zmm2 #define REG_ZMM3 zmm3 #define REG_ZMM4 zmm4 #define REG_ZMM5 zmm5 #define REG_ZMM6 zmm6 #if !defined(mingw32_HOST_OS) #define CALLER_SAVES_R3 #define CALLER_SAVES_R4 #endif #define CALLER_SAVES_R5 #define CALLER_SAVES_R6 #define CALLER_SAVES_F1 #define CALLER_SAVES_F2 #define CALLER_SAVES_F3 #define CALLER_SAVES_F4 #define CALLER_SAVES_F5 #if !defined(mingw32_HOST_OS) #define CALLER_SAVES_F6 #endif #define CALLER_SAVES_D1 #define CALLER_SAVES_D2 #define CALLER_SAVES_D3 #define CALLER_SAVES_D4 #define CALLER_SAVES_D5 #if !defined(mingw32_HOST_OS) #define CALLER_SAVES_D6 #endif #define CALLER_SAVES_XMM1 #define CALLER_SAVES_XMM2 #define CALLER_SAVES_XMM3 #define CALLER_SAVES_XMM4 #define CALLER_SAVES_XMM5 #if !defined(mingw32_HOST_OS) #define CALLER_SAVES_XMM6 #endif #define CALLER_SAVES_YMM1 #define CALLER_SAVES_YMM2 #define CALLER_SAVES_YMM3 #define CALLER_SAVES_YMM4 #define CALLER_SAVES_YMM5 #if !defined(mingw32_HOST_OS) #define CALLER_SAVES_YMM6 #endif #define CALLER_SAVES_ZMM1 #define CALLER_SAVES_ZMM2 #define CALLER_SAVES_ZMM3 #define CALLER_SAVES_ZMM4 #define CALLER_SAVES_ZMM5 #if !defined(mingw32_HOST_OS) #define CALLER_SAVES_ZMM6 #endif #define MAX_REAL_VANILLA_REG 6 #define MAX_REAL_FLOAT_REG 6 #define MAX_REAL_DOUBLE_REG 6 #define MAX_REAL_LONG_REG 0 #define MAX_REAL_XMM_REG 6 #define MAX_REAL_YMM_REG 6 #define MAX_REAL_ZMM_REG 6 /* ----------------------------------------------------------------------------- The PowerPC register mapping 0 system glue? (caller-save, volatile) 1 SP (callee-save, non-volatile) 2 AIX, powerpc64-linux: RTOC (a strange special case) powerpc32-linux: reserved for use by system 3-10 args/return (caller-save, volatile) 11,12 system glue? (caller-save, volatile) 13 on 64-bit: reserved for thread state pointer on 32-bit: (callee-save, non-volatile) 14-31 (callee-save, non-volatile) f0 (caller-save, volatile) f1-f13 args/return (caller-save, volatile) f14-f31 (callee-save, non-volatile) \tr{14}--\tr{31} are wonderful callee-save registers on all ppc OSes. \tr{0}--\tr{12} are caller-save registers. \tr{%f14}--\tr{%f31} are callee-save floating-point registers. We can do the Whole Business with callee-save registers only! -------------------------------------------------------------------------- */ #elif defined(MACHREGS_powerpc) #define REG(x) __asm__(#x) #define REG_R1 r14 #define REG_R2 r15 #define REG_R3 r16 #define REG_R4 r17 #define REG_R5 r18 #define REG_R6 r19 #define REG_R7 r20 #define REG_R8 r21 #define REG_R9 r22 #define REG_R10 r23 #define REG_F1 fr14 #define REG_F2 fr15 #define REG_F3 fr16 #define REG_F4 fr17 #define REG_F5 fr18 #define REG_F6 fr19 #define REG_D1 fr20 #define REG_D2 fr21 #define REG_D3 fr22 #define REG_D4 fr23 #define REG_D5 fr24 #define REG_D6 fr25 #define REG_Sp r24 #define REG_SpLim r25 #define REG_Hp r26 #define REG_Base r27 #define MAX_REAL_FLOAT_REG 6 #define MAX_REAL_DOUBLE_REG 6 /* ----------------------------------------------------------------------------- The Sun SPARC register mapping !! IMPORTANT: if you change this register mapping you must also update compiler/nativeGen/SPARC/Regs.hs. That file handles the mapping for the NCG. This one only affects via-c code. The SPARC register (window) story: Remember, within the Haskell Threaded World, we essentially ``shut down'' the register-window mechanism---the window doesn't move at all while in this World. It *does* move, of course, if we call out to arbitrary~C... The %i, %l, and %o registers (8 each) are the input, local, and output registers visible in one register window. The 8 %g (global) registers are visible all the time. zero: always zero scratch: volatile across C-fn calls. used by linker. app: usable by application system: reserved for system alloc: allocated to in the register allocator, intra-closure only GHC usage v8 ABI v9 ABI Global %g0 zero zero zero %g1 alloc scratch scrach %g2 alloc app app %g3 alloc app app %g4 alloc app scratch %g5 system scratch %g6 system system %g7 system system Output: can be zapped by callee %o0-o5 alloc caller saves %o6 C stack ptr %o7 C ret addr Local: maintained by register windowing mechanism %l0 alloc %l1 R1 %l2 R2 %l3 R3 %l4 R4 %l5 R5 %l6 alloc %l7 alloc Input %i0 Sp %i1 Base %i2 SpLim %i3 Hp %i4 alloc %i5 R6 %i6 C frame ptr %i7 C ret addr The paired nature of the floating point registers causes complications for the native code generator. For convenience, we pretend that the first 22 fp regs %f0 .. %f21 are actually 11 double regs, and the remaining 10 are float (single) regs. The NCG acts accordingly. That means that the following FP assignment is rather fragile, and should only be changed with extreme care. The current scheme is: %f0 /%f1 FP return from C %f2 /%f3 D1 %f4 /%f5 D2 %f6 /%f7 ncg double spill tmp #1 %f8 /%f9 ncg double spill tmp #2 %f10/%f11 allocatable %f12/%f13 allocatable %f14/%f15 allocatable %f16/%f17 allocatable %f18/%f19 allocatable %f20/%f21 allocatable %f22 F1 %f23 F2 %f24 F3 %f25 F4 %f26 ncg single spill tmp #1 %f27 ncg single spill tmp #2 %f28 allocatable %f29 allocatable %f30 allocatable %f31 allocatable -------------------------------------------------------------------------- */ #elif defined(MACHREGS_sparc) #define REG(x) __asm__("%" #x) #define CALLER_SAVES_USER #define CALLER_SAVES_F1 #define CALLER_SAVES_F2 #define CALLER_SAVES_F3 #define CALLER_SAVES_F4 #define CALLER_SAVES_D1 #define CALLER_SAVES_D2 #define REG_R1 l1 #define REG_R2 l2 #define REG_R3 l3 #define REG_R4 l4 #define REG_R5 l5 #define REG_R6 i5 #define REG_F1 f22 #define REG_F2 f23 #define REG_F3 f24 #define REG_F4 f25 /* for each of the double arg regs, Dn_2 is the high half. */ #define REG_D1 f2 #define REG_D1_2 f3 #define REG_D2 f4 #define REG_D2_2 f5 #define REG_Sp i0 #define REG_SpLim i2 #define REG_Hp i3 #define REG_Base i1 #define NCG_FirstFloatReg f22 /* ----------------------------------------------------------------------------- The ARM EABI register mapping Here we consider ARM mode (i.e. 32bit isns) and also CPU with full VFPv3 implementation ARM registers (see Chapter 5.1 in ARM IHI 0042D and Section 9.2.2 in ARM Software Development Toolkit Reference Guide) r15 PC The Program Counter. r14 LR The Link Register. r13 SP The Stack Pointer. r12 IP The Intra-Procedure-call scratch register. r11 v8/fp Variable-register 8. r10 v7/sl Variable-register 7. r9 v6/SB/TR Platform register. The meaning of this register is defined by the platform standard. r8 v5 Variable-register 5. r7 v4 Variable register 4. r6 v3 Variable register 3. r5 v2 Variable register 2. r4 v1 Variable register 1. r3 a4 Argument / scratch register 4. r2 a3 Argument / scratch register 3. r1 a2 Argument / result / scratch register 2. r0 a1 Argument / result / scratch register 1. VFPv2/VFPv3/NEON registers s0-s15/d0-d7/q0-q3 Argument / result/ scratch registers s16-s31/d8-d15/q4-q7 callee-saved registers (must be preserved across subroutine calls) VFPv3/NEON registers (added to the VFPv2 registers set) d16-d31/q8-q15 Argument / result/ scratch registers ----------------------------------------------------------------------------- */ #elif defined(MACHREGS_arm) #define REG(x) __asm__(#x) #define REG_Base r4 #define REG_Sp r5 #define REG_Hp r6 #define REG_R1 r7 #define REG_R2 r8 #define REG_R3 r9 #define REG_R4 r10 #define REG_SpLim r11 #if !defined(arm_HOST_ARCH_PRE_ARMv6) /* d8 */ #define REG_F1 s16 #define REG_F2 s17 /* d9 */ #define REG_F3 s18 #define REG_F4 s19 #define REG_D1 d10 #define REG_D2 d11 #endif /* ----------------------------------------------------------------------------- The ARMv8/AArch64 ABI register mapping The AArch64 provides 31 64-bit general purpose registers and 32 128-bit SIMD/floating point registers. General purpose registers (see Chapter 5.1.1 in ARM IHI 0055B) Register | Special | Role in the procedure call standard ---------+---------+------------------------------------ SP | | The Stack Pointer r30 | LR | The Link Register r29 | FP | The Frame Pointer r19-r28 | | Callee-saved registers r18 | | The Platform Register, if needed; | | or temporary register r17 | IP1 | The second intra-procedure-call temporary register r16 | IP0 | The first intra-procedure-call scratch register r9-r15 | | Temporary registers r8 | | Indirect result location register r0-r7 | | Parameter/result registers FPU/SIMD registers s/d/q/v0-v7 Argument / result/ scratch registers s/d/q/v8-v15 callee-saved registers (must be preserved across subroutine calls, but only bottom 64-bit value needs to be preserved) s/d/q/v16-v31 temporary registers ----------------------------------------------------------------------------- */ #elif defined(MACHREGS_aarch64) #define REG(x) __asm__(#x) #define REG_Base r19 #define REG_Sp r20 #define REG_Hp r21 #define REG_R1 r22 #define REG_R2 r23 #define REG_R3 r24 #define REG_R4 r25 #define REG_R5 r26 #define REG_R6 r27 #define REG_SpLim r28 #define REG_F1 s8 #define REG_F2 s9 #define REG_F3 s10 #define REG_F4 s11 #define REG_D1 d12 #define REG_D2 d13 #define REG_D3 d14 #define REG_D4 d15 /* ----------------------------------------------------------------------------- The s390x register mapping Register | Role(s) | Call effect ------------+-------------------------------------+----------------- r0,r1 | - | caller-saved r2 | Argument / return value | caller-saved r3,r4,r5 | Arguments | caller-saved r6 | Argument | callee-saved r7...r11 | - | callee-saved r12 | (Commonly used as GOT pointer) | callee-saved r13 | (Commonly used as literal pool pointer) | callee-saved r14 | Return address | caller-saved r15 | Stack pointer | callee-saved f0 | Argument / return value | caller-saved f2,f4,f6 | Arguments | caller-saved f1,f3,f5,f7 | - | caller-saved f8...f15 | - | callee-saved v0...v31 | - | caller-saved Each general purpose register r0 through r15 as well as each floating-point register f0 through f15 is 64 bits wide. Each vector register v0 through v31 is 128 bits wide. Note, the vector registers v0 through v15 overlap with the floating-point registers f0 through f15. -------------------------------------------------------------------------- */ #elif defined(MACHREGS_s390x) #define REG(x) __asm__("%" #x) #define REG_Base r7 #define REG_Sp r8 #define REG_Hp r10 #define REG_R1 r11 #define REG_R2 r12 #define REG_R3 r13 #define REG_R4 r6 #define REG_R5 r2 #define REG_R6 r3 #define REG_R7 r4 #define REG_R8 r5 #define REG_SpLim r9 #define REG_MachSp r15 #define REG_F1 f8 #define REG_F2 f9 #define REG_F3 f10 #define REG_F4 f11 #define REG_F5 f0 #define REG_F6 f1 #define REG_D1 f12 #define REG_D2 f13 #define REG_D3 f14 #define REG_D4 f15 #define REG_D5 f2 #define REG_D6 f3 #define CALLER_SAVES_R5 #define CALLER_SAVES_R6 #define CALLER_SAVES_R7 #define CALLER_SAVES_R8 #define CALLER_SAVES_F5 #define CALLER_SAVES_F6 #define CALLER_SAVES_D5 #define CALLER_SAVES_D6 #else #error Cannot find platform to give register info for #endif #else #error Bad MACHREGS_NO_REGS value #endif /* ----------------------------------------------------------------------------- * These constants define how many stg registers will be used for * passing arguments (and results, in the case of an unboxed-tuple * return). * * We usually set MAX_REAL_VANILLA_REG and co. to be the number of the * highest STG register to occupy a real machine register, otherwise * the calling conventions will needlessly shuffle data between the * stack and memory-resident STG registers. We might occasionally * set these macros to other values for testing, though. * * Registers above these values might still be used, for instance to * communicate with PrimOps and RTS functions. */ #if !defined(MAX_REAL_VANILLA_REG) # if defined(REG_R10) # define MAX_REAL_VANILLA_REG 10 # elif defined(REG_R9) # define MAX_REAL_VANILLA_REG 9 # elif defined(REG_R8) # define MAX_REAL_VANILLA_REG 8 # elif defined(REG_R7) # define MAX_REAL_VANILLA_REG 7 # elif defined(REG_R6) # define MAX_REAL_VANILLA_REG 6 # elif defined(REG_R5) # define MAX_REAL_VANILLA_REG 5 # elif defined(REG_R4) # define MAX_REAL_VANILLA_REG 4 # elif defined(REG_R3) # define MAX_REAL_VANILLA_REG 3 # elif defined(REG_R2) # define MAX_REAL_VANILLA_REG 2 # elif defined(REG_R1) # define MAX_REAL_VANILLA_REG 1 # else # define MAX_REAL_VANILLA_REG 0 # endif #endif #if !defined(MAX_REAL_FLOAT_REG) # if defined(REG_F4) # define MAX_REAL_FLOAT_REG 4 # elif defined(REG_F3) # define MAX_REAL_FLOAT_REG 3 # elif defined(REG_F2) # define MAX_REAL_FLOAT_REG 2 # elif defined(REG_F1) # define MAX_REAL_FLOAT_REG 1 # else # define MAX_REAL_FLOAT_REG 0 # endif #endif #if !defined(MAX_REAL_DOUBLE_REG) # if defined(REG_D2) # define MAX_REAL_DOUBLE_REG 2 # elif defined(REG_D1) # define MAX_REAL_DOUBLE_REG 1 # else # define MAX_REAL_DOUBLE_REG 0 # endif #endif #if !defined(MAX_REAL_LONG_REG) # if defined(REG_L1) # define MAX_REAL_LONG_REG 1 # else # define MAX_REAL_LONG_REG 0 # endif #endif #if !defined(MAX_REAL_XMM_REG) # if defined(REG_XMM6) # define MAX_REAL_XMM_REG 6 # elif defined(REG_XMM5) # define MAX_REAL_XMM_REG 5 # elif defined(REG_XMM4) # define MAX_REAL_XMM_REG 4 # elif defined(REG_XMM3) # define MAX_REAL_XMM_REG 3 # elif defined(REG_XMM2) # define MAX_REAL_XMM_REG 2 # elif defined(REG_XMM1) # define MAX_REAL_XMM_REG 1 # else # define MAX_REAL_XMM_REG 0 # endif #endif /* define NO_ARG_REGS if we have no argument registers at all (we can * optimise certain code paths using this predicate). */ #if MAX_REAL_VANILLA_REG < 2 #define NO_ARG_REGS #else #undef NO_ARG_REGS #endif ghc-lib-parser-8.10.2.20200808/includes/CodeGen.Platform.hs0000644000000000000000000005664713713635665020763 0ustar0000000000000000 import CmmExpr #if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \ || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc)) import PlainPanic #endif import Reg #include "stg/MachRegs.h" #if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) # if defined(MACHREGS_i386) # define eax 0 # define ebx 1 # define ecx 2 # define edx 3 # define esi 4 # define edi 5 # define ebp 6 # define esp 7 # endif # if defined(MACHREGS_x86_64) # define rax 0 # define rbx 1 # define rcx 2 # define rdx 3 # define rsi 4 # define rdi 5 # define rbp 6 # define rsp 7 # define r8 8 # define r9 9 # define r10 10 # define r11 11 # define r12 12 # define r13 13 # define r14 14 # define r15 15 # endif -- N.B. XMM, YMM, and ZMM are all aliased to the same hardware registers hence -- being assigned the same RegNos. # define xmm0 16 # define xmm1 17 # define xmm2 18 # define xmm3 19 # define xmm4 20 # define xmm5 21 # define xmm6 22 # define xmm7 23 # define xmm8 24 # define xmm9 25 # define xmm10 26 # define xmm11 27 # define xmm12 28 # define xmm13 29 # define xmm14 30 # define xmm15 31 # define ymm0 16 # define ymm1 17 # define ymm2 18 # define ymm3 19 # define ymm4 20 # define ymm5 21 # define ymm6 22 # define ymm7 23 # define ymm8 24 # define ymm9 25 # define ymm10 26 # define ymm11 27 # define ymm12 28 # define ymm13 29 # define ymm14 30 # define ymm15 31 # define zmm0 16 # define zmm1 17 # define zmm2 18 # define zmm3 19 # define zmm4 20 # define zmm5 21 # define zmm6 22 # define zmm7 23 # define zmm8 24 # define zmm9 25 # define zmm10 26 # define zmm11 27 # define zmm12 28 # define zmm13 29 # define zmm14 30 # define zmm15 31 -- Note: these are only needed for ARM/ARM64 because globalRegMaybe is now used in CmmSink.hs. -- Since it's only used to check 'isJust', the actual values don't matter, thus -- I'm not sure if these are the correct numberings. -- Normally, the register names are just stringified as part of the REG() macro #elif defined(MACHREGS_powerpc) || defined(MACHREGS_arm) \ || defined(MACHREGS_aarch64) # define r0 0 # define r1 1 # define r2 2 # define r3 3 # define r4 4 # define r5 5 # define r6 6 # define r7 7 # define r8 8 # define r9 9 # define r10 10 # define r11 11 # define r12 12 # define r13 13 # define r14 14 # define r15 15 # define r16 16 # define r17 17 # define r18 18 # define r19 19 # define r20 20 # define r21 21 # define r22 22 # define r23 23 # define r24 24 # define r25 25 # define r26 26 # define r27 27 # define r28 28 # define r29 29 # define r30 30 # define r31 31 -- See note above. These aren't actually used for anything except satisfying the compiler for globalRegMaybe -- so I'm unsure if they're the correct numberings, should they ever be attempted to be used in the NCG. #if defined(MACHREGS_aarch64) || defined(MACHREGS_arm) # define s0 32 # define s1 33 # define s2 34 # define s3 35 # define s4 36 # define s5 37 # define s6 38 # define s7 39 # define s8 40 # define s9 41 # define s10 42 # define s11 43 # define s12 44 # define s13 45 # define s14 46 # define s15 47 # define s16 48 # define s17 49 # define s18 50 # define s19 51 # define s20 52 # define s21 53 # define s22 54 # define s23 55 # define s24 56 # define s25 57 # define s26 58 # define s27 59 # define s28 60 # define s29 61 # define s30 62 # define s31 63 # define d0 32 # define d1 33 # define d2 34 # define d3 35 # define d4 36 # define d5 37 # define d6 38 # define d7 39 # define d8 40 # define d9 41 # define d10 42 # define d11 43 # define d12 44 # define d13 45 # define d14 46 # define d15 47 # define d16 48 # define d17 49 # define d18 50 # define d19 51 # define d20 52 # define d21 53 # define d22 54 # define d23 55 # define d24 56 # define d25 57 # define d26 58 # define d27 59 # define d28 60 # define d29 61 # define d30 62 # define d31 63 #endif # if defined(MACHREGS_darwin) # define f0 32 # define f1 33 # define f2 34 # define f3 35 # define f4 36 # define f5 37 # define f6 38 # define f7 39 # define f8 40 # define f9 41 # define f10 42 # define f11 43 # define f12 44 # define f13 45 # define f14 46 # define f15 47 # define f16 48 # define f17 49 # define f18 50 # define f19 51 # define f20 52 # define f21 53 # define f22 54 # define f23 55 # define f24 56 # define f25 57 # define f26 58 # define f27 59 # define f28 60 # define f29 61 # define f30 62 # define f31 63 # else # define fr0 32 # define fr1 33 # define fr2 34 # define fr3 35 # define fr4 36 # define fr5 37 # define fr6 38 # define fr7 39 # define fr8 40 # define fr9 41 # define fr10 42 # define fr11 43 # define fr12 44 # define fr13 45 # define fr14 46 # define fr15 47 # define fr16 48 # define fr17 49 # define fr18 50 # define fr19 51 # define fr20 52 # define fr21 53 # define fr22 54 # define fr23 55 # define fr24 56 # define fr25 57 # define fr26 58 # define fr27 59 # define fr28 60 # define fr29 61 # define fr30 62 # define fr31 63 # endif #elif defined(MACHREGS_sparc) # define g0 0 # define g1 1 # define g2 2 # define g3 3 # define g4 4 # define g5 5 # define g6 6 # define g7 7 # define o0 8 # define o1 9 # define o2 10 # define o3 11 # define o4 12 # define o5 13 # define o6 14 # define o7 15 # define l0 16 # define l1 17 # define l2 18 # define l3 19 # define l4 20 # define l5 21 # define l6 22 # define l7 23 # define i0 24 # define i1 25 # define i2 26 # define i3 27 # define i4 28 # define i5 29 # define i6 30 # define i7 31 # define f0 32 # define f1 33 # define f2 34 # define f3 35 # define f4 36 # define f5 37 # define f6 38 # define f7 39 # define f8 40 # define f9 41 # define f10 42 # define f11 43 # define f12 44 # define f13 45 # define f14 46 # define f15 47 # define f16 48 # define f17 49 # define f18 50 # define f19 51 # define f20 52 # define f21 53 # define f22 54 # define f23 55 # define f24 56 # define f25 57 # define f26 58 # define f27 59 # define f28 60 # define f29 61 # define f30 62 # define f31 63 #elif defined(MACHREGS_s390x) # define r0 0 # define r1 1 # define r2 2 # define r3 3 # define r4 4 # define r5 5 # define r6 6 # define r7 7 # define r8 8 # define r9 9 # define r10 10 # define r11 11 # define r12 12 # define r13 13 # define r14 14 # define r15 15 # define f0 16 # define f1 17 # define f2 18 # define f3 19 # define f4 20 # define f5 21 # define f6 22 # define f7 23 # define f8 24 # define f9 25 # define f10 26 # define f11 27 # define f12 28 # define f13 29 # define f14 30 # define f15 31 #endif callerSaves :: GlobalReg -> Bool #if defined(CALLER_SAVES_Base) callerSaves BaseReg = True #endif #if defined(CALLER_SAVES_R1) callerSaves (VanillaReg 1 _) = True #endif #if defined(CALLER_SAVES_R2) callerSaves (VanillaReg 2 _) = True #endif #if defined(CALLER_SAVES_R3) callerSaves (VanillaReg 3 _) = True #endif #if defined(CALLER_SAVES_R4) callerSaves (VanillaReg 4 _) = True #endif #if defined(CALLER_SAVES_R5) callerSaves (VanillaReg 5 _) = True #endif #if defined(CALLER_SAVES_R6) callerSaves (VanillaReg 6 _) = True #endif #if defined(CALLER_SAVES_R7) callerSaves (VanillaReg 7 _) = True #endif #if defined(CALLER_SAVES_R8) callerSaves (VanillaReg 8 _) = True #endif #if defined(CALLER_SAVES_R9) callerSaves (VanillaReg 9 _) = True #endif #if defined(CALLER_SAVES_R10) callerSaves (VanillaReg 10 _) = True #endif #if defined(CALLER_SAVES_F1) callerSaves (FloatReg 1) = True #endif #if defined(CALLER_SAVES_F2) callerSaves (FloatReg 2) = True #endif #if defined(CALLER_SAVES_F3) callerSaves (FloatReg 3) = True #endif #if defined(CALLER_SAVES_F4) callerSaves (FloatReg 4) = True #endif #if defined(CALLER_SAVES_F5) callerSaves (FloatReg 5) = True #endif #if defined(CALLER_SAVES_F6) callerSaves (FloatReg 6) = True #endif #if defined(CALLER_SAVES_D1) callerSaves (DoubleReg 1) = True #endif #if defined(CALLER_SAVES_D2) callerSaves (DoubleReg 2) = True #endif #if defined(CALLER_SAVES_D3) callerSaves (DoubleReg 3) = True #endif #if defined(CALLER_SAVES_D4) callerSaves (DoubleReg 4) = True #endif #if defined(CALLER_SAVES_D5) callerSaves (DoubleReg 5) = True #endif #if defined(CALLER_SAVES_D6) callerSaves (DoubleReg 6) = True #endif #if defined(CALLER_SAVES_L1) callerSaves (LongReg 1) = True #endif #if defined(CALLER_SAVES_Sp) callerSaves Sp = True #endif #if defined(CALLER_SAVES_SpLim) callerSaves SpLim = True #endif #if defined(CALLER_SAVES_Hp) callerSaves Hp = True #endif #if defined(CALLER_SAVES_HpLim) callerSaves HpLim = True #endif #if defined(CALLER_SAVES_CCCS) callerSaves CCCS = True #endif #if defined(CALLER_SAVES_CurrentTSO) callerSaves CurrentTSO = True #endif #if defined(CALLER_SAVES_CurrentNursery) callerSaves CurrentNursery = True #endif callerSaves _ = False activeStgRegs :: [GlobalReg] activeStgRegs = [ #if defined(REG_Base) BaseReg #endif #if defined(REG_Sp) ,Sp #endif #if defined(REG_Hp) ,Hp #endif #if defined(REG_R1) ,VanillaReg 1 VGcPtr #endif #if defined(REG_R2) ,VanillaReg 2 VGcPtr #endif #if defined(REG_R3) ,VanillaReg 3 VGcPtr #endif #if defined(REG_R4) ,VanillaReg 4 VGcPtr #endif #if defined(REG_R5) ,VanillaReg 5 VGcPtr #endif #if defined(REG_R6) ,VanillaReg 6 VGcPtr #endif #if defined(REG_R7) ,VanillaReg 7 VGcPtr #endif #if defined(REG_R8) ,VanillaReg 8 VGcPtr #endif #if defined(REG_R9) ,VanillaReg 9 VGcPtr #endif #if defined(REG_R10) ,VanillaReg 10 VGcPtr #endif #if defined(REG_SpLim) ,SpLim #endif #if MAX_REAL_XMM_REG != 0 #if defined(REG_F1) ,FloatReg 1 #endif #if defined(REG_D1) ,DoubleReg 1 #endif #if defined(REG_XMM1) ,XmmReg 1 #endif #if defined(REG_YMM1) ,YmmReg 1 #endif #if defined(REG_ZMM1) ,ZmmReg 1 #endif #if defined(REG_F2) ,FloatReg 2 #endif #if defined(REG_D2) ,DoubleReg 2 #endif #if defined(REG_XMM2) ,XmmReg 2 #endif #if defined(REG_YMM2) ,YmmReg 2 #endif #if defined(REG_ZMM2) ,ZmmReg 2 #endif #if defined(REG_F3) ,FloatReg 3 #endif #if defined(REG_D3) ,DoubleReg 3 #endif #if defined(REG_XMM3) ,XmmReg 3 #endif #if defined(REG_YMM3) ,YmmReg 3 #endif #if defined(REG_ZMM3) ,ZmmReg 3 #endif #if defined(REG_F4) ,FloatReg 4 #endif #if defined(REG_D4) ,DoubleReg 4 #endif #if defined(REG_XMM4) ,XmmReg 4 #endif #if defined(REG_YMM4) ,YmmReg 4 #endif #if defined(REG_ZMM4) ,ZmmReg 4 #endif #if defined(REG_F5) ,FloatReg 5 #endif #if defined(REG_D5) ,DoubleReg 5 #endif #if defined(REG_XMM5) ,XmmReg 5 #endif #if defined(REG_YMM5) ,YmmReg 5 #endif #if defined(REG_ZMM5) ,ZmmReg 5 #endif #if defined(REG_F6) ,FloatReg 6 #endif #if defined(REG_D6) ,DoubleReg 6 #endif #if defined(REG_XMM6) ,XmmReg 6 #endif #if defined(REG_YMM6) ,YmmReg 6 #endif #if defined(REG_ZMM6) ,ZmmReg 6 #endif #else /* MAX_REAL_XMM_REG == 0 */ #if defined(REG_F1) ,FloatReg 1 #endif #if defined(REG_F2) ,FloatReg 2 #endif #if defined(REG_F3) ,FloatReg 3 #endif #if defined(REG_F4) ,FloatReg 4 #endif #if defined(REG_F5) ,FloatReg 5 #endif #if defined(REG_F6) ,FloatReg 6 #endif #if defined(REG_D1) ,DoubleReg 1 #endif #if defined(REG_D2) ,DoubleReg 2 #endif #if defined(REG_D3) ,DoubleReg 3 #endif #if defined(REG_D4) ,DoubleReg 4 #endif #if defined(REG_D5) ,DoubleReg 5 #endif #if defined(REG_D6) ,DoubleReg 6 #endif #endif /* MAX_REAL_XMM_REG == 0 */ ] haveRegBase :: Bool #if defined(REG_Base) haveRegBase = True #else haveRegBase = False #endif -- | Returns 'Nothing' if this global register is not stored -- in a real machine register, otherwise returns @'Just' reg@, where -- reg is the machine register it is stored in. globalRegMaybe :: GlobalReg -> Maybe RealReg #if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \ || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc) \ || defined(MACHREGS_arm) || defined(MACHREGS_aarch64) \ || defined(MACHREGS_s390x) # if defined(REG_Base) globalRegMaybe BaseReg = Just (RealRegSingle REG_Base) # endif # if defined(REG_R1) globalRegMaybe (VanillaReg 1 _) = Just (RealRegSingle REG_R1) # endif # if defined(REG_R2) globalRegMaybe (VanillaReg 2 _) = Just (RealRegSingle REG_R2) # endif # if defined(REG_R3) globalRegMaybe (VanillaReg 3 _) = Just (RealRegSingle REG_R3) # endif # if defined(REG_R4) globalRegMaybe (VanillaReg 4 _) = Just (RealRegSingle REG_R4) # endif # if defined(REG_R5) globalRegMaybe (VanillaReg 5 _) = Just (RealRegSingle REG_R5) # endif # if defined(REG_R6) globalRegMaybe (VanillaReg 6 _) = Just (RealRegSingle REG_R6) # endif # if defined(REG_R7) globalRegMaybe (VanillaReg 7 _) = Just (RealRegSingle REG_R7) # endif # if defined(REG_R8) globalRegMaybe (VanillaReg 8 _) = Just (RealRegSingle REG_R8) # endif # if defined(REG_R9) globalRegMaybe (VanillaReg 9 _) = Just (RealRegSingle REG_R9) # endif # if defined(REG_R10) globalRegMaybe (VanillaReg 10 _) = Just (RealRegSingle REG_R10) # endif # if defined(REG_F1) globalRegMaybe (FloatReg 1) = Just (RealRegSingle REG_F1) # endif # if defined(REG_F2) globalRegMaybe (FloatReg 2) = Just (RealRegSingle REG_F2) # endif # if defined(REG_F3) globalRegMaybe (FloatReg 3) = Just (RealRegSingle REG_F3) # endif # if defined(REG_F4) globalRegMaybe (FloatReg 4) = Just (RealRegSingle REG_F4) # endif # if defined(REG_F5) globalRegMaybe (FloatReg 5) = Just (RealRegSingle REG_F5) # endif # if defined(REG_F6) globalRegMaybe (FloatReg 6) = Just (RealRegSingle REG_F6) # endif # if defined(REG_D1) globalRegMaybe (DoubleReg 1) = # if defined(MACHREGS_sparc) Just (RealRegPair REG_D1 (REG_D1 + 1)) # else Just (RealRegSingle REG_D1) # endif # endif # if defined(REG_D2) globalRegMaybe (DoubleReg 2) = # if defined(MACHREGS_sparc) Just (RealRegPair REG_D2 (REG_D2 + 1)) # else Just (RealRegSingle REG_D2) # endif # endif # if defined(REG_D3) globalRegMaybe (DoubleReg 3) = # if defined(MACHREGS_sparc) Just (RealRegPair REG_D3 (REG_D3 + 1)) # else Just (RealRegSingle REG_D3) # endif # endif # if defined(REG_D4) globalRegMaybe (DoubleReg 4) = # if defined(MACHREGS_sparc) Just (RealRegPair REG_D4 (REG_D4 + 1)) # else Just (RealRegSingle REG_D4) # endif # endif # if defined(REG_D5) globalRegMaybe (DoubleReg 5) = # if defined(MACHREGS_sparc) Just (RealRegPair REG_D5 (REG_D5 + 1)) # else Just (RealRegSingle REG_D5) # endif # endif # if defined(REG_D6) globalRegMaybe (DoubleReg 6) = # if defined(MACHREGS_sparc) Just (RealRegPair REG_D6 (REG_D6 + 1)) # else Just (RealRegSingle REG_D6) # endif # endif # if MAX_REAL_XMM_REG != 0 # if defined(REG_XMM1) globalRegMaybe (XmmReg 1) = Just (RealRegSingle REG_XMM1) # endif # if defined(REG_XMM2) globalRegMaybe (XmmReg 2) = Just (RealRegSingle REG_XMM2) # endif # if defined(REG_XMM3) globalRegMaybe (XmmReg 3) = Just (RealRegSingle REG_XMM3) # endif # if defined(REG_XMM4) globalRegMaybe (XmmReg 4) = Just (RealRegSingle REG_XMM4) # endif # if defined(REG_XMM5) globalRegMaybe (XmmReg 5) = Just (RealRegSingle REG_XMM5) # endif # if defined(REG_XMM6) globalRegMaybe (XmmReg 6) = Just (RealRegSingle REG_XMM6) # endif # endif # if defined(MAX_REAL_YMM_REG) && MAX_REAL_YMM_REG != 0 # if defined(REG_YMM1) globalRegMaybe (YmmReg 1) = Just (RealRegSingle REG_YMM1) # endif # if defined(REG_YMM2) globalRegMaybe (YmmReg 2) = Just (RealRegSingle REG_YMM2) # endif # if defined(REG_YMM3) globalRegMaybe (YmmReg 3) = Just (RealRegSingle REG_YMM3) # endif # if defined(REG_YMM4) globalRegMaybe (YmmReg 4) = Just (RealRegSingle REG_YMM4) # endif # if defined(REG_YMM5) globalRegMaybe (YmmReg 5) = Just (RealRegSingle REG_YMM5) # endif # if defined(REG_YMM6) globalRegMaybe (YmmReg 6) = Just (RealRegSingle REG_YMM6) # endif # endif # if defined(MAX_REAL_ZMM_REG) && MAX_REAL_ZMM_REG != 0 # if defined(REG_ZMM1) globalRegMaybe (ZmmReg 1) = Just (RealRegSingle REG_ZMM1) # endif # if defined(REG_ZMM2) globalRegMaybe (ZmmReg 2) = Just (RealRegSingle REG_ZMM2) # endif # if defined(REG_ZMM3) globalRegMaybe (ZmmReg 3) = Just (RealRegSingle REG_ZMM3) # endif # if defined(REG_ZMM4) globalRegMaybe (ZmmReg 4) = Just (RealRegSingle REG_ZMM4) # endif # if defined(REG_ZMM5) globalRegMaybe (ZmmReg 5) = Just (RealRegSingle REG_ZMM5) # endif # if defined(REG_ZMM6) globalRegMaybe (ZmmReg 6) = Just (RealRegSingle REG_ZMM6) # endif # endif # if defined(REG_Sp) globalRegMaybe Sp = Just (RealRegSingle REG_Sp) # endif # if defined(REG_Lng1) globalRegMaybe (LongReg 1) = Just (RealRegSingle REG_Lng1) # endif # if defined(REG_Lng2) globalRegMaybe (LongReg 2) = Just (RealRegSingle REG_Lng2) # endif # if defined(REG_SpLim) globalRegMaybe SpLim = Just (RealRegSingle REG_SpLim) # endif # if defined(REG_Hp) globalRegMaybe Hp = Just (RealRegSingle REG_Hp) # endif # if defined(REG_HpLim) globalRegMaybe HpLim = Just (RealRegSingle REG_HpLim) # endif # if defined(REG_CurrentTSO) globalRegMaybe CurrentTSO = Just (RealRegSingle REG_CurrentTSO) # endif # if defined(REG_CurrentNursery) globalRegMaybe CurrentNursery = Just (RealRegSingle REG_CurrentNursery) # endif # if defined(REG_MachSp) globalRegMaybe MachSp = Just (RealRegSingle REG_MachSp) # endif globalRegMaybe _ = Nothing #elif defined(MACHREGS_NO_REGS) globalRegMaybe _ = Nothing #else globalRegMaybe = panic "globalRegMaybe not defined for this platform" #endif freeReg :: RegNo -> Bool #if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) # if defined(MACHREGS_i386) freeReg esp = False -- %esp is the C stack pointer freeReg esi = False -- Note [esi/edi/ebp not allocatable] freeReg edi = False freeReg ebp = False # endif # if defined(MACHREGS_x86_64) freeReg rsp = False -- %rsp is the C stack pointer # endif {- Note [esi/edi/ebp not allocatable] %esi is mapped to R1, so %esi would normally be allocatable while it is not being used for R1. However, %esi has no 8-bit version on x86, and the linear register allocator is not sophisticated enough to handle this irregularity (we need more RegClasses). The graph-colouring allocator also cannot handle this - it was designed with more flexibility in mind, but the current implementation is restricted to the same set of classes as the linear allocator. Hence, on x86 esi, edi and ebp are treated as not allocatable. -} -- split patterns in two functions to prevent overlaps freeReg r = freeRegBase r freeRegBase :: RegNo -> Bool # if defined(REG_Base) freeRegBase REG_Base = False # endif # if defined(REG_Sp) freeRegBase REG_Sp = False # endif # if defined(REG_SpLim) freeRegBase REG_SpLim = False # endif # if defined(REG_Hp) freeRegBase REG_Hp = False # endif # if defined(REG_HpLim) freeRegBase REG_HpLim = False # endif -- All other regs are considered to be "free", because we can track -- their liveness accurately. freeRegBase _ = True #elif defined(MACHREGS_powerpc) freeReg 0 = False -- Used by code setting the back chain pointer -- in stack reallocations on Linux. -- Moreover r0 is not usable in all insns. freeReg 1 = False -- The Stack Pointer -- most ELF PowerPC OSes use r2 as a TOC pointer freeReg 2 = False freeReg 13 = False -- reserved for system thread ID on 64 bit -- at least linux in -fPIC relies on r30 in PLT stubs freeReg 30 = False {- TODO: reserve r13 on 64 bit systems only and r30 on 32 bit respectively. For now we use r30 on 64 bit and r13 on 32 bit as a temporary register in stack handling code. See compiler/nativeGen/PPC/Instr.hs. Later we might want to reserve r13 and r30 only where it is required. Then use r12 as temporary register, which is also what the C ABI does. -} # if defined(REG_Base) freeReg REG_Base = False # endif # if defined(REG_Sp) freeReg REG_Sp = False # endif # if defined(REG_SpLim) freeReg REG_SpLim = False # endif # if defined(REG_Hp) freeReg REG_Hp = False # endif # if defined(REG_HpLim) freeReg REG_HpLim = False # endif freeReg _ = True #elif defined(MACHREGS_sparc) -- SPARC regs used by the OS / ABI -- %g0(r0) is always zero freeReg g0 = False -- %g5(r5) - %g7(r7) -- are reserved for the OS freeReg g5 = False freeReg g6 = False freeReg g7 = False -- %o6(r14) -- is the C stack pointer freeReg o6 = False -- %o7(r15) -- holds the C return address freeReg o7 = False -- %i6(r30) -- is the C frame pointer freeReg i6 = False -- %i7(r31) -- is used for C return addresses freeReg i7 = False -- %f0(r32) - %f1(r32) -- are C floating point return regs freeReg f0 = False freeReg f1 = False {- freeReg regNo -- don't release high half of double regs | regNo >= f0 , regNo < NCG_FirstFloatReg , regNo `mod` 2 /= 0 = False -} # if defined(REG_Base) freeReg REG_Base = False # endif # if defined(REG_R1) freeReg REG_R1 = False # endif # if defined(REG_R2) freeReg REG_R2 = False # endif # if defined(REG_R3) freeReg REG_R3 = False # endif # if defined(REG_R4) freeReg REG_R4 = False # endif # if defined(REG_R5) freeReg REG_R5 = False # endif # if defined(REG_R6) freeReg REG_R6 = False # endif # if defined(REG_R7) freeReg REG_R7 = False # endif # if defined(REG_R8) freeReg REG_R8 = False # endif # if defined(REG_R9) freeReg REG_R9 = False # endif # if defined(REG_R10) freeReg REG_R10 = False # endif # if defined(REG_F1) freeReg REG_F1 = False # endif # if defined(REG_F2) freeReg REG_F2 = False # endif # if defined(REG_F3) freeReg REG_F3 = False # endif # if defined(REG_F4) freeReg REG_F4 = False # endif # if defined(REG_F5) freeReg REG_F5 = False # endif # if defined(REG_F6) freeReg REG_F6 = False # endif # if defined(REG_D1) freeReg REG_D1 = False # endif # if defined(REG_D1_2) freeReg REG_D1_2 = False # endif # if defined(REG_D2) freeReg REG_D2 = False # endif # if defined(REG_D2_2) freeReg REG_D2_2 = False # endif # if defined(REG_D3) freeReg REG_D3 = False # endif # if defined(REG_D3_2) freeReg REG_D3_2 = False # endif # if defined(REG_D4) freeReg REG_D4 = False # endif # if defined(REG_D4_2) freeReg REG_D4_2 = False # endif # if defined(REG_D5) freeReg REG_D5 = False # endif # if defined(REG_D5_2) freeReg REG_D5_2 = False # endif # if defined(REG_D6) freeReg REG_D6 = False # endif # if defined(REG_D6_2) freeReg REG_D6_2 = False # endif # if defined(REG_Sp) freeReg REG_Sp = False # endif # if defined(REG_SpLim) freeReg REG_SpLim = False # endif # if defined(REG_Hp) freeReg REG_Hp = False # endif # if defined(REG_HpLim) freeReg REG_HpLim = False # endif freeReg _ = True #else freeReg = panic "freeReg not defined for this platform" #endif ghc-lib-parser-8.10.2.20200808/compiler/GhclibHsVersions.h0000644000000000000000000000421313713635665020707 0ustar0000000000000000#pragma once -- For GHC_STAGE #include "ghcplatform.h" #if 0 IMPORTANT! If you put extra tabs/spaces in these macro definitions, you will screw up the layout where they are used in case expressions! (This is cpp-dependent, of course) #endif #define GLOBAL_VAR(name,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ name = Util.global (value); #define GLOBAL_VAR_M(name,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ name = Util.globalM (value); #define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ name = Util.sharedGlobal (value) (accessor); \ foreign import ccall unsafe saccessor \ accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); #define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \ name = Util.sharedGlobalM (value) (accessor); \ foreign import ccall unsafe saccessor \ accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); #define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else #define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else #define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $ -- Examples: Assuming flagSet :: String -> m Bool -- -- do { c <- getChar; MASSERT( isUpper c ); ... } -- do { c <- getChar; MASSERT2( isUpper c, text "Bad" ); ... } -- do { str <- getStr; ASSERTM( flagSet str ); .. } -- do { str <- getStr; ASSERTM2( flagSet str, text "Bad" ); .. } -- do { str <- getStr; WARNM2( flagSet str, text "Flag is set" ); .. } #define MASSERT(e) ASSERT(e) return () #define MASSERT2(e,msg) ASSERT2(e,msg) return () #define ASSERTM(e) do { bool <- e; MASSERT(bool) } #define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) } #define WARNM2(e,msg) do { bool <- e; WARN(bool, msg) return () } ghc-lib-parser-8.10.2.20200808/compiler/Unique.h0000644000000000000000000000024013713635662016732 0ustar0000000000000000/* unique has the following structure: * HsInt unique = * (unique_tag << (sizeof (HsInt) - UNIQUE_TAG_BITS)) | unique_number */ #define UNIQUE_TAG_BITS 8