[project @ 1997-08-03 02:30:42 by sof]
authorsof <unknown>
Sun, 3 Aug 1997 02:30:42 +0000 (02:30 +0000)
committersof <unknown>
Sun, 3 Aug 1997 02:30:42 +0000 (02:30 +0000)
derived Show: added printing of labels for constructors with labelled fields; derived Read: added lexing of fields for constructors with labelled fields

ghc/compiler/typecheck/TcGenDeriv.lhs

index d317f10..14cf7a0 100644 (file)
@@ -28,7 +28,7 @@ module TcGenDeriv (
     ) where
 
 IMP_Ubiq()
     ) where
 
 IMP_Ubiq()
-IMPORT_1_3(List(partition))
+IMPORT_1_3(List(partition,intersperse))
 
 import HsSyn           ( HsBinds(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
                          GRHS(..), HsExpr(..), HsLit(..), InPat(..), Stmt(..), DoOrListComp(..),
 
 import HsSyn           ( HsBinds(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
                          GRHS(..), HsExpr(..), HsLit(..), InPat(..), Stmt(..), DoOrListComp(..),
@@ -38,12 +38,14 @@ import RdrHsSyn             ( RdrName(..), varQual, varUnqual, mkOpApp,
                          SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat)
                        )
 import BasicTypes      ( IfaceFlavour(..) )
                          SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat)
                        )
 import BasicTypes      ( IfaceFlavour(..) )
+import FieldLabel       ( fieldLabelName )
 import Id              ( GenId, isNullaryDataCon, dataConTag,
                          dataConRawArgTys, fIRST_TAG,
                          isDataCon, SYN_IE(DataCon), SYN_IE(ConTag),
 import Id              ( GenId, isNullaryDataCon, dataConTag,
                          dataConRawArgTys, fIRST_TAG,
                          isDataCon, SYN_IE(DataCon), SYN_IE(ConTag),
-                         SYN_IE(Id) )
+                         dataConFieldLabels, SYN_IE(Id) )
 import Maybes          ( maybeToBool )
 import Maybes          ( maybeToBool )
-import Name            ( getOccString, getOccName, getSrcLoc, occNameString, modAndOcc, OccName, Name )
+import Name            ( getOccString, getOccName, getSrcLoc, occNameString, 
+                         modAndOcc, OccName, Name )
 
 import PrimOp          ( PrimOp(..) )
 import PrelInfo                -- Lots of RdrNames
 
 import PrimOp          ( PrimOp(..) )
 import PrelInfo                -- Lots of RdrNames
@@ -53,7 +55,17 @@ import Type          ( eqTy, isPrimType, SYN_IE(Type) )
 import TysPrim         ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
                          floatPrimTy, doublePrimTy
                        )
 import TysPrim         ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
                          floatPrimTy, doublePrimTy
                        )
-import Util            ( mapAccumL, zipEqual, zipWith3Equal, nOfThem, panic, assertPanic )
+import Util            ( mapAccumL, zipEqual, zipWithEqual,
+                         zipWith3Equal, nOfThem, panic, assertPanic )
+
+
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 200
+intersperse :: a -> [a] -> [a]
+intersperse s []     = []
+intersperse s [x]    = [x]
+intersperse s (x:xs) = x : s : intersperse s xs
+#endif
+
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -587,8 +599,10 @@ gen_Ix_binds tycon
          ) tycon_loc))))
 
     --------------------------------------------------------------
          ) tycon_loc))))
 
     --------------------------------------------------------------
-    single_con_ixes = single_con_range `AndMonoBinds`
-               single_con_index `AndMonoBinds` single_con_inRange
+    single_con_ixes 
+      = single_con_range `AndMonoBinds`
+       single_con_index `AndMonoBinds`
+       single_con_inRange
 
     data_con
       =        case maybeTyConSingleCon tycon of -- just checking...
 
     data_con
       =        case maybeTyConSingleCon tycon of -- just checking...
@@ -598,15 +612,16 @@ gen_Ix_binds tycon
                     else
                         dc
 
                     else
                         dc
 
-    con_arity   = argFieldCount data_con
+    con_arity    = argFieldCount data_con
     data_con_RDR = qual_orig_name data_con
     data_con_RDR = qual_orig_name data_con
-    con_pat  xs = ConPatIn data_con_RDR (map VarPatIn xs)
-    con_expr xs = mk_easy_App data_con_RDR xs
 
     as_needed = take con_arity as_RDRs
     bs_needed = take con_arity bs_RDRs
     cs_needed = take con_arity cs_RDRs
 
 
     as_needed = take con_arity as_RDRs
     bs_needed = take con_arity bs_RDRs
     cs_needed = take con_arity cs_RDRs
 
+    con_pat  xs  = ConPatIn data_con_RDR (map VarPatIn xs)
+    con_expr     = mk_easy_App data_con_RDR cs_needed
+
     --------------------------------------------------------------
     single_con_range
       = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] $
     --------------------------------------------------------------
     single_con_range
       = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] $
@@ -614,7 +629,7 @@ gen_Ix_binds tycon
       where
        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
                ++
       where
        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
                ++
-               [ReturnStmt (con_expr cs_needed)]
+               [ReturnStmt con_expr]
 
        mk_qual a b c = BindStmt (VarPatIn c)
                                 (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b]))
 
        mk_qual a b c = BindStmt (VarPatIn c)
                                 (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b]))
@@ -625,6 +640,8 @@ gen_Ix_binds tycon
       = mk_easy_FunMonoBind tycon_loc index_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
        foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
       where
       = mk_easy_FunMonoBind tycon_loc index_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
        foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
       where
+       mk_index (HsLit (HsInt 0)) (l, u, i)  -- optim.
+         = HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i)
        mk_index multiply_by (l, u, i)
          = genOpApp (
                (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
        mk_index multiply_by (l, u, i)
          = genOpApp (
                (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
@@ -683,33 +700,74 @@ gen_Read_binds tycon
                data_con_RDR = qual_orig_name data_con
                data_con_str= occNameString (getOccName data_con)
                con_arity   = argFieldCount data_con
                data_con_RDR = qual_orig_name data_con
                data_con_str= occNameString (getOccName data_con)
                con_arity   = argFieldCount data_con
-               as_needed   = take con_arity as_RDRs
-               bs_needed   = take con_arity bs_RDRs
                con_expr    = mk_easy_App data_con_RDR as_needed
                nullary_con = con_arity == 0
                con_expr    = mk_easy_App data_con_RDR as_needed
                nullary_con = con_arity == 0
+               labels      = dataConFieldLabels data_con
+               lab_fields  = length labels
 
 
+               as_needed   = take con_arity as_RDRs
+               bs_needed   
+                | lab_fields == 0 = take con_arity bs_RDRs
+                | otherwise       = take (4*lab_fields + 1) bs_RDRs
+                                      -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
                con_qual
                con_qual
-                 = BindStmt
-                     (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
-                     (HsApp (HsVar lex_RDR) c_Expr)
-                     tycon_loc
-
-               field_quals = snd (mapAccumL mk_qual d_Expr (zipEqual "as_needed" as_needed bs_needed))
-               mk_qual draw_from (con_field, str_left)
+                  = BindStmt
+                         (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
+                         (HsApp (HsVar lex_RDR) c_Expr)
+                         tycon_loc
+
+               str_qual str res draw_from
+                  = BindStmt
+                      (TuplePatIn [LitPatIn (HsString str), VarPatIn res])
+                      (HsApp (HsVar lex_RDR) draw_from)
+                      tycon_loc
+  
+               read_label f
+                 = let nm = occNameString (getOccName (fieldLabelName f))
+                   in 
+                       [str_qual nm, str_qual SLIT("=")] 
+                           -- There might be spaces between the label and '='
+
+               field_quals
+                 | lab_fields == 0 =
+                    snd (mapAccumL mk_qual 
+                                   d_Expr 
+                                   (zipWithEqual "as_needed" 
+                                                 (\ con_field draw_from -> (mk_read_qual con_field,
+                                                                            draw_from))
+                                                 as_needed bs_needed))
+                  | otherwise =
+                    snd $
+                    mapAccumL mk_qual d_Expr
+                       (zipEqual "bs_needed"        
+                          ((str_qual (SLIT("{")):
+                            concat (
+                            intersperse ([str_qual SLIT(",")]) $
+                            zipWithEqual 
+                               "field_quals"
+                               (\ as b -> as ++ [b])
+                                   -- The labels
+                               (map read_label labels)
+                                   -- The fields
+                               (map mk_read_qual as_needed))) ++ [str_qual (SLIT("}"))])
+                           bs_needed)
+
+               mk_qual draw_from (f, str_left)
                  = (HsVar str_left,    -- what to draw from down the line...
                  = (HsVar str_left,    -- what to draw from down the line...
-                        BindStmt
-                         (TuplePatIn [VarPatIn con_field, VarPatIn str_left])
-                         (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from)
-                         tycon_loc
-                   )
+                    f str_left draw_from)
+
+               mk_read_qual con_field res draw_from =
+                 BindStmt
+                  (TuplePatIn [VarPatIn con_field, VarPatIn res])
+                  (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from)
+                  tycon_loc
 
                result_expr = ExplicitTuple [con_expr, if null bs_needed 
                                                       then d_Expr 
                                                       else HsVar (last bs_needed)]
 
 
                result_expr = ExplicitTuple [con_expr, if null bs_needed 
                                                       then d_Expr 
                                                       else HsVar (last bs_needed)]
 
-               stmts = (con_qual : field_quals) ++ [ReturnStmt result_expr]
+               stmts = con_qual:field_quals ++ [ReturnStmt result_expr]
                
                
-
                read_paren_arg
                  = if nullary_con then -- must be False (parens are surely optional)
                       false_Expr
                read_paren_arg
                  = if nullary_con then -- must be False (parens are surely optional)
                       false_Expr
@@ -721,6 +779,7 @@ gen_Read_binds tycon
                 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
                        HsDo ListComp stmts tycon_loc)
              ) (HsVar b_RDR)
                 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
                        HsDo ListComp stmts tycon_loc)
              ) (HsVar b_RDR)
+
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -748,22 +807,57 @@ gen_Show_binds tycon
        pats_etc data_con
          = let
                data_con_RDR = qual_orig_name data_con
        pats_etc data_con
          = let
                data_con_RDR = qual_orig_name data_con
-               con_arity   = argFieldCount data_con
-               bs_needed   = take con_arity bs_RDRs
-               con_pat     = ConPatIn data_con_RDR (map VarPatIn bs_needed)
-               nullary_con = con_arity == 0
+               con_arity    = argFieldCount data_con
+               bs_needed    = take con_arity bs_RDRs
+               con_pat      = ConPatIn data_con_RDR (map VarPatIn bs_needed)
+               nullary_con  = con_arity == 0
+                labels       = dataConFieldLabels data_con
+               lab_fields   = length labels
 
                show_con
                  = let nm = occNameString (getOccName data_con)
 
                show_con
                  = let nm = occNameString (getOccName data_con)
-                       space_maybe = if nullary_con then _NIL_ else SLIT(" ")
+                       space_ocurly_maybe
+                          | nullary_con     = _NIL_
+                         | lab_fields == 0 = SLIT(" ")
+                         | otherwise       = SLIT("{")
+
                    in
                    in
-                       HsApp (HsVar showString_RDR) (HsLit (HsString (nm _APPEND_ space_maybe)))
+                       mk_showString_app (nm _APPEND_ space_ocurly_maybe)
 
 
-               show_thingies = show_con : (spacified real_show_thingies)
+               show_all con fs
+                 = let
+                        ccurly_maybe 
+                          | lab_fields > 0  = [mk_showString_app (SLIT("}"))]
+                          | otherwise       = []
+                   in
+                       con:fs ++ ccurly_maybe
+
+               show_thingies = show_all show_con real_show_thingies_with_labs
+                
+               show_label l 
+                 = let nm = occNameString (getOccName (fieldLabelName l)) 
+                   in
+                       mk_showString_app (nm _APPEND_ SLIT("="))
+
+                mk_showString_app str = HsApp (HsVar showString_RDR)
+                                             (HsLit (HsString str))
+
+               real_show_thingies =
+                    [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
+                    | b <- bs_needed ]
+
+                real_show_thingies_with_labs
+                | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
+                | otherwise       = --Assumption: no of fields == no of labelled fields 
+                                    --            (and in same order)
+                   concat $
+                   intersperse ([mk_showString_app (_CONS_ ',' _NIL_ )]) $ -- Using SLIT() is not cool here.
+                   zipWithEqual "gen_Show_binds"
+                                (\ a b -> [a,b])
+                                (map show_label labels) 
+                                real_show_thingies
+                              
 
 
-               real_show_thingies
-                 = [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
-                 | b <- bs_needed ]
            in
            if nullary_con then  -- skip the showParen junk...
                ASSERT(null bs_needed)
            in
            if nullary_con then  -- skip the showParen junk...
                ASSERT(null bs_needed)
@@ -772,10 +866,6 @@ gen_Show_binds tycon
                ([a_Pat, con_pat],
                    showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10))))
                                   (HsPar (nested_compose_Expr show_thingies)))
                ([a_Pat, con_pat],
                    showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10))))
                                   (HsPar (nested_compose_Expr show_thingies)))
-         where
-           spacified []     = []
-           spacified [x]    = [x]
-           spacified (x:xs) = (x : (HsVar showSpace_RDR) : spacified xs)
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************