/src/Cxx/Operations.hs

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…