/src/Cxx/Operations.hs
Haskell | 1030 lines | 808 code | 178 blank | 44 comment | 33 complexity | ce49598e9aa1fd1d74a410a6e7b13621 MD5 | raw file
Large files files are truncated, but you can click here to view the full file
1{-# LANGUAGE UnicodeSyntax, DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances, PatternGuards, Rank2Types, OverlappingInstances, ScopedTypeVariables, ExistentialQuantification, TypeSynonymInstances, CPP, ViewPatterns, TupleSections #-} 2 3module Cxx.Operations (apply, mapply, squared, parenthesized, is_primary_TypeSpecifier, split_all_decls, map_plain, parseAbbrMain, expand, line_breaks, specT, find, is_pointer_or_reference, namedPathTo, findable_productions, make_edits, ShortCode) where 4 5import qualified Cxx.Show 6import qualified Data.List.NonEmpty as NeList 7import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty) 8import qualified Data.Maybe as Maybe 9import Util (Convert(..), (.), total_tail, strip, isIdChar, TriBool(..), MaybeEitherString(..), Phantom(..), neElim, NeList, orElse, neFilter, Apply(..), MaybeApply(..), MyMonadError(..)) 10import Cxx.Basics 11import Editing.Basics (Range(..), Offsettable(..), TextEdit(..), Pos(Pos), pos, contained_in, fullRange) 12import Editing.Diff (diff_as_Edits) 13import Data.Function (on) 14import Data.Foldable (toList, any) 15import Control.Arrow (first, second) 16import Control.Monad.Identity 17import Data.Generics (cast, gmapT, everywhere, Data, Typeable, gfoldl, dataTypeOf, toConstr, Constr, DataType, dataTypeName, constrType) 18 19import Prelude hiding ((.), any) 20import Prelude.Unicode 21 22-- Operations on Chunks/Code 23 24map_plain :: (String → String) → Chunk → Chunk 25map_plain f (Plain s) = Plain $ f s 26map_plain f (Curlies c) = Curlies $ map (map_plain f) c 27map_plain f (Parens c) = Parens $ map (map_plain f) c 28map_plain f (Squares c) = Squares $ map (map_plain f) c 29map_plain _ x = x 30 31int_main :: String 32int_main = "\nint main(int argc, char * argv[])" 33 34gen :: String → String → String → TString 35gen left middle right 36 = map (, 0) left 37 ++ zip middle [0..] 38 ++ map (, length middle) right 39 40generateMain :: AbbreviatedMain → TString 41generateMain (Block c) = gen int_main ("{" ++ show c ++ "}") "" 42generateMain (Call c) = gen (int_main ++ "{printf") (show c) "\n;}" 43generateMain (Print c) = gen (int_main ++ "{::std::cout") ("<<" ++ show c) "\n;}" 44 -- The newlines make //-style comments work. 45 46cstyle_comments :: Code → Code 47cstyle_comments = map f where f (SingleComment s) = MultiComment s; f c = c 48 49type ShortCode = (Maybe AbbreviatedMain, Code) 50 51instance Show AbbreviatedMain where 52 show (Block c) = show [Curlies c] 53 show (Call c) = show c 54 show (Print c) = show $ [Plain "<<"] ++ c 55 56type TString = [(Char, Int {- position in the request body -})] 57 58expand :: Code -> (Maybe TString {- generated main -}, TString {- rest -}) 59expand requestChunks = 60 ( generateMain . mAbbrMain 61 , zip (show rest) [maybe 0 (length . show) mAbbrMain ..]) 62 where 63 (mAbbrMain, rest) = parseAbbrMain requestChunks 64 65parseAbbrMain :: Code → (Maybe AbbreviatedMain, Code) 66parseAbbrMain (Curlies c : b) = (Just (Block c), b) 67parseAbbrMain (Plain ('<':'<':a) : b) = (Just (Print x), total_tail y) 68 where (x, y) = break (== Plain ";") $ Plain a : b 69parseAbbrMain (Parens c : b) = (Just (Call (Parens c : x)), total_tail y) 70 where (x, y) = break (== Plain ";") b 71parseAbbrMain c = (Nothing, c) 72 73line_breaks :: Code → Code 74line_breaks = map $ map_plain $ map $ \c → if c == '\\' then '\n' else c 75 76-- Convenience constructors 77 78squared :: a → Squared a 79squared x = Squared (OpenSquare_, White "") (Enclosed x) (CloseSquare_, White "") 80 81parenthesized :: a → Parenthesized a 82parenthesized x = Parenthesized (OpenParen_, White "") (Enclosed x) (CloseParen_, White "") 83 84specT :: TypeSpecifier 85specT = TypeSpecifier_TrailingTypeSpecifier $ TrailingTypeSpecifier_SimpleTypeSpecifier $ SimpleTypeSpecifier_TypeName (OptQualified Nothing Nothing) $ TypeName_ClassName $ ClassName_Identifier $ Identifier "T" $ White " " 86 87-- Applying make-specifications. 88 89apply_makedecl_to :: Data d ⇒ MakeDeclaration → d → MaybeEitherString d 90apply_makedecl_to makedecl = Maybe.fromMaybe (const $ MaybeEitherString Nothing) $ Maybe.listToMaybe . Maybe.catMaybes $ 91 [ cast ((\d → case d of 92 SimpleDeclaration specs (Just (InitDeclaratorList (Commad (InitDeclarator x mi) []))) w → 93 case makedecl of 94 MakeDeclaration _ _ Definitely → throwError "Cannot purify simple-declaration." 95 MakeDeclaration specs' mpad _ → return $ let (specs'', x') = apply (specs', mpad) (specs, x) in 96 SimpleDeclaration specs'' (Just (InitDeclaratorList (Commad (InitDeclarator x' mi) []))) w 97 _ → MaybeEitherString Nothing) :: SimpleDeclaration → MaybeEitherString SimpleDeclaration) 98 , cast (mapply makedecl :: ParameterDeclaration → MaybeEitherString ParameterDeclaration) 99 , cast ((\d → case d of 100 ExceptionDeclaration u (Just (Left e)) → 101 case makedecl of 102 MakeDeclaration _ _ Definitely → throwError "Cannot purify exception-declaration." 103 MakeDeclaration specs mpad _ → 104 (\(u', e') → ExceptionDeclaration u' $ Just $ Left e') . mapply (specs, mpad) (u, e) 105 _ → MaybeEitherString Nothing) :: ExceptionDeclaration → MaybeEitherString ExceptionDeclaration) 106 , cast ((\d → case d of 107 MemberDeclaration specs (Just (MemberDeclaratorList (Commad (MemberDeclarator decl ps) []))) semicolon → 108 return $ let (specs', decl', ps') = apply makedecl (specs, decl, ps) in 109 MemberDeclaration specs' (Just (MemberDeclaratorList (Commad (MemberDeclarator decl' ps') []))) semicolon 110 _ → MaybeEitherString Nothing) :: MemberDeclaration → MaybeEitherString MemberDeclaration) 111 , cast (mapply makedecl :: FunctionDefinition → MaybeEitherString FunctionDefinition) 112 , cast ((\d → case d of 113 Condition_Declaration u e i → 114 case makedecl of 115 MakeDeclaration _ _ Definitely → throwError "Cannot purify condition-declaration." 116 MakeDeclaration specs mpad _ → 117 (\(u', e') → Condition_Declaration u' e' i) . mapply (specs, mpad) (u, e) 118 _ → MaybeEitherString Nothing) :: Condition → MaybeEitherString Condition) 119 , cast (mapply makedecl :: ForRangeDeclaration → MaybeEitherString ForRangeDeclaration) 120 ] 121 122-- Getting declarator-ids out of things. 123 124instance Convert ClassSpecifier (Maybe DeclaratorId) where convert (ClassSpecifier h _) = convert h 125instance Convert ClassHead (Maybe DeclaratorId) where convert (ClassHead _ k _) = convert k 126instance Convert Identifier DeclaratorId where convert = DeclaratorId_IdExpression Nothing . convert 127instance Convert Identifier IdExpression where convert = IdExpression . Right . convert 128instance Convert Identifier UnqualifiedId where convert = UnqualifiedId_Identifier 129instance Convert (NestedNameSpecifier, Identifier) QualifiedId where convert (nns, i) = NestedUnqualifiedId Nothing nns Nothing (convert i) 130instance Convert (NestedNameSpecifier, Identifier) IdExpression where convert = IdExpression . Left . convert 131instance Convert SimpleTemplateId UnqualifiedId where convert = UnqualifiedId_TemplateId . convert 132instance Convert SimpleTemplateId IdExpression where convert = IdExpression . Right . convert 133instance Convert SimpleTemplateId DeclaratorId where convert = DeclaratorId_IdExpression Nothing . convert 134instance Convert SimpleTemplateId TemplateId where convert = TemplateId_SimpleTemplateId 135instance Convert (NestedNameSpecifier, SimpleTemplateId) DeclaratorId where convert = DeclaratorId_IdExpression Nothing . convert 136instance Convert (NestedNameSpecifier, SimpleTemplateId) IdExpression where convert = IdExpression . Left . convert 137instance Convert (NestedNameSpecifier, SimpleTemplateId) QualifiedId where convert (nns, tid) = NestedUnqualifiedId Nothing nns Nothing (convert tid) 138instance Convert ClassHeadKind (Maybe DeclaratorId) where 139 convert (ClassHeadKind_Identifier m) = convert . m 140 convert (ClassHeadKind_NestedIdentifier nns i) = Just $ DeclaratorId_IdExpression Nothing $ convert (nns, i) 141 convert (ClassHeadKind_SimpleTemplateId Nothing i) = Just $ convert i 142 convert (ClassHeadKind_SimpleTemplateId (Just nns) i) = Just $ convert (nns, i) 143instance Convert EnumSpecifier (Maybe DeclaratorId) where convert (EnumSpecifier x _) = convert x 144instance Convert EnumHead (Maybe DeclaratorId) where convert (EnumHead _ m _) = convert . m 145instance Convert DeclSpecifier (Maybe DeclaratorId) where 146 convert (DeclSpecifier_TypeSpecifier (TypeSpecifier_ClassSpecifier c)) = convert c 147 convert (DeclSpecifier_TypeSpecifier (TypeSpecifier_EnumSpecifier c)) = convert c 148 convert (DeclSpecifier_TypeSpecifier (TypeSpecifier_TrailingTypeSpecifier (TrailingTypeSpecifier_ElaboratedTypeSpecifier c))) = Just $ convert c 149 convert _ = Nothing 150instance Convert SimpleDeclaration (Maybe DeclaratorId) where 151 convert (SimpleDeclaration _ (Just (InitDeclaratorList (Commad (InitDeclarator d _) []))) _) = Just $ convert d 152 convert (SimpleDeclaration (Just (DeclSpecifierSeq (neElim → (d, [])))) Nothing _) = convert d 153 convert _ = Nothing 154instance Convert NamespaceAliasDefinition DeclaratorId where convert (NamespaceAliasDefinition _ i _ _ _ _) = convert i 155instance Convert BlockDeclaration (Maybe DeclaratorId) where 156 convert (BlockDeclaration_SimpleDeclaration d) = convert d 157 convert (BlockDeclaration_NamespaceAliasDefinition d) = Just $ convert d 158 convert (BlockDeclaration_AliasDeclaration d) = Just $ convert d 159 convert _ = Nothing 160instance Convert ExplicitSpecialization (Maybe DeclaratorId) where convert (ExplicitSpecialization _ _ d) = convert d 161instance Convert FunctionDefinition DeclaratorId where convert (FunctionDefinition _ d _) = convert d 162instance Convert NamespaceDefinition (Maybe DeclaratorId) where convert (NamespaceDefinition _ _ m _) = convert . m 163instance Convert AliasDeclaration DeclaratorId where convert (AliasDeclaration _ i _ _ _) = convert i 164instance Convert Declaration (Maybe DeclaratorId) where 165 convert (Declaration_BlockDeclaration d) = convert d 166 convert (Declaration_FunctionDefinition d) = Just $ convert d 167 convert (Declaration_TemplateDeclaration d) = convert d 168 convert (Declaration_NamespaceDefinition d) = convert d 169 convert (Declaration_ExplicitSpecialization d) = convert d 170 convert _ = Nothing 171instance Convert TemplateDeclaration (Maybe DeclaratorId) where convert (TemplateDeclaration _ _ _ d) = convert d 172instance Convert ExplicitInstantiation (Maybe DeclaratorId) where convert (ExplicitInstantiation _ _ d) = convert d 173instance Convert MemberDeclarator (Maybe DeclaratorId) where 174 convert (MemberDeclarator d _) = Just $ convert d 175 convert (BitField m _ _) = convert . m 176instance Convert MemberDeclaration (Maybe DeclaratorId) where 177 convert (MemberFunctionDefinition d _) = Just $ convert d 178 convert (MemberUsingDeclaration _) = Nothing 179 convert (MemberTemplateDeclaration d) = convert d 180 convert (MemberDeclaration _ (Just (MemberDeclaratorList (Commad d []))) _) = convert d 181 convert (MemberDeclaration (Just (DeclSpecifierSeq (neElim → (d, [])))) Nothing _) = convert d 182 convert (MemberDeclaration _ _ _) = Nothing 183instance Convert ExceptionDeclaration (Maybe DeclaratorId) where 184 convert (ExceptionDeclaration _ (Just (Left d))) = Just $ convert d 185 convert _ = Nothing 186instance Convert ParameterDeclaration (Maybe DeclaratorId) where 187 convert (ParameterDeclaration _ (Left d) _) = Just $ convert d 188 convert _ = Nothing 189instance Convert Condition (Maybe DeclaratorId) where 190 convert (Condition_Declaration _ d _) = Just $ convert d 191 convert _ = Nothing 192instance Convert ForRangeDeclaration DeclaratorId where 193 convert (ForRangeDeclaration _ d) = convert d 194instance Convert (OptQualified, Identifier) DeclaratorId where 195 convert (OptQualified Nothing Nothing, i) = convert i 196 convert (OptQualified (Just s) Nothing, i) = DeclaratorId_IdExpression Nothing $ IdExpression $ Left $ GlobalIdentifier s i 197 convert (OptQualified ms (Just nns), i) = DeclaratorId_IdExpression Nothing $ IdExpression $ Left $ NestedUnqualifiedId ms nns Nothing $ convert i 198instance Convert QualifiedId DeclaratorId where 199 convert = DeclaratorId_IdExpression Nothing . IdExpression . Left 200instance Convert (OptQualified, SimpleTemplateId) DeclaratorId where 201 convert (OptQualified Nothing Nothing, stid) = convert stid 202 convert (OptQualified (Just s) Nothing, stid) = DeclaratorId_IdExpression Nothing $ IdExpression $ Left $ GlobalTemplateId s $ convert stid 203 convert (OptQualified ms (Just nns), stid) = DeclaratorId_IdExpression Nothing $ IdExpression $ Left $ NestedUnqualifiedId ms nns Nothing $ convert stid 204instance Convert ElaboratedTypeSpecifier DeclaratorId where 205 convert (ElaboratedTypeSpecifier _ optqualified (Right identifier)) = convert (optqualified, identifier) 206 convert (ElaboratedTypeSpecifier _ optqualified (Left (_, stid))) = convert (optqualified, stid) 207 -- Todo: Maybe using the (KwdTemplate, White) pair in the declarator-id would be better. 208instance Convert Declarator DeclaratorId where 209 convert (Declarator_PtrDeclarator p) = convert p 210 convert (Declarator_TrailingReturnType d _ _) = convert d 211instance Convert PtrDeclarator DeclaratorId where 212 convert (PtrDeclarator_NoptrDeclarator d) = convert d 213 convert (PtrDeclarator _ d) = convert d 214instance Convert NoptrDeclarator DeclaratorId where 215 convert (NoptrDeclarator_Id did) = did 216 convert (NoptrDeclarator_WithParams d _) = convert d 217 convert (NoptrDeclarator_Squared d _) = convert d 218 convert (NoptrDeclarator_Parenthesized (Parenthesized _ (Enclosed d) _)) = convert d 219instance Convert ((ScopeRes, White), UnqualifiedId) (Maybe DeclaratorId) where 220 convert (scoperes, UnqualifiedId_Identifier i) = Just $ convert (GlobalIdentifier scoperes i) 221 convert (scoperes, UnqualifiedId_TemplateId i) = Just $ convert (GlobalTemplateId scoperes i) 222 convert (scoperes, UnqualifiedId_OperatorFunctionId i) = Just $ convert (GlobalOperatorFunctionId scoperes i) 223 convert (_, UnqualifiedId_Destructor _ _) = Nothing -- There are no global destructors. 224 convert (_, UnqualifiedId_ConversionFunctionId _) = Nothing -- There are no global conversion operators. 225instance Convert UsingDeclaration (Maybe DeclaratorId) where 226 convert (UsingDeclaration_Nested _ _ msr nns i _) = Just $ convert $ NestedUnqualifiedId msr nns Nothing i 227 convert (UsingDeclaration_NonNested _ s i _) = convert (s, i) 228 229-- Finding declarations 230 231gfoldl_with_lengths :: Data a ⇒ Int → (forall d. Data d ⇒ Int → d → [r]) → a → [r] 232gfoldl_with_lengths i f = runIdentity . gfoldl_with_lengthsM i ((Identity .) . f) 233 234gfoldl_with_ranges :: Data a ⇒ Int → (forall d. Data d ⇒ Range Char → d → [r]) → a → [r] 235gfoldl_with_ranges i f = runIdentity . gfoldl_with_rangesM i ((Identity .) . f) 236 237gfoldl_with_lengthsM :: (Data a, Monad m) ⇒ Int → (forall d. Data d ⇒ Int → d → m [r]) → a → m [r] 238gfoldl_with_lengthsM i f = gfoldl_with_rangesM i (f . pos . start) 239 240data GfoldlWithLengthsIntermediary m r a = GfoldlWithLengthsIntermediary { gwli_result :: m [r], _off :: Int } 241 242gfoldl_with_rangesM :: (Data a, Monad m) ⇒ Int → (forall d. Data d ⇒ Range Char → d → m [r]) → a → m [r] 243gfoldl_with_rangesM i f = gwli_result . gfoldl (\(GfoldlWithLengthsIntermediary m o) y → 244 let n = length (Cxx.Show.show_simple y) in 245 GfoldlWithLengthsIntermediary (liftM2 (++) m (f (Range (Pos o) n) y)) (o + n)) (\_ → GfoldlWithLengthsIntermediary (return []) i) 246 247listElem :: forall a d . (Data a, Typeable a, Data d) ⇒ Phantom a → d → Maybe (Range Char, Range Char) 248listElem _ d 249 | Just (Commad x []) ← cast d :: Maybe (Commad a) = 250 Just $ diag $ fullRange (Cxx.Show.show_simple x) 251 | Just (Commad x ((cw, _):_)) ← cast d :: Maybe (Commad a) = 252 Just (fullRange $ Cxx.Show.show_simple (x, cw), fullRange $ Cxx.Show.show_simple x) 253 | Just x@(cw, r) ← cast d :: Maybe ((CommaOp, White), a) = 254 Just (fullRange $ Cxx.Show.show_simple x, 255 Range (Pos $ length $ Cxx.Show.show_simple cw) (length $ Cxx.Show.show_simple r)) 256 | otherwise = Nothing 257 258bodyOf :: Data d ⇒ d → DeclaratorId → Maybe (Range Char) 259bodyOf x did 260 | Just (GeordiRequest_Block (FunctionBody _ (CompoundStatement (Curlied o b _))) _) ← cast x, strip (show did) == "main" = 261 Just $ Range (Pos $ length $ Cxx.Show.show_simple o) (length $ Cxx.Show.show_simple b) 262 | Just (ClassSpecifier classHead (Curlied o b _)) ← cast x, convert classHead == Just did = 263 Just $ Range (Pos $ length $ Cxx.Show.show_simple (classHead, o)) (length $ Cxx.Show.show_simple b) 264 | Just (EnumSpecifier enumHead (Curlied o b _)) ← cast x, convert enumHead == Just did = 265 Just $ Range (Pos $ length $ Cxx.Show.show_simple (enumHead, o)) (length $ Cxx.Show.show_simple b) 266 | Just (FunctionDefinition specs declarator (FunctionBody ctorInitializer (CompoundStatement (Curlied o b _)))) ← cast x, convert declarator == did = 267 Just $ Range (Pos $ length $ Cxx.Show.show_simple (specs, declarator, ctorInitializer, o)) (length $ Cxx.Show.show_simple b) 268 | Just (NamespaceDefinition inline kwd (Just identifier) (Curlied o b _)) ← cast x, convert identifier == did = 269 Just $ Range (Pos $ length $ Cxx.Show.show_simple (inline, kwd, identifier, o)) (length $ Cxx.Show.show_simple b) 270 | otherwise = Nothing 271 272instance Eq DataType where (==) = (==) `on` dataTypeName 273 274constr_eq :: Constr → Constr → Bool 275 -- The existing Eq instance only compares constructor indices for algebraic data types, so for instance the first constructors of two unrelated algebraic data types are considered equal. 276constr_eq c d = c == d ∧ constrType c == constrType d 277 278data AnyData = forall d . Data d ⇒ AnyData d 279 280type TreePath = NeList AnyData 281 282applyAny :: (forall a. Data a ⇒ a → b) → (AnyData → b) 283applyAny p (AnyData x) = p x 284 285diag :: a → (a, a) 286diag x = (x, x) 287 288finder :: Findable → TreePath → Maybe (Range Char, Range Char) 289finder f = case f of 290 FindableDataType t → (diag .) . simpleFinder ((== t) . applyAny dataTypeOf . NeList.head) 291 FindableConstr c → (diag .) . simpleFinder (constr_eq c . applyAny toConstr . NeList.head) 292 BodyOf d → (diag .) . applyAny (`bodyOf` d) . NeList.head 293 DeclarationOf d → (diag .) . simpleFinder (complete (`isDeclarationOf` d)) 294 Constructor → (diag .) . simpleFinder (complete $ isSpecialFuncWith isConstructorId) 295 Destructor → (diag .) . simpleFinder (complete $ isSpecialFuncWith isDestructorId) 296 ConversionFunction → (diag .) . simpleFinder (complete $ isSpecialFuncWith isConversionFunctionId) 297 FindableParameterDeclaration → applyAny (listElem (Phantom :: Phantom ParameterDeclaration)) . NeList.head 298 TemplateParameter → applyAny (listElem (Phantom :: Phantom TemplateParameter)) . NeList.head 299 TemplateArgument → applyAny (listElem (Phantom :: Phantom TemplateArgument)) . NeList.head 300 where 301 simpleFinder p t | AnyData x ← NeList.head t = 302 if p t then Just $ fullRange $ Cxx.Show.show_simple x else Nothing 303 304find :: Data d ⇒ Findable → d → [(Range Char, Range Char)] 305find f = findRange (finder f) [] 0 306 307complete :: (forall d . Data d ⇒ d → Bool) → TreePath → Bool 308complete p d | AnyData x ← NeList.head d = 309 p x ∧ case NeList.tail d of [] → True; AnyData h : _ → not $ p h 310 311pathTo :: Data d ⇒ d → Range Char → Int → TreePath 312 -- Precondition: the range is entirely within [0, length (show d)] 313pathTo x r i = AnyData x :| case gfoldl_with_ranges i f x of 314 [] → [] 315 l : _ → toList l 316 where f r'@(Range st _) y = [pathTo y r (pos st) | r `contained_in` r'] 317 318findable_productions, all_productions :: [DataType] 319findable_productions = 320#define P(n) dataTypeOf (undefined :: Cxx.Basics.n) 321 -- A.1 Keywords [gram.key] 322 [ P(TypedefName), P(NamespaceName), P(OriginalNamespaceName), P(NamespaceAlias) 323 , P(ClassName), P(EnumName), P(TemplateName) 324 325 -- A.2 Lexical conventions [gram.lex] 326 , P(Identifier), P(Literal), P(IntegerLiteral), P(CharacterLiteral), P(FloatingLiteral), P(StringLiteral), P(EncodingPrefix) 327 328 -- A.4 Expressions [gram.expr] 329 , P(PrimaryExpression), P(IdExpression), P(UnqualifiedId), P(QualifiedId), P(NestedNameSpecifier), P(PostfixExpression) 330 , P(ExpressionList), P(PseudoDestructorName), P(UnaryExpression), P(UnaryOperator), P(NewExpression), P(NewPlacement) 331 , P(NewTypeId), P(NewDeclarator), P(NoptrNewDeclarator), P(NewInitializer), P(DeleteExpression) 332 , P(CastExpression), P(PmExpression), P(MultiplicativeExpression), P(AdditiveExpression), P(ShiftExpression) 333 , P(RelationalExpression), P(EqualityExpression), P(AndExpression), P(ExclusiveOrExpression) 334 , P(InclusiveOrExpression), P(LogicalAndExpression), P(LogicalOrExpression), P(ConditionalExpression) 335 , P(AssignmentExpression), P(AssignmentOperator), P(Expression), P(ConstantExpression) 336 , P(LambdaExpression), P(LambdaIntroducer), P(LambdaCapture), P(CaptureDefault), P(CaptureList), P(Capture), P(LambdaDeclarator) 337 338 -- A.5 Statements [gram.stmt] 339 , P(Statement), P(StatementSeq), P(Label), P(LabeledStatement), P(ExpressionStatement), P(CompoundStatement) 340 , P(SelectionStatement), P(Condition), P(IterationStatement), P(ForInitStatement), P(ForRangeDeclaration), P(ForRangeInitializer), P(JumpStatement), P(DeclarationStatement) 341 342 -- A.6 Declarations [gram.dcl] 343 , P(Declaration), P(DeclarationSeq), P(BlockDeclaration), P(AliasDeclaration), P(SimpleDeclaration), P(StaticAssertDeclaration) 344 , P(DeclSpecifier), P(DeclSpecifierSeq), P(StorageClassSpecifier), P(FunctionSpecifier), P(TrailingTypeSpecifier), P(TypeSpecifier), P(TypeSpecifierSeq), P(SimpleTypeSpecifier) 345 , P(TypeName), P(ElaboratedTypeSpecifier), P(EnumSpecifier), P(EnumHead), P(EnumKey), P(EnumeratorList), P(EnumeratorDefinition) 346 , P(Enumerator), P(NamespaceDefinition), P(NamespaceAliasDefinition), P(UsingDeclaration), P(UsingDirective), P(AsmDefinition), P(LinkageSpecification) 347 , P(AlignmentSpecifier) 348 349 -- A.7 Declarators [gram.decl] 350 , P(InitDeclaratorList), P(InitDeclarator), P(Declarator), P(PtrDeclarator), P(NoptrDeclarator), P(ParametersAndQualifiers) 351 , P(PtrOperator), P(CvQualifier), P(CvQualifierSeq), P(DeclaratorId), P(TypeId), P(AbstractDeclarator), P(PtrAbstractDeclarator) 352 , P(NoptrAbstractDeclarator), P(ParameterDeclarationClause), P(ParameterDeclarationList), P(FunctionDefinition) 353 , P(FunctionBody), P(Initializer), P(BraceOrEqualInitializer), P(InitializerClause), P(InitializerList), P(BracedInitList), P(NamespaceBody) 354 , P(TrailingReturnType) 355 356 -- A.8 Classes [gram.class] 357 , P(ClassSpecifier), P(ClassHead), P(ClassKey), P(MemberAccessSpecifier) 358 , P(MemberSpecification), P(MemberDeclaration), P(MemberDeclaratorList), P(MemberDeclarator), P(PureSpecifier) 359 360 -- A.9 Derived classes [gram.derived] 361 , P(BaseClause), P(BaseSpecifierList), P(BaseSpecifier), P(AccessSpecifier) 362 363 -- A.10 Special member functions [gram.special] 364 , P(ConversionFunctionId), P(ConversionTypeId), P(CtorInitializer), P(MemInitializerList), P(MemInitializer), P(MemInitializerId) 365 366 -- A.11 Overloading [gram.over] 367 , P(OperatorFunctionId) 368 369 -- A.12 Templates [gram.temp] 370 , P(TemplateDeclaration), P(TemplateParameterList), P(TypeParameter), P(TemplateArguments), P(SimpleTemplateId) 371 , P(TemplateId), P(TemplateArgumentList), P(TemplateArgument), P(TypenameSpecifier), P(ExplicitInstantiation) 372 , P(ExplicitSpecialization) 373 374 -- A.13 Exception handling [gram.except] 375 , P(TryBlock), P(FunctionTryBlock), P(Handler), P(HandlerSeq), P(ExceptionDeclaration), P(ThrowExpression), P(ExceptionSpecification) 376 , P(TypeIdList) ] 377all_productions = findable_productions ++ [P(ParameterDeclaration), P(TemplateParameter), P(TemplateArgument)] 378 -- These three are not part of findable_productions because they get special Findable treatment. 379#undef P 380 381namedPathTo :: Data d ⇒ d → Range Char → [String] 382namedPathTo d r = map Cxx.Show.dataType_abbreviated_productionName $ 383 filter (∈ all_productions) $ toList $ fmap (applyAny dataTypeOf) (pathTo d r 0) 384 385findRange :: (Offsettable a, Data d) ⇒ (TreePath → Maybe a) → [AnyData] → Int → d → [a] 386findRange p tp i x = Maybe.maybeToList (offset i . p (AnyData x :| tp)) ++ gfoldl_with_lengths i (findRange p (AnyData x : tp)) x 387 388make_edits :: (MyMonadError String m, Data d) ⇒ Range Char → MakeDeclaration → Int → d → m [TextEdit Char] 389make_edits r m i d = do 390 ot ← gfoldl_with_lengthsM i (make_edits r m) d 391 oi ← (if Range (Pos i) (length $ strip $ Cxx.Show.show_simple d) == r 392 then (case apply_makedecl_to m d of 393 MaybeEitherString (Just (Right d')) → return $ offset i $ diff_as_Edits (Cxx.Show.show_simple d) (Cxx.Show.show_simple d') 394 MaybeEitherString (Just (Left e)) → throwError e 395 MaybeEitherString Nothing → return []) 396 else return []) 397 return $ oi ++ ot 398 399instance Convert [DeclSpecifier] [TypeSpecifier] where 400 convert = Maybe.mapMaybe $ \ds → 401 case ds of 402 DeclSpecifier_TypeSpecifier t → Just t 403 _ → Nothing 404 405isSpecialFunc :: Data d ⇒ d → Maybe DeclaratorId 406 -- "special" meaning: without any type-specifiers. 407isSpecialFunc x 408 | Just s@(MemberDeclaration l _ _) ← cast x, null (convert l :: [TypeSpecifier]) = convert s 409 | Just (MemberFunctionDefinition f@(FunctionDefinition Nothing _ _) _) ← cast x = Just $ convert f 410 | Just (MemberTemplateDeclaration d) ← cast x = isSpecialFunc d 411 | Just f@(FunctionDefinition l _ _) ← cast x, null (convert l :: [TypeSpecifier]) = Just $ convert f 412 | Just (TemplateDeclaration _ _ _ d) ← cast x = isSpecialFunc d 413 | Just (Declaration_FunctionDefinition d) ← cast x = isSpecialFunc d 414 | Just (Declaration_TemplateDeclaration d) ← cast x = isSpecialFunc d 415 | Just (Declaration_BlockDeclaration d) ← cast x = isSpecialFunc d 416 | Just (BlockDeclaration_SimpleDeclaration d) ← cast x = isSpecialFunc d 417 | Just s@(SimpleDeclaration l _ _) ← cast x, null (convert l :: [TypeSpecifier]) = convert s 418 | otherwise = Nothing 419 420isSpecialFuncWith :: Data d ⇒ (DeclaratorId → Bool) → d → Bool 421isSpecialFuncWith p x 422 | Just did ← isSpecialFunc x = p did 423 | otherwise = False 424 425isConstructorId :: DeclaratorId → Bool 426isConstructorId i = not $ isDestructorId i ∨ isConversionFunctionId i 427 428isDestructorId :: DeclaratorId → Bool 429isDestructorId (DeclaratorId_IdExpression Nothing (IdExpression e)) = case e of 430 Right (UnqualifiedId_Destructor _ _) → True 431 Left (NestedUnqualifiedId _ _ _ (UnqualifiedId_Destructor _ _)) → True 432 _ → False 433isDestructorId _ = False 434 435isConversionFunctionId :: DeclaratorId → Bool 436isConversionFunctionId = Maybe.isJust . (convert :: DeclaratorId → Maybe ConversionFunctionId) 437 438isDeclarationOf :: Data d ⇒ d → DeclaratorId → Bool 439isDeclarationOf x did = Just did == case () of { () 440 | Just s ← cast x → convert (s :: Declaration) 441 | Just s ← cast x → convert (s :: BlockDeclaration) 442 | Just s ← cast x → Just $ convert (s :: FunctionDefinition) 443 | Just s ← cast x → convert (s :: TemplateDeclaration) 444 | Just s ← cast x → convert (s :: ExplicitInstantiation) 445 | Just s ← cast x → convert (s :: ExplicitSpecialization) 446 | Just s ← cast x → convert (s :: NamespaceDefinition) 447 | Just s ← cast x → convert (s :: SimpleDeclaration) 448 | Just s ← cast x → Just $ convert (s :: NamespaceAliasDefinition) 449 | Just s ← cast x → convert (s :: UsingDeclaration) 450 | Just s ← cast x → Just $ convert (s :: AliasDeclaration) 451 | Just s ← cast x → convert (s :: MemberDeclaration) 452 | Just s ← cast x → convert (s :: ExceptionDeclaration) 453 | Just s ← cast x → convert (s :: ParameterDeclaration) 454 | Just s ← cast x → convert (s :: Condition) 455 | Just s ← cast x → Just $ convert (s :: ForRangeDeclaration) 456 | otherwise → Nothing } 457 458-- Specifier/qualifier compatibility. 459 460class Compatible a b where compatible :: a → b → Bool 461 -- For instances where a=b, compatible should be symmetric. 462 463instance Compatible CvQualifier CvQualifier where compatible = (≠) 464 465instance Compatible CvQualifier TypeSpecifier where 466 compatible cv (TypeSpecifier_TrailingTypeSpecifier (TrailingTypeSpecifier_CvQualifier (cv', _))) = compatible cv cv' 467 compatible _ _ = True 468 469instance Compatible CvQualifier DeclSpecifier where 470 compatible cv (DeclSpecifier_TypeSpecifier t) = compatible cv t 471 compatible _ _ = True 472 473instance Compatible SimpleTypeSpecifier SimpleTypeSpecifier where 474 compatible (SignSpec _) (LengthSpec _) = True 475 compatible (LengthSpec _) (SignSpec _) = True 476 compatible (LengthSpec (LongSpec, _)) (SimpleTypeSpecifier_BasicType (Int', _)) = True 477 compatible (LengthSpec (LongSpec, _)) (SimpleTypeSpecifier_BasicType (Double', _)) = True 478 compatible x@(SimpleTypeSpecifier_BasicType _) y@(LengthSpec _) = compatible y x 479 compatible (SignSpec _) (SimpleTypeSpecifier_BasicType (Int', _)) = True 480 compatible (SimpleTypeSpecifier_BasicType (Int', _)) (SignSpec _) = True 481 compatible _ _ = False 482 483instance Compatible TrailingTypeSpecifier TrailingTypeSpecifier where 484 compatible (TrailingTypeSpecifier_CvQualifier (cv, _)) (TrailingTypeSpecifier_CvQualifier (cv', _)) = compatible cv cv' 485 compatible (TrailingTypeSpecifier_CvQualifier _) _ = True 486 compatible _ (TrailingTypeSpecifier_CvQualifier _) = True 487 compatible (TrailingTypeSpecifier_SimpleTypeSpecifier x) (TrailingTypeSpecifier_SimpleTypeSpecifier y) = compatible x y 488 compatible _ _ = False 489 490instance Compatible TypeSpecifier TypeSpecifier where 491 compatible (TypeSpecifier_TrailingTypeSpecifier x) (TypeSpecifier_TrailingTypeSpecifier y) = compatible x y 492 compatible _ _ = False 493 494instance Compatible MakeSpecifier MakeSpecifier where 495 compatible (MakeSpecifier_DeclSpecifier d) (MakeSpecifier_DeclSpecifier d') = compatible d d' 496 compatible x@(MakeSpecifier_DeclSpecifier _) y = compatible y x 497 compatible (NonStorageClassSpecifier scs) (MakeSpecifier_DeclSpecifier (DeclSpecifier_StorageClassSpecifier (scs', _))) = scs ≠ scs' 498 compatible _ _ = True 499 500instance Compatible DeclSpecifier DeclSpecifier where 501 compatible (DeclSpecifier_TypeSpecifier x) (DeclSpecifier_TypeSpecifier y) = compatible x y 502 compatible (DeclSpecifier_StorageClassSpecifier _) (DeclSpecifier_StorageClassSpecifier _) = False 503 compatible (DeclSpecifier_FunctionSpecifier (s, _)) (DeclSpecifier_FunctionSpecifier (s', _)) | s == s' = False 504 compatible (DeclSpecifier_Typedef _) (DeclSpecifier_Typedef _) = False 505 compatible (DeclSpecifier_ConstExpr _) (DeclSpecifier_ConstExpr _) = False 506 compatible (DeclSpecifier_AlignmentSpecifier _) (DeclSpecifier_AlignmentSpecifier _) = False 507 compatible (DeclSpecifier_FunctionSpecifier (Virtual, _)) (DeclSpecifier_StorageClassSpecifier (Static, _)) = False 508 compatible (DeclSpecifier_StorageClassSpecifier (Static, _)) (DeclSpecifier_FunctionSpecifier (Virtual, _)) = False 509 compatible _ _ = True 510 511-- Making sure things end with whitespace. 512 513data WithAlternate a = WithoutAlternate a | WithAlternate { _wa_primary :: a, _wa_alternate :: a } deriving Typeable 514 515instance Functor WithAlternate where 516 fmap f (WithoutAlternate x) = WithoutAlternate $ f x 517 fmap f (WithAlternate x y) = WithAlternate (f x) (f y) 518 519with_trailing_white :: Data d ⇒ d → d 520with_trailing_white = \x → case f x of WithoutAlternate y → y; WithAlternate _ y → y 521 where 522 f :: Data d ⇒ d → WithAlternate d 523 f | Just h ← cast (\w@(White s) → WithAlternate w (White $ if null s then " " else s)) = h 524 | otherwise = gfoldl (\e d → case e of 525 (WithAlternate h i) → case f d of 526 WithoutAlternate x → WithAlternate (h x) (i x) 527 WithAlternate x y → WithAlternate (h x) (h y) 528 (WithoutAlternate h) → h . f d) WithoutAlternate 529 530-- Specifier/qualifier conversion 531 532instance Convert TrailingTypeSpecifier TypeSpecifier where convert = TypeSpecifier_TrailingTypeSpecifier 533instance Convert (BasicType, White) TypeSpecifier where convert = convert . TrailingTypeSpecifier_SimpleTypeSpecifier . SimpleTypeSpecifier_BasicType 534instance Convert (BasicType, White) DeclSpecifier where convert = (convert :: TypeSpecifier → DeclSpecifier) . convert 535instance Convert CvQualifier TrailingTypeSpecifier where convert cvq = TrailingTypeSpecifier_CvQualifier (cvq, White " ") 536instance Convert CvQualifier TypeSpecifier where convert = convert . (convert :: CvQualifier → TrailingTypeSpecifier) 537instance Convert CvQualifier DeclSpecifier where convert = convert . (convert :: CvQualifier → TypeSpecifier) 538instance Convert CvQualifier MakeSpecifier where convert = convert . (convert :: TypeSpecifier → DeclSpecifier) . convert 539instance Convert SimpleTypeSpecifier (Maybe Sign) where convert (SignSpec (s, _)) = Just s; convert _ = Nothing 540instance Convert SimpleTypeSpecifier (Maybe LengthSpec) where convert (LengthSpec (s, _)) = Just s; convert _ = Nothing 541instance Convert SimpleTypeSpecifier TypeSpecifier where convert = convert . TrailingTypeSpecifier_SimpleTypeSpecifier 542instance Convert TypeSpecifier DeclSpecifier where convert = DeclSpecifier_TypeSpecifier 543instance Convert TypeSpecifier (Maybe Sign) where convert x = convert x >>= (convert :: SimpleTypeSpecifier → Maybe Sign) 544instance Convert TypeSpecifier (Maybe SimpleTypeSpecifier) where convert (TypeSpecifier_TrailingTypeSpecifier (TrailingTypeSpecifier_SimpleTypeSpecifier s)) = Just s; convert _ = Nothing 545instance Convert TypeSpecifier (Maybe LengthSpec) where convert x = convert x >>= (convert :: SimpleTypeSpecifier → Maybe LengthSpec) 546instance Convert TypeSpecifier (Maybe (CvQualifier, White)) where convert (TypeSpecifier_TrailingTypeSpecifier (TrailingTypeSpecifier_CvQualifier cvq)) = Just cvq; convert _ = Nothing 547instance Convert TypeSpecifier (Maybe CvQualifier) where convert x = fst . (convert x :: Maybe (CvQualifier, White)) 548instance Convert DeclSpecifier (Maybe TypeSpecifier) where convert (DeclSpecifier_TypeSpecifier s) = Just s; convert _ = Nothing 549instance Convert DeclSpecifier (Maybe StorageClassSpecifier) where convert (DeclSpecifier_StorageClassSpecifier (s, _)) = Just s; convert _ = Nothing 550instance Convert DeclSpecifier (Maybe FunctionSpecifier) where convert (DeclSpecifier_FunctionSpecifier (s, _)) = Just s; convert _ = Nothing 551instance Convert DeclSpecifier MakeSpecifier where convert = MakeSpecifier_DeclSpecifier 552instance Convert DeclSpecifier (Maybe Sign) where convert x = convert x >>= (convert :: TypeSpecifier → Maybe Sign) 553instance Convert DeclSpecifier (Maybe LengthSpec) where convert x = convert x >>= (convert :: TypeSpecifier → Maybe LengthSpec) 554instance Convert DeclSpecifier (Maybe (CvQualifier, White)) where convert (DeclSpecifier_TypeSpecifier t) = convert t; convert _ = Nothing 555instance Convert DeclSpecifier (Maybe CvQualifier) where convert x = fst . (convert x :: Maybe (CvQualifier, White)) 556instance Convert MakeSpecifier (Maybe (CvQualifier, White)) where convert (MakeSpecifier_DeclSpecifier t) = convert t; convert _ = Nothing 557instance Convert LengthSpec SimpleTypeSpecifier where convert x = LengthSpec (x, White " ") 558instance Convert LengthSpec TypeSpecifier where convert = convert . (convert :: LengthSpec → SimpleTypeSpecifier) 559instance Convert LengthSpec DeclSpecifier where convert = convert . (convert :: LengthSpec → TypeSpecifier) 560instance Convert LengthSpec MakeSpecifier where convert = convert . (convert :: LengthSpec → DeclSpecifier) 561 562-- Misc conversions 563 564instance Convert PtrDeclarator Declarator where convert = Declarator_PtrDeclarator 565instance Convert NoptrDeclarator PtrDeclarator where convert = PtrDeclarator_NoptrDeclarator 566instance Convert NoptrDeclarator Declarator where convert = convert . (convert :: NoptrDeclarator → PtrDeclarator) 567instance Convert NoptrDeclarator InitDeclarator where convert = flip InitDeclarator Nothing . convert 568 569instance Convert DeclaratorId (Maybe ConversionFunctionId) where 570 convert (DeclaratorId_IdExpression Nothing (IdExpression e)) = 571 case e of 572 Left (NestedUnqualifiedId _ _ _ (UnqualifiedId_ConversionFunctionId i)) → Just i 573 Right (UnqualifiedId_ConversionFunctionId i) → Just i 574 _ → Nothing 575 convert _ = Nothing 576 577-- Declaration splitting 578 579class SplitDecls a where split_decls :: a → NeList a 580 581instance SplitDecls Declaration where 582 split_decls (Declaration_BlockDeclaration bd) = fmap Declaration_BlockDeclaration $ split_decls bd 583 split_decls d = return d 584 585instance SplitDecls BlockDeclaration where 586 split_decls (BlockDeclaration_SimpleDeclaration sd) = fmap BlockDeclaration_SimpleDeclaration $ split_decls sd 587 split_decls d = return d 588 589instance SplitDecls SimpleDeclaration where 590 split_decls d@(SimpleDeclaration _ Nothing _) = return d 591 split_decls (SimpleDeclaration specs (Just (InitDeclaratorList (Commad x l))) w) = 592 (\y → SimpleDeclaration specs (Just (InitDeclaratorList (Commad y []))) w) . (x :| (snd . l)) 593 594instance SplitDecls Statement where 595 split_decls (Statement_DeclarationStatement (DeclarationStatement d)) = 596 Statement_DeclarationStatement . DeclarationStatement . split_decls d 597 split_decls (Statement_CompoundStatement (CompoundStatement (Curlied x (Enclosed (Just (StatementSeq l))) y))) = 598 return (Statement_CompoundStatement $ CompoundStatement $ Curlied x (Enclosed $ Just $ StatementSeq $ l >>= split_decls) y) 599 split_decls (Statement_SelectionStatement (IfStatement k c s Nothing)) = 600 return (Statement_SelectionStatement $ IfStatement k c (compound_split_decls s) Nothing) -- todo: do else part as well 601 -- todo: do while and do-loops as well. 602 split_decls s = return $ gmapT split_all_decls s 603 604instance SplitDecls MemberDeclaration where 605 split_decls (MemberDeclaration specs (Just (MemberDeclaratorList (Commad d ds))) s) = 606 (\d' → MemberDeclaration specs (Just (MemberDeclaratorList (Commad d' []))) s) . (d :| (snd . ds)) 607 split_decls d = return $ gmapT split_all_decls d 608 609compound_split_decls :: Statement → Statement 610compound_split_decls s 611 | null (NeList.tail l) = NeList.head l 612 | otherwise = Statement_CompoundStatement $ CompoundStatement $ Curlied (OpenCurly_, White "") (Enclosed $ Just $ StatementSeq l) (CloseCurly_, White "") 613 where l = split_decls s 614 615split_all_decls :: Data a ⇒ a → a 616split_all_decls = everywhere $ Maybe.fromMaybe id $ Maybe.listToMaybe . Maybe.catMaybes $ 617 [ cast ((>>= split_decls) :: NeList Declaration → NeList Declaration) 618 , cast ((>>= split_decls) :: NeList Statement → NeList Statement) 619 , cast (compound_split_decls :: Statement → Statement) 620 , cast (concatMap (either (map Left . toList . split_decls) ((:[]) . Right)) :: [Either MemberDeclaration MemberAccessSpecifier] → [Either MemberDeclaration MemberAccessSpecifier]) 621 ] 622 623-- Qualifier/specifier classification 624 625is_primary_TrailingTypeSpecifier :: TrailingTypeSpecifier → Bool 626is_primary_TrailingTypeSpecifier (TrailingTypeSpecifier_CvQualifier _) = False 627is_primary_TrailingTypeSpecifier _ = True 628 629is_primary_TypeSpecifier :: TypeSpecifier → Bool 630is_primary_TypeSpecifier (TypeSpecifier_TrailingTypeSpecifier t) = is_primary_TrailingTypeSpecifier t 631is_primary_TypeSpecifier _ = True 632 633is_primary_DeclSpecifier :: DeclSpecifier → Bool 634is_primary_DeclSpecifier (DeclSpecifier_TypeSpecifier t) = is_primary_TypeSpecifier t 635is_primary_DeclSpecifier _ = False 636 637is_primary_MakeSpecifier :: MakeSpecifier → Bool 638is_primary_MakeSpecifier (MakeSpecifier_DeclSpecifier t) = is_primary_DeclSpecifier t 639is_primary_MakeSpecifier _ = False 640 641instance Apply a b b ⇒ Apply [a] b b where apply = flip $ foldl $ flip apply 642instance Apply a b c ⇒ Apply a (Enclosed b) (Enclosed c) where apply x (Enclosed y) = Enclosed $ apply x y 643instance MaybeApply a b ⇒ MaybeApply a (Enclosed b) where mapply x (Enclosed y) = Enclosed . mapply x y 644 645-- Id application 646 647instance Apply DeclaratorId PtrAbstractDeclarator PtrDeclarator where 648 apply i (PtrAbstractDeclarator_NoptrAbstractDeclarator npad) = PtrDeclarator_NoptrDeclarator $ apply i npad 649 apply i (PtrAbstractDeclarator o Nothing) = PtrDeclarator (with_trailing_white o) $ PtrDeclarator_NoptrDeclarator $ NoptrDeclarator_Id i 650 apply i (PtrAbstractDeclarator o (Just pad)) = let pd = apply i pad in PtrDeclarator (case Cxx.Show.show_simple pd of 651 (h:_) | not (isIdChar h) → o; _ → with_trailing_white o) pd 652 653instance Apply DeclaratorId NoptrAbstractDeclarator NoptrDeclarator where 654 apply i (NoptrAbstractDeclarator Nothing (Right s)) = NoptrDeclarator_Squared (NoptrDeclarator_Id i) s 655 apply i (NoptrAbstractDeclarator (Just npad) (Right s)) = NoptrDeclarator_Squared (apply i npad) s 656 apply i (NoptrAbstractDeclarator Nothing (Left params)) = NoptrDeclarator_WithParams (NoptrDeclarator_Id i) params 657 apply i (NoptrAbstractDeclarator (Just npad) (Left params)) = NoptrDeclarator_WithParams (apply i npad) params 658 apply i (NoptrAbstractDeclarator_PtrAbstractDeclarator (Parenthesized w (Enclosed pad) w')) = 659 NoptrDeclarator_Parenthesized $ Parenthesized w (Enclosed $ apply i pad) w' 660 661-- TypeSpecifier application 662 663-- Here and elsewhere, we always keep specifiers in the order they appeared in the source text as much as possible. 664 665instance Apply TypeSpecifier (NeList TypeSpecifier) (NeList TypeSpecifier) where 666 apply d = (with_trailing_white d :|) . filter (compatible d) . toList 667 668-- DeclSpecifier application 669 670instance Apply DeclSpecifier [DeclSpecifier] [DeclSpecifier] where 671 apply d = (with_trailing_white d :) . filter (compatible d) 672 673instance Apply DeclSpecifier (NeList DeclSpecifier) (NeList DeclSpecifier) where 674 apply d = (with_trailing_white d :|) . filter (compatible d) . toList 675 676instance Apply [DeclSpecifier] (NeList DeclSpecifier) (NeList DeclSpecifier) where 677 apply [] l = l 678 apply l@(h:t) x = h :| (with_trailing_white t ++ filter (\s → all (compatible s) l) (toList x)) 679 680instance MaybeApply DeclSpecifier (NeList TypeSpecifier) where 681 mapply (DeclSpecifier_TypeSpecifier x) typespecs = return $ apply x typespecs 682 mapply x _ = throwError $ "Invalid decl-specifier for type-specifier-seq: " ++ Cxx.Show.show_simple x 683 684instance MaybeApply [DeclSpecifier] (NeList TypeSpecifier) where 685 mapply = flip $ foldM $ flip mapply 686 687-- MakeSpecifier application 688 689type M = ([MakeSpecifier], Maybe PtrAbstractDeclarator) 690 691instance MaybeApply M (DeclSpecifierSeq, Either Declarator (Maybe AbstractDeclarator)) where 692 mapply x (l, Left d) | (l', d') ← apply x (l, d) = return (l', Left d') 693 mapply x (DeclSpecifierSeq l, Right Nothing) = return $ 694 first DeclSpecifierSeq $ second (Right . (AbstractDeclarator_PtrAbstractDeclarator .)) $ 695 apply x (l, Nothing :: Maybe PtrAbstractDeclarator) 696 mapply x (DeclSpecifierSeq l, Right (Just (AbstractDeclarator_PtrAbstractDeclarator d))) = return $ 697 first DeclSpecifierSeq $ second (Right . (AbstractDeclarator_PtrAbstractDeclarator .)) $ apply x (l, Just d) 698 mapply _ (_, Right (Just (AbstractDeclarator_Ellipsis _))) = throwError "Sorry, make-application to abstract-declarator with ellipsis not yet implemented." 699 700instance MaybeApply M (TypeSpecifierSeq, Declarator) where 701 mapply x (l, Declarator_PtrDeclarator d) = second Declarator_PtrDeclarator . mapply x (l, d) 702 mapply _ _ = throwError "Sorry, not yet implemented." 703 704instance Apply M (Maybe DeclSpecifierSeq, Declarator) (Maybe DeclSpecifierSeq, Declarator) where 705 apply x (y, Declarator_PtrDeclarator d) = second Declarator_PtrDeclarator $ apply x (y, d) 706 apply _ y = y -- Sorry, not yet implemented. 707 708instance Apply M (NeList DeclSpecifier, Declarator) (NeList DeclSpecifier, Declarator) where 709 apply x (l, Declarator_PtrDeclarator d) = second Declarator_PtrDeclarator $ apply x (l, d) 710 apply _ y = y -- Sorry, not yet implemented. 711 712instance Apply M (DeclSpecifierSeq, Declarator) (DeclSpecifierSeq, Declarator) where 713 apply x (DeclSpecifierSeq l, d)= first DeclSpecifierSeq $ apply x (l, d) 714 715instance Apply M (Maybe DeclSpecifierSeq, PtrDeclarator) (Maybe DeclSpecifierSeq, PtrDeclarator) where 716 apply x (m, d) = first convert $ apply x (convert m :: [DeclSpecifier], d) 717 718instance (Apply [MakeSpecifier] (l DeclSpecifier) (l DeclSpecifier), Apply MakeSpecifier (l DeclSpecifier, PtrDeclarator) (l DeclSpecifier, PtrDeclarator)) ⇒ Apply M (l DeclSpecifier, PtrDeclarator) (l DeclSpecifier, PtrDeclarator) where 719 apply (l, Nothing) (l', x) = 720 if any is_primary_MakeSpecifier l 721 then (apply l l', PtrDeclarator_NoptrDeclarator $ NoptrDeclarator_Id $ convert x) 722 else foldl (flip apply) (l', x) l 723 apply (l, Just pad) (l', x) = (apply l l', apply (convert x :: DeclaratorId) pad) 724 725instance Apply M (NeList DeclSpecifier, Maybe PtrAbstractDeclarator) (NeList DeclSpecifier, Maybe PtrAbstractDeclarator) where 726 apply (l, Nothing) (l', Just x) = 727 if any is_primary_MakeSpecifier l 728 then (apply l l', Just x) 729 else second Just $ foldl (flip apply) (l', x) l 730 apply (l, m) (l', Nothing) = (apply l l', m) 731 apply (l, Just x) (l', _) = (apply l l', Just x) 732 733instance MaybeApply M (TypeSpecifierSeq, PtrDeclarator) where 734 mapply (l, Nothing) (l', x) = 735 if any is_primary_MakeSpecifier l 736 then flip (,) (PtrDeclarator_NoptrDeclarator $ NoptrDeclarator_Id $ convert x) . mapply l l' 737 else foldM (flip mapply) (l', x) l 738 mapply (l, Just pad) (l', x) = flip (,) (apply (convert x :: DeclaratorId) pad) . mapply l l' 739 740instance MaybeApply [MakeSpecifier] TypeSpecifierSeq where mapply l l' = foldM (flip mapply) l' l 741 742instance Apply MakeSpecifier ([DeclSpecifier], PtrDeclarator) ([DeclSpecifier], PtrDeclarator) where 743 apply s (x, y) = maybe (apply s x, y) ((,) x) (mapply s y) 744 745instance Apply MakeSpecifier (NeList DeclSpecifier, PtrAbstractDeclarator) (NeList DeclSpecifier, PtrAbstractDeclarator) where 746 apply s (x, y) = maybe (apply s x, y) ((,) x) (mapply s y) 747 748instance MaybeApply MakeSpecifier (TypeSpecifierSeq, PtrDeclarator) where 749 mapply s (x, y) = maybe (flip (,) y . mapply s x) (return . (,) x) (mapply s y) 750 751instance MaybeApply MakeSpecifier PtrDeclarator where 752 mapply s (PtrDeclarator_NoptrDeclarator d) = PtrDeclarator_NoptrDeclarator . mapply s d 753 mapply s (PtrDeclarator o d) = maybe (flip PtrDeclarator d . mapply s o) (return . PtrDeclarator o) (mapply s d) 754 755instance MaybeApply MakeSpecifier PtrAbstractDeclarator where 756 mapply s (PtrAbstractDeclarator_NoptrAbstractDeclarator d) = 757 PtrAbstractDeclarator_NoptrAbstractDeclarator . mapply s d 758 mapply _ _ = throwError "Sorry, not yet implemented." 759 760instance MaybeApply MakeSpecifier PtrOperator where 761 mapply s (PtrOperator_Ptr o cvs) = PtrOperator_Ptr o . mapply s cvs 762 mapply s (PtrOperator_Nested x y z cvs) = PtrOperator_Nested x y z . mapply s cvs 763 mapply _ (PtrOperator_Ref _) = throwError "Cannot apply make-specifier to reference ptr-operator." 764 765eraseCv :: CvQualifier → Maybe CvQualifierSeq → Maybe CvQualifierSeq 766eraseCv _ Nothing = Nothing 767eraseCv q (Just (CvQualifierSeq l)) = CvQualifierSeq . nonEmpty (neFilter ((≠ q) . fst) l) 768 769instance MaybeApply MakeSpecifier (Maybe CvQualifierSeq) where 770 mapply (MakeSpecifier_DeclSpecifier (DeclSpecifier_TypeSpecifier (TypeSpecifier_TrailingTypeSpecifier (TrailingTypeSpecifier_CvQualifier (cvq, _))))) = 771 return . apply cvq 772 mapply (NonCv cvq) = return . eraseCv cvq 773 mapply _ = const $ throwError "Cannot apply non-cv make-specifier to cv-qualifier-seq." 774 775instance MaybeApply MakeSpecifier NoptrAbstractDeclarator where 776 mapply s (NoptrAbstractDeclarator_PtrAbstractDeclarator (Parenthesized w (Enclosed d) w')) = do 777 d' ← mapply s d 778 return (NoptrAbstractDeclarator_PtrAbstractDeclarator (Parenthesized w (Enclosed d') w')) 779 mapply _ _ = throwError "Sorry, not yet implemented." 780 781instance MaybeApply MakeSpecifier NoptrDeclarator where 782 mapply _ (NoptrDeclarator_Id _) = throwError "Cannot apply make-specifier to declarator-id." 783 mapply s (NoptrDeclarator_Parenthesized (Parenthesized w (Enclosed d) w')) = do 784 d' ← mapply s d 785 return (NoptrDeclarator_Parenthesized (Parenthesized w (Enclosed d') w')) 786 mapply s (NoptrDeclarator_Squared d ce) = do 787 d' ← mapply s d 788 return $ NoptrDeclarator_Squared d' ce 789 mapply s (NoptrDeclarator_WithParams d p) = 790 case mapply s d of 791 Just d' → return $ NoptrDeclarator_WithParams d' p 792 Nothing → NoptrDeclarator_WithParams d . mapply s p 793 794instance MaybeApply MakeSpecifier ParametersAndQualifiers where 795 mapply (MakeSpecifier_DeclSpecifier (DeclSpecifier_TypeSpecifier (TypeSpecifier_TrailingTypeSpecifier (TrailingTypeSpecifier_CvQualifier (cvq, _))))) (ParametersAndQualifiers c cvqs m e) = 796 return $ ParametersAndQualifiers c (apply cvq cvqs) m e 797 mapply (NonCv cvq) (ParametersAndQualifiers c cvqs m e) = 798 return $ ParametersAndQualifiers c (eraseCv cvq cvqs) m e 799 mapply _ _ = throwError "Cannot apply non-cv make-specifier to parameters-and-qualifiers (yet)." 800 801instance Apply MakeSpecifier (NeList DeclSpecifier, PtrDeclarator) (NeList DeclSpecifier, PtrDeclarator) where 802 apply s (x, y) = maybe (apply s x, y) ((,) x) (mapply s y) 803 804nonIntSpec :: (Eq s, Eq t, Convert t (Maybe s), Convert (BasicType, White) t) ⇒ s → NeList t → NeList t 805nonIntSpec s l = case neFilter ((≠ Just s) . convert) l of 806 l'@(h:t) | (convert (Int', White "") ∈ l') ∨ (convert (Double', White "") ∈ l') → h :| t 807 l' → convert (Int', White " ") :| l' 808 809instance MaybeApply MakeSpecifier (NeList TypeSpecifier) where 810 mapply (MakeSpecifier_DeclSpecifier s) = mapply s 811 mapply (NonStorageClassSpecifier _) = return 812 mapply (NonFunctionSpecifier _) = return 813 mapply (NonCv cvq) = return . filter_but_keep_nonempty ((≠ Just cvq) . convert) 814 mapply (NonSign s) = return . nonIntSpec s 815 mapply (NonLength s) = return . nonIntSpec s 816 mapply LongLong = return . (convert LongSpec :|) . (convert LongSpec :) . filter (compatible (convert LongSpec :: TypeSpecifier)) . toList 817 818instance MaybeApply MakeSpecifier TypeSpecifierSeq where 819 mapply s (TypeSpecifierSeq l) = TypeSpecifierSeq . mapply s l 820 821-- decl-specifier-seqs (which are always nonempty) always contain at least one primary specifier. Hence, removing, say, all cv-qualifiers, will always produce a prop…
Large files files are truncated, but you can click here to view the full file