Skip to content

Commit ac16af8

Browse files
jkopanskijkopanski
committed
Dedicated deriving syntax representation
Since now there will be multiple deriving strategies there is a need to record that additional information in the syntax tree. Original deriving mechanism is called stock deriving (like in Haskell). There is no changes planned to the way this works. Follow up commits will add new deriving functions.
1 parent 6771423 commit ac16af8

8 files changed

Lines changed: 82 additions & 30 deletions

File tree

‎src/comp/CFreeVars.hs‎

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -560,10 +560,10 @@ getFTCDn (Cforeign { cforg_type = t } ) = getFQTyCons t
560560
getFTCDn (Ctype _ _ t) = getFTyCons t
561561
getFTCDn (Cdata { cd_internal_summands = summands,
562562
cd_derivings = derivings }) =
563-
S.unions (map f summands) `S.union` S.fromList (map typeclassId derivings)
563+
S.unions (map f summands) `S.union` mconcat (map getFTDer derivings)
564564
where f summand = getFTyCons (cis_arg_type summand)
565565
getFTCDn (Cstruct _ _ _ vs fields ds) =
566-
S.unions (map (getFQTyCons . cf_type) fields) `S.union` S.fromList (map typeclassId ds)
566+
S.unions (map (getFQTyCons . cf_type) fields) `S.union` mconcat (map getFTDer ds)
567567
getFTCDn (Cclass _ ps _ _ _ ats fields) =
568568
S.difference
569569
(S.unions (map getCPTyCons ps ++ map f fields))
@@ -579,6 +579,10 @@ getFTCDn (CItype i vs useposs) = S.empty
579579
getFTCDn (CIclass incoh ps i vs fds atfs useposs) =
580580
S.unions (map getCPTyCons ps) `S.union` S.fromList (map ca_name atfs)
581581

582+
getFTDer :: CDeriving -> S.Set Id
583+
getFTDer (CStock tcs) = S.fromList (map typeclassId tcs)
584+
getFTDer (CVia tc _) = S.singleton (typeclassId tc)
585+
582586
getVDefIds :: CDefn -> [Id]
583587
getVDefIds (CValueSign (CDef i _ _)) = [i]
584588
getVDefIds (CValueSign (CDefT i _ _ _)) = [i]

‎src/comp/CSyntax.hs‎

Lines changed: 20 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,7 @@ module CSyntax(
3333
CFields,
3434
CStmt(..),
3535
CStmts,
36+
CDeriving(..),
3637
IdK(..),
3738
CLiteral(..),
3839
CMStmt(..),
@@ -196,12 +197,11 @@ data CDefn
196197
cd_type_vars :: [Id],
197198
cd_original_summands :: COSummands,
198199
cd_internal_summands :: CSummands,
199-
cd_derivings :: [CTypeclass] }
200+
cd_derivings :: [CDeriving] }
200201
| Cstruct Bool StructSubType IdK [Id] CFields
201-
[CTypeclass]
202+
[CDeriving]
202203
-- Bool indicates the constrs are visible
203204
-- first [Id] are the names of this definition's argument type variables
204-
-- last [CTypeclass] are derived classes
205205
-- incoherent_matches superclasses name_with_kind variables fundeps assoc_dep_funs default_methods
206206
| Cclass (Maybe Bool) [CPred] IdK [Id] CFunDeps [CAssocDepFun] CFields
207207
| Cinstance CQType [CDefl]
@@ -255,6 +255,16 @@ instance NFData IdK where
255255
rnf (IdKind i k) = rnf2 i k
256256
rnf (IdPKind i pk) = rnf2 i pk
257257

258+
data CDeriving
259+
= CStock [CTypeclass]
260+
-- TODO: expr?
261+
| CVia CTypeclass Id
262+
deriving (Eq, Ord, Show)
263+
264+
instance NFData CDeriving where
265+
rnf (CStock tcs) = rnf tcs
266+
rnf (CVia tc target) = rnf2 tc target
267+
258268
type CFunDeps = [([Id],[Id])]
259269

260270
-- Expressions
@@ -1242,10 +1252,14 @@ pBlock _ n nl xs =
12421252
foldr1 ($+$) (map (\ x -> x <> if nl then t";" $+$ t"" else t";") (init xs) ++ [last xs])) $+$
12431253
t"}"
12441254

1245-
ppDer :: PDetail -> [CTypeclass] -> Doc
1246-
ppDer d [] = text ""
1247-
ppDer d is = text " deriving (" <> sepList (map (pPrint d 0) is) (text ",") <> text ")"
1255+
instance PPrint CDeriving where
1256+
pPrint d _ (CStock tcs) = case tcs of
1257+
[] -> t""
1258+
is -> t" deriving (" <> sepList (map (pPrint d 0) is) (t",") <> t")"
1259+
pPrint d _ (CVia tc tgt) = t" deriving " <> pPrint d 0 tc <> t" via " <> pPrint d 0 tgt
12481260

1261+
ppDer :: PDetail -> [CDeriving] -> Doc
1262+
ppDer d drvs = vcatList (map (pPrint d 0) drvs) empty
12491263

12501264
instance PPrint CExpr where
12511265
pPrint d p (CLam ei e) = ppQuant "\\ " d p ei e

‎src/comp/CVPrint.hs‎

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -438,9 +438,8 @@ pBlockNT _ n nl xs sep =
438438
(t (replicate n ' ') <>
439439
foldr1 ($+$) (map (\ x -> x <> if nl then sep $+$ empty else sep) xs))
440440

441-
ppDer :: PDetail -> [CTypeclass] -> Doc
442-
ppDer d [] = empty
443-
ppDer d is = text "deriving (" <> sepList (map (pvPrint d 0) is) (text ",") <> text ")"
441+
ppDer :: PDetail -> [CDeriving] -> Doc
442+
ppDer d drvs = vcatList (map (pPrint d 0) drvs) empty
444443

445444
--isTerminated (Caction _ _) = True
446445
--isTerminated (Cdo _ _) = True

‎src/comp/Deriving.hs‎

Lines changed: 10 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -95,8 +95,8 @@ doDer flags r packageid xs data_decl@(Cdata {}) =
9595
orig_sums = cd_original_summands data_decl
9696
int_sums = cd_internal_summands data_decl
9797
derivs = cd_derivings data_decl
98-
derivs' = addAutoDerivs flags r qual_name ty_vars derivs
99-
in Right [data_decl] : map (doDataDer r packageid xs qual_name ty_vars orig_sums int_sums) derivs'
98+
stockDerivs = addAutoDerivs flags r qual_name ty_vars (getStockDerivs derivs)
99+
in Right [data_decl] : map (doDataDer r packageid xs qual_name ty_vars orig_sums int_sums) stockDerivs
100100
doDer flags r packageid xs struct_decl@(Cstruct _ s i ty_var_names fields derivs) =
101101
let unqual_name = iKName i
102102
qual_name = qualId packageid unqual_name
@@ -105,8 +105,8 @@ doDer flags r packageid xs struct_decl@(Cstruct _ s i ty_var_names fields derivs
105105
_ -> internalError "Deriving.doDer Cstruct: findType"
106106
ty_var_kinds = getArgKinds kind
107107
ty_vars = zipWith cTVarKind ty_var_names ty_var_kinds
108-
derivs' = addAutoDerivs flags r qual_name ty_vars derivs
109-
in Right [struct_decl] : map (doStructDer r packageid xs qual_name ty_vars fields) derivs'
108+
stockDerivs = addAutoDerivs flags r qual_name ty_vars (getStockDerivs derivs)
109+
in Right [struct_decl] : map (doStructDer r packageid xs qual_name ty_vars fields) stockDerivs
110110
doDer flags r packageid xs prim_decl@(CprimType (IdKind i kind))
111111
-- "special" typeclasses only need to be derived for ordinary types
112112
| res_kind /= KStar = [Right [prim_decl]]
@@ -992,5 +992,11 @@ addAutoDerivs flags r i tvs derivs =
992992
setPos clsId = setIdPosition pos (unQualId clsId)
993993
f = addAutoDeriv flags r i tvs
994994

995+
getStockTC :: CDeriving -> [CTypeclass]
996+
getStockTC (CStock tcs) = tcs
997+
getStockTC _ = []
998+
999+
getStockDerivs :: [CDeriving] -> [CTypeclass]
1000+
getStockDerivs = concatMap getStockTC
9951001

9961002
-- -------------------------

‎src/comp/Lex.hs‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -57,7 +57,7 @@ data LexItem =
5757
| L_interface | L_instance
5858
| L_let | L_letseq | L_package | L_of
5959
| L_primitive | L_qualified | L_rules | L_signature | L_struct
60-
| L_then | L_module | L_type | L_valueOf | L_stringOf | L_verilog | L_synthesize | L_when | L_where
60+
| L_then | L_module | L_type | L_valueOf | L_stringOf | L_verilog | L_via | L_synthesize | L_when | L_where
6161
| L_coherent | L_incoherent
6262
-- reserved ops
6363
| L_dcolon | L_colon | L_eq | L_at | L_lam | L_bar
@@ -94,6 +94,7 @@ prLexItem L_case = "case"
9494
prLexItem L_class = "class"
9595
prLexItem L_data = "data"
9696
prLexItem L_deriving = "deriving"
97+
prLexItem L_via = "via"
9798
prLexItem L_do = "do"
9899
prLexItem L_else = "else"
99100
prLexItem L_foreign = "foreign"
@@ -363,6 +364,7 @@ lx lf f l c (x:cs) | isAlpha x || x == '_' = spanId [] (c+1) cs
363364
"valueOf" -> lxr L_valueOf
364365
"stringOf" -> lxr L_stringOf
365366
"verilog" -> lxr L_verilog
367+
"via" -> lxr L_via
366368
"synthesize" -> lxr L_synthesize
367369
"when" -> lxr L_when
368370
"where" -> lxr L_where

‎src/comp/Parser/BSV/CVParser.lhs‎

Lines changed: 24 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -869,15 +869,28 @@ though can it ever be anything other than KStar?)
869869
optional "deriving (Class, Class, ...)" clause
870870
returns names of classes to be derived, or error if deriving not permitted
871871

872-
> pDerivationsIf :: Bool -> SV_Parser [CTypeclass]
872+
> pDerivationsIf :: Bool -> SV_Parser [CDeriving]
873873
> pDerivationsIf False = option [] $
874874
> do pos <- getPos
875875
> pKeyword SV_KW_deriving
876876
> failWithErr (pos, EForbiddenDeriving)
877-
> pDerivationsIf True = option [] $
878-
> do pKeyword SV_KW_deriving
879-
> pInParens (pCommaSep1 (pTypeclass <?> "typeclass name"))
877+
> pDerivationsIf True = many pDeriving
880878

879+
> pDeriving :: SV_Parser CDeriving
880+
> pDeriving = pKeyword SV_KW_deriving
881+
> *> ( pDerivingStock
882+
> -- <|> pDerivingVia
883+
> )
884+
885+
> pDerivingStock :: SV_Parser CDeriving
886+
> pDerivingStock = CStock <$> pInParens (pCommaSep1 (pTypeclass <?> "typeclass name"))
887+
888+
For now Deriving Via is disabled for bsv.
889+
pDerivingVia :: SV_Parser CDeriving
890+
pDerivingVia = CVia
891+
<$> (pTypeclass <?> "typeclass name")
892+
*> pKeyword SV_KW_via
893+
<*> (pIdentifier <?> "via target")
881894
882895
> pTypeclass :: SV_Parser CTypeclass
883896
> pTypeclass = CTypeclass <$> pQualConstructor
@@ -895,7 +908,7 @@ if prefix is provided, sub-union and sub-struct constructors start with it
895908
> pTypedefStructField ::
896909
> SV_Parser (Maybe Id {- constructor ID prefix -}
897910
> -> [(Id, PartialKind)] {- type parameters collected thus far -}
898-
> -> [CTypeclass] {- derivings collected thus far -}
911+
> -> [CDeriving] {- derivings collected thus far -}
899912
> -> (CField, [CDefn] {- accum'd defs -}))
900913
> pTypedefStructField =
901914
> do mkSubUnion <- pTypedefTaggedUnionType False False
@@ -919,7 +932,7 @@ if prefix is provided, sub-union and sub-struct constructors start with it
919932
> cf_type = typ,
920933
> cf_default = []
921934
> }
922-
> return (const $ const $ const (field, []))
935+
> return (const $ const $ const (field, []))
923936

924937
many struct fields
925938
returns a function which requires a supertype prefix
@@ -928,7 +941,7 @@ if prefix is provided, sub-union and sub-struct constructors start with it
928941
> pTypedefStructFields ::
929942
> SV_Parser (Maybe Id {- constructor ID prefix -}
930943
> -> [(Id, PartialKind)] {- type parameters accumulated thus far -}
931-
> -> [CTypeclass] {- derivations accumulated thus far -}
944+
> -> [CDeriving] {- derivations accumulated thus far -}
932945
> -> [(CField, [CDefn] {- accum'd defs -})])
933946
> pTypedefStructFields =
934947
> do mks <- many pTypedefStructField
@@ -946,7 +959,7 @@ if prefix is provided, sub-union and sub-struct constructors start with it
946959
> -> SV_Parser
947960
> (Maybe Id {- constructor ID prefix -}
948961
> -> [(Id, PartialKind)] {- type parameters collected thus far -}
949-
> -> [CTypeclass] {- derivations collected thus far -}
962+
> -> [CDeriving] {- derivations collected thus far -}
950963
> -> ((Id, CType, [Id], [CQType]), [CDefn]))
951964
> pTypedefStructType isTopLevel =
952965
> do pKeyword SV_KW_struct
@@ -981,7 +994,7 @@ if prefix is provided, sub-union and sub-struct constructors start with it
981994
> SV_Parser (Maybe Id {- constructor ID prefix -}
982995
> -> Integer {- tag encoding -}
983996
> -> [(Id, PartialKind)] {- type parameters collected thus far -}
984-
> -> [CTypeclass] {- derivations collected thus far -}
997+
> -> [CDeriving] {- derivations collected thus far -}
985998
> -> (TaggedUnionField, [CDefn] {- accum'd defs -}))
986999
> pTypedefTaggedUnionField =
9871000
> do mkSubStruct <- pTypedefStructType False
@@ -1052,7 +1065,7 @@ if prefix is provided, sub-union and sub-struct constructors start with it
10521065
> pTypedefTaggedUnionFields ::
10531066
> SV_Parser (Maybe Id {- constructor ID prefix -}
10541067
> -> [(Id, PartialKind)] {- type parameters collected thus far -}
1055-
> -> [CTypeclass] {- derivations collected thus far -}
1068+
> -> [CDeriving] {- derivations collected thus far -}
10561069
> -> [(TaggedUnionField, [CDefn])])
10571070
> pTypedefTaggedUnionFields =
10581071
> do mks <- many1 pTypedefTaggedUnionField
@@ -1075,7 +1088,7 @@ will be a field inside a struct and should be an identifier
10751088
> -> SV_Parser
10761089
> (Maybe Id {- constructor ID prefix -}
10771090
> -> [(Id, PartialKind)] {- type params collected thus far -}
1078-
> -> [CTypeclass] {- derivations collected thus far -}
1091+
> -> [CDeriving] {- derivations collected thus far -}
10791092
> -> ((Id, CType, [CQType]), [CDefn]))
10801093
> pTypedefTaggedUnionType isTopLevel uppercaseName =
10811094
> do pKeyword SV_KW_union >> pKeyword SV_KW_tagged

‎src/comp/Parser/Classic/CParser.hs‎

Lines changed: 13 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -531,9 +531,19 @@ pSummand' = pSummandConIds `into` \ constr_names ->
531531
blockBrOf pQField >>- (\ fs -> (constr_names, Right fs))
532532
||! many atyp >>- (\ ts -> (constr_names, Left (map (CQType []) ts)))
533533

534-
pDer :: CParser [CTypeclass]
535-
pDer = l L_deriving ..+ lp ..+ sepBy pTypeclass cm +.. rp
536-
||! succeed []
534+
pDeriving :: CParser CDeriving
535+
pDeriving = l L_deriving ..+
536+
( pDerivingStock
537+
||! pDerivingVia)
538+
539+
pDerivingStock :: CParser CDeriving
540+
pDerivingStock = lp ..+ sepBy1 pTypeclass cm +.. rp >>- CStock
541+
542+
pDerivingVia :: CParser CDeriving
543+
pDerivingVia = pTypeclass +.+ l L_via ..+ pTyConId >>> CVia
544+
545+
pDer :: CParser [CDeriving]
546+
pDer = many pDeriving
537547

538548
opt :: CParser a -> CParser (Maybe a)
539549
opt p = p >>- Just ||! succeed Nothing

‎src/comp/SystemVerilogKeywords.lhs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -256,6 +256,7 @@ Data type declaration for the keywords:
256256
> | SV_KW_actionvalue
257257
> | SV_KW_endactionvalue
258258
> | SV_KW_deriving
259+
> | SV_KW_via
259260
> | SV_KW_endinstance
260261
> | SV_KW_let
261262
> | SV_KW_method
@@ -604,6 +605,7 @@ scanner and to prettyprint keywords.
604605
> (SV_KW_actionvalue, "actionvalue", Bluespec38),
605606
> (SV_KW_endactionvalue, "endactionvalue", Bluespec38),
606607
> (SV_KW_deriving, "deriving", Bluespec38),
608+
> (SV_KW_deriving, "deriving", Bluespec38),
607609
> (SV_KW_endinstance, "endinstance", Bluespec38),
608610
> (SV_KW_let, "let", Bluespec38),
609611
> (SV_KW_match, "match", Bluespec38),
@@ -635,6 +637,8 @@ scanner and to prettyprint keywords.
635637
> (SV_KW_powered_by, "powered_by", Bluespec38),
636638
> (SV_KW_Action, "Action", Bluespec38),
637639
> (SV_KW_ActionValue, "ActionValue", Bluespec38)]
640+
> -- Bluespec X.X keywords
641+
> -- (SV_KW_via, "via", BluespecXX)]
638642

639643
Symbol table
640644

0 commit comments

Comments
 (0)