@@ -254,6 +254,8 @@ Reserved Ids
254254> 'qualified' { Loc $$ KW_Qualified }
255255> 'role' { Loc $$ KW_Role }
256256> 'pattern' { Loc $$ KW_Pattern }
257+ > 'stock' { Loc $$ KW_Stock } -- for DerivingStrategies extension
258+ > 'anyclass' { Loc $$ KW_Anyclass } -- for DerivingStrategies extension
257259
258260Pragmas
259261
@@ -586,22 +588,23 @@ Here there is no special keyword so we must do the check.
586588> checkEnabled TypeFamilies ;
587589> let {l = nIS $1 <++> ann $5 <** [$1 ,$2 ,$4 ]};
588590> return (TypeInsDecl l $3 $5 ) } }
589- > | data_or_newtype ctype constrs0 deriving
591+ > | data_or_newtype ctype constrs0 maybe_derivings
590592> {% do { (cs,dh) <- checkDataHeader $2 ;
591593> let { (qds,ss,minf) = $3 ;
592- > l = $1 <> $2 <+?> minf <+?> fmap ann $ 4 <** ss};
594+ > l = $1 <> $2 <+?> minf <+?> fmap ann (listToMaybe $ 4 ) <** ss};
593595> checkDataOrNew $1 qds;
594- > return (DataDecl l $1 cs dh (reverse qds) $ 4 ) } }
596+ > return (DataDecl l $1 cs dh (reverse qds) (reverse $ 4 ) ) } }
595597
596598Requires the GADTs extension enabled, handled in gadtlist.
597- > | data_or_newtype ctype optkind gadtlist deriving
599+ > | data_or_newtype ctype optkind gadtlist maybe_derivings
598600> {% do { (cs,dh) <- checkDataHeader $2 ;
599601> let { (gs,ss,minf) = $4 ;
600- > l = ann $1 <+?> minf <+?> fmap ann $5 <** (snd $3 ++ ss)};
602+ > derivs' = reverse $5 ;
603+ > l = ann $1 <+?> minf <+?> fmap ann (listToMaybe $5 ) <** (snd $3 ++ ss)};
601604> checkDataOrNewG $1 gs;
602605> case (gs, fst $3 ) of
603- > ([], Nothing) -> return (DataDecl l $1 cs dh [] $ 5 )
604- > _ -> checkEnabled GADTs >> return (GDataDecl l $1 cs dh (fst $3 ) (reverse gs) $ 5 ) } }
606+ > ([], Nothing) -> return (DataDecl l $1 cs dh [] derivs' )
607+ > _ -> checkEnabled GADTs >> return (GDataDecl l $1 cs dh (fst $3 ) (reverse gs) derivs' ) } }
605608
606609Same as above, lexer will handle it through the 'family' keyword.
607610> | 'data' 'family' ctype opt_datafam_kind_sig
@@ -610,22 +613,23 @@ Same as above, lexer will handle it through the 'family' keyword.
610613> return (DataFamDecl l cs dh $4 ) } }
611614
612615Here we must check for TypeFamilies.
613- > | data_or_newtype 'instance' truectype constrs0 deriving
616+ > | data_or_newtype 'instance' truectype constrs0 maybe_derivings
614617> {% do { -- (cs,c,t ) <- checkDataHeader $4 ;
615618> checkEnabled TypeFamilies ;
616619> let { (qds,ss,minf) = $4 ;
617- > l = $1 <> $3 <+?> minf <+?> fmap ann $ 5 <** $2 :ss };
620+ > l = $1 <> $3 <+?> minf <+?> fmap ann (listToMaybe $ 5 ) <** $2 :ss };
618621> checkDataOrNew $1 qds;
619- > return (DataInsDecl l $1 $3 (reverse qds) $ 5 ) } }
622+ > return (DataInsDecl l $1 $3 (reverse qds) (reverse $ 5 ) ) } }
620623
621624This style requires both TypeFamilies and GADTs, the latter is handled in gadtlist.
622- > | data_or_newtype 'instance' truectype optkind gadtlist deriving
625+ > | data_or_newtype 'instance' truectype optkind gadtlist maybe_derivings
623626> {% do { -- (cs,c,t ) <- checkDataHeader $4 ;
624627> checkEnabled TypeFamilies ;
625628> let {(gs,ss,minf) = $5 ;
626- > l = ann $1 <+?> minf <+?> fmap ann $6 <** ($2 :snd $4 ++ ss)};
629+ > derivs' = reverse $6 ;
630+ > l = ann $1 <+?> minf <+?> fmap ann (listToMaybe derivs') <** ($2 :snd $4 ++ ss)};
627631> checkDataOrNewG $1 gs;
628- > return (GDataInsDecl l $1 $3 (fst $4 ) (reverse gs) $ 6 ) } }
632+ > return (GDataInsDecl l $1 $3 (fst $4 ) (reverse gs) derivs' ) } }
629633> | 'class' ctype fds optcbody
630634> {% do { (cs,dh) <- checkClassHeader $2 ;
631635> let {(fds,ss1,minf1) = $3 ; (mcs,ss2,minf2) = $4} ;
@@ -637,11 +641,11 @@ This style requires both TypeFamilies and GADTs, the latter is handled in gadtli
637641> return (InstDecl (nIS $1 <++> ann $3 <+?> minf <** ($1 :ss)) $2 ih mis) } }
638642
639643Requires the StandaloneDeriving extension enabled.
640- > | 'deriving' 'instance' optoverlap ctype
644+ > | 'deriving' deriv_strategy 'instance' optoverlap ctype
641645> {% do { checkEnabled StandaloneDeriving ;
642- > ih <- checkInstHeader $4 ;
643- > let {l = nIS $1 <++> ann $4 <** [$1 ,$2 ]};
644- > return (DerivDecl l $3 ih) } }
646+ > ih <- checkInstHeader $5 ;
647+ > let {l = nIS $1 <++> ann $5 <** [$1 ,$3 ]};
648+ > return (DerivDecl l $2 $ 4 ih) } }
645649> | 'default' '(' typelist ')'
646650> { DefaultDecl ($1 <^^> $4 <** ($1 :$2 : snd $3 ++ [$4 ])) (fst $3 ) }
647651
@@ -1165,14 +1169,24 @@ as qcon and then check separately that they are truly unqualified.
11651169> fielddecl :: { FieldDecl L }
11661170> : vars '::' truectype { let (ns,ss,l) = $1 in FieldDecl (l <++> ann $3 <** (reverse ss ++ [$2 ])) (reverse ns) $3 }
11671171
1168- > deriving :: { Maybe (Deriving L) }
1169- > : {- empty -} { Nothing }
1170- > | 'deriving' qtycls1 { let l = nIS $1 <++> ann $2 <** [$1 ] in Just $ Deriving l [IRule (ann $2 ) Nothing Nothing $2 ] }
1171- > | 'deriving' '(' ')' { Just $ Deriving ($1 <^^> $3 <** [$1 ,$2 ,$3 ]) [] }
1172- > | 'deriving' '(' dclasses ')' { -- Distinguish deriving (Show) from deriving Show (#189 )
1173- > case fst $3 of
1174- > [ts] -> Just $ Deriving ($1 <^^> $4 <** [$1 ]) [IParen ($2 <^^> $4 <** [$2 ,$4 ]) ts]
1175- > tss -> Just $ Deriving ($1 <^^> $4 <** $1 :$2 : reverse (snd $3 ) ++ [$4 ]) (reverse tss)}
1172+ > maybe_derivings :: { [Deriving L] }
1173+ > : {- empty -} { [] }
1174+ > | derivings { $1 }
1175+
1176+ > derivings :: { [Deriving L] }
1177+ > : derivings deriving { $2 : $1 }
1178+ > | deriving { [$1 ] }
1179+
1180+ > deriving :: { Deriving L }
1181+ > : 'deriving' deriv_strategy qtycls1
1182+ > { let l = nIS $1 <++> ann $3 <** [$1 ] in Deriving l $2 [IRule (ann $3 ) Nothing Nothing $3 ] }
1183+ > | 'deriving' deriv_strategy '(' ')'
1184+ > { Deriving ($1 <^^> $4 <** [$1 ,$3 ,$4 ]) $2 [] }
1185+ > | 'deriving' deriv_strategy '(' dclasses ')'
1186+ > { -- Distinguish deriving (Show) from deriving Show (#189 )
1187+ > case fst $4 of
1188+ > [ts] -> Deriving ($1 <^^> $5 <** [$1 ]) $2 [IParen ($3 <^^> $5 <** [$3 ,$5 ]) ts]
1189+ > tss -> Deriving ($1 <^^> $5 <** $1 :$3 : reverse (snd $4 ) ++ [$5 ]) $2 (reverse tss)}
11761190
11771191> dclasses :: { ([InstRule L],[S]) }
11781192> : types1 {% checkDeriving (fst $1 ) >>= \ds -> return (ds, snd $1 ) }
@@ -1299,16 +1313,16 @@ Associated types require the TypeFamilies extension enabled.
12991313> : 'type' truedtype '=' truectype
13001314> {% do { -- no checkSimpleType $4 since dtype may contain type patterns
13011315> return (InsType (nIS $1 <++> ann $4 <** [$1 ,$3 ]) $2 $4 ) } }
1302- > | data_or_newtype truectype constrs0 deriving
1316+ > | data_or_newtype truectype constrs0 maybe_derivings
13031317> {% do { -- (cs,c,t ) <- checkDataHeader $4 ;
13041318> let {(ds,ss,minf) = $3 };
13051319> checkDataOrNew $1 ds;
1306- > return (InsData ($1 <> $2 <+?> minf <+?> fmap ann $ 4 <** ss ) $1 $2 (reverse ds) $ 4 ) } }
1307- > | data_or_newtype truectype optkind gadtlist deriving
1320+ > return (InsData ($1 <> $2 <+?> minf <+?> fmap ann (listToMaybe $ 4 ) <** ss ) $1 $2 (reverse ds) (reverse $ 4 ) ) } }
1321+ > | data_or_newtype truectype optkind gadtlist maybe_derivings
13081322> {% do { -- (cs,c,t ) <- checkDataHeader $4 ;
13091323> let { (gs,ss,minf) = $4 } ;
13101324> checkDataOrNewG $1 gs;
1311- > return $ InsGData (ann $1 <+?> minf <+?> fmap ann $ 5 <** (snd $3 ++ ss)) $1 $2 (fst $3 ) (reverse gs) $ 5 } }
1325+ > return $ InsGData (ann $1 <+?> minf <+?> fmap ann (listToMaybe $ 5 ) <** (snd $3 ++ ss)) $1 $2 (fst $3 ) (reverse gs) (reverse $ 5 ) } }
13121326
13131327-----------------------------------------------------------------------------
13141328Value definitions
@@ -1956,6 +1970,8 @@ Identifiers and Symbols
19561970> | 'js' { js_name ( nIS $ 1 ) }
19571971> | 'javascript' { javascript_name ( nIS $ 1 ) }
19581972> | 'capi' { capi_name ( nIS $ 1 ) }
1973+ > | 'stock' { stock_name ( nIS $ 1 ) }
1974+ > | 'anyclass' { anyclass_name ( nIS $ 1 ) }
19591975
19601976> varid :: { Name L }
19611977> : varid_no_safety { $ 1 }
@@ -2097,6 +2113,20 @@ Pattern Synonyms
20972113> | type
20982114> {% checkType $1 >>= \t -> return (Nothing, [], Nothing, Nothing, t) }
20992115
2116+ -----------------------------------------------------------------------------
2117+ Deriving strategies
2118+
2119+ > deriv_strategy :: { Maybe ( DerivStrategy L) }
2120+ > : 'stock' {% do { checkEnabled DerivingStrategies
2121+ > ; return ( Just ( DerivStock ( nIS $ 1 ))) } }
2122+ > | 'anyclass' {% do { checkEnabled DerivingStrategies
2123+ > ; checkEnabled DeriveAnyClass
2124+ > ; return ( Just ( DerivAnyclass ( nIS $ 1 ))) } }
2125+ > | 'newtype' {% do { checkEnabled DerivingStrategies
2126+ > ; checkEnabled GeneralizedNewtypeDeriving
2127+ > ; return ( Just ( DerivNewtype ( nIS $ 1 ))) } }
2128+ > | {- empty -} { Nothing }
2129+
21002130-----------------------------------------------------------------------------
21012131Miscellaneous ( mostly renamings)
21022132
0 commit comments