Add fixity declarations to Template Haskell (Trac #1541)

There is an accompanying patch to the template-haskell library

compiler/deSugar/DsMeta.hs

@@ -124,16 +124,16 @@ repTopDs group
 	--	     return (Data t [] ...more t's... }
 	-- The other important reason is that the output must mention
 	-- only "T", not "Foo:T" where Foo is the current module
-
 	
 	decls <- addBinds ss (do {
+                        fix_ds  <- mapM repFixD (hs_fixds group) ;
 			val_ds  <- rep_val_binds (hs_valds group) ;
 			tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
 			inst_ds <- mapM repInstD (hs_instds group) ;
 			for_ds <- mapM repForD (hs_fords group) ;
 			-- more needed
 			return (de_loc $ sort_by_loc $ 
-                                val_ds ++ catMaybes tycl_ds
+                                val_ds ++ catMaybes tycl_ds ++ fix_ds
                                        ++ catMaybes inst_ds ++ for_ds) }) ;
 
 	decl_ty <- lookupType decQTyConName ;
@@ -175,11 +175,12 @@ repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
 repTyClD tydecl@(L _ (TyFamily {}))
   = repTyFamily tydecl addTyVarBinds
 
-repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, 
+repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, tcdKindSig = mb_kind,
 		          tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
 		          tcdCons = cons, tcdDerivs = mb_derivs }))
   = do { tc1 <- lookupLOcc tc 		-- See note [Binders and occurrences] 
-       ; dec <- addTyVarBinds tvs $ \bndrs -> 
+       ; more_tvs <- mk_extra_tvs mb_kind
+       ; dec <- addTyVarBinds (tvs ++ more_tvs) $ \bndrs -> 
            do { cxt1     <- repLContext cxt
               ; opt_tys1 <- maybeMapM repLTys opt_tys   -- only for family insts
               ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
@@ -244,6 +245,34 @@ repTyClD (L loc d) = putSrcSpanDs loc $
 		     do { warnDs (hang ds_msg 4 (ppr d))
 			; return Nothing }
 
+-------------------------
+mk_extra_tvs :: Maybe (HsBndrSig (LHsKind Name)) -> DsM [LHsTyVarBndr Name]
+-- If there is a kind signature it must be of form
+--    k1 -> .. -> kn -> *
+-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
+mk_extra_tvs Nothing 
+  = return []
+mk_extra_tvs (Just (HsBSig hs_kind _))
+  = go hs_kind
+  where
+    go :: LHsKind Name -> DsM [LHsTyVarBndr Name]
+    go (L loc (HsFunTy kind rest))
+      = do { uniq <- newUnique
+           ; let { occ = mkTyVarOccFS (fsLit "t")
+                 ; nm = mkInternalName uniq occ loc
+                 ; hs_tv = L loc (KindedTyVar nm (HsBSig kind placeHolderBndrs)) }
+           ; hs_tvs <- go rest
+           ; return (hs_tv : hs_tvs) }
+
+    go (L _ (HsTyVar n))
+      | n == liftedTypeKindTyConName
+      = return []
+   
+    go _ = failWithDs (hang (ptext (sLit "Malformed kind signature"))
+                          2 (ppr hs_kind))
+
+
+-------------------------
 -- The type variables in the head of families are treated differently when the
 -- family declaration is associated.  In that case, they are usage, not binding
 -- occurences.
@@ -261,9 +290,9 @@ repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
 	      ; bndrs1 <- coreList tyVarBndrTyConName bndrs
               ; case opt_kind of 
                   Nothing -> repFamilyNoKind flav tc1 bndrs1
-                  Just ki -> do { ki1 <- repKind ki 
-                                ; repFamilyKind flav tc1 bndrs1 ki1
-                                }
+                  Just (HsBSig ki _) 
+                    -> do { ki1 <- repKind ki 
+                          ; repFamilyKind flav tc1 bndrs1 ki1 }
               }
        ; return $ Just (loc, dec)
        }
@@ -314,7 +343,7 @@ repInstD (L loc (FamInstDecl fi_decl))
   = repTyClD (L loc fi_decl)
 
 
-repInstD (L loc (ClsInstDecl ty binds _ ats))	-- Ignore user pragmas for now
+repInstD (L loc (ClsInstDecl ty binds prags ats))
   = do { dec <- addTyVarBinds tvs $ \_ ->
 	    -- We must bring the type variables into scope, so their
 	    -- occurrences don't fail, even though the binders don't 
@@ -330,8 +359,9 @@ repInstD (L loc (ClsInstDecl ty binds _ ats))	-- Ignore user pragmas for now
                ; cls_tys <- repLTys tys
                ; inst_ty1 <- repTapps cls_tcon cls_tys
                ; binds1 <- rep_binds binds
+               ; prags1 <- rep_sigs prags
                ; ats1 <- repLAssocFamInst ats
-               ; decls <- coreList decQTyConName (ats1 ++ binds1)
+               ; decls <- coreList decQTyConName (ats1 ++ binds1 ++ prags1)
                ; repInst cxt1 inst_ty1 decls }
        ; return (Just (loc, dec)) }
  where
@@ -371,6 +401,17 @@ repSafety PlayRisky = rep2 unsafeName []
 repSafety PlayInterruptible = rep2 interruptibleName []
 repSafety PlaySafe = rep2 safeName []
 
+repFixD :: LFixitySig Name -> DsM (SrcSpan, Core TH.DecQ)
+repFixD (L loc (FixitySig name (Fixity prec dir)))
+  = do { MkC name' <- lookupLOcc name
+       ; MkC prec' <- coreIntLit prec
+       ; let rep_fn = case dir of 
+                        InfixL -> infixLDName
+                        InfixR -> infixRDName
+                        InfixN -> infixNDName
+       ; dec <- rep2 rep_fn [prec', name']
+       ; return (loc, dec) }
+
 ds_msg :: SDoc
 ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
 
@@ -426,7 +467,7 @@ mkGadtCtxt data_tvs (ResTyGADT res_ty)
   = return (go [] [] (data_tvs `zip` tys))
 
   | otherwise 
-  = failWithDs (ptext (sLit "Malformed constructor result type") <+> ppr res_ty)
+  = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
   where
     go cxt subst [] = (cxt, subst)
     go cxt subst ((data_tv, ty) : rest)
@@ -607,7 +648,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name
                      -> Core TH.Name -> DsM (Core TH.TyVarBndr)
 repTyVarBndrWithKind (L _ (UserTyVar {})) nm
   = repPlainTV nm
-repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _) _)) nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _))) nm
   = repKind ki >>= repKindedTV nm
 
 -- represent a type context
@@ -1963,7 +2004,8 @@ parSName    = libFun (fsLit "parS")    parSIdKey
 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
     instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
     pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
-    newtypeInstDName, tySynInstDName :: Name
+    newtypeInstDName, tySynInstDName, 
+    infixLDName, infixRDName, infixNDName :: Name
 funDName         = libFun (fsLit "funD")         funDIdKey
 valDName         = libFun (fsLit "valD")         valDIdKey
 dataDName        = libFun (fsLit "dataD")        dataDIdKey
@@ -1981,6 +2023,9 @@ familyKindDName  = libFun (fsLit "familyKindD")  familyKindDIdKey
 dataInstDName    = libFun (fsLit "dataInstD")    dataInstDIdKey
 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
 tySynInstDName   = libFun (fsLit "tySynInstD")   tySynInstDIdKey
+infixLDName      = libFun (fsLit "infixLD")      infixLDIdKey
+infixRDName      = libFun (fsLit "infixRD")      infixRDIdKey
+infixNDName      = libFun (fsLit "infixND")      infixNDIdKey
 
 -- type Ctxt = ...
 cxtName :: Name
@@ -2245,7 +2290,8 @@ parSIdKey        = mkPreludeMiscIdUnique 323
 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
     classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
     pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
-    dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique 
+    dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, 
+    infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique 
 funDIdKey          = mkPreludeMiscIdUnique 330
 valDIdKey          = mkPreludeMiscIdUnique 331
 dataDIdKey         = mkPreludeMiscIdUnique 332
@@ -2263,6 +2309,9 @@ familyKindDIdKey   = mkPreludeMiscIdUnique 343
 dataInstDIdKey     = mkPreludeMiscIdUnique 344
 newtypeInstDIdKey  = mkPreludeMiscIdUnique 345
 tySynInstDIdKey    = mkPreludeMiscIdUnique 346
+infixLDIdKey       = mkPreludeMiscIdUnique 347
+infixRDIdKey       = mkPreludeMiscIdUnique 348
+infixNDIdKey       = mkPreludeMiscIdUnique 349
 
 -- type Cxt = ...
 cxtIdKey :: Unique

compiler/hsSyn/Convert.lhs

@@ -154,6 +154,10 @@ cvtDec (TH.SigD nm typ)
 	; ty' <- cvtType typ
 	; returnL $ Hs.SigD (TypeSig [nm'] ty') }
 
+cvtDec (TH.InfixD fx nm)
+  = do { nm' <- vNameL nm
+       ; returnL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) } 
+
 cvtDec (PragmaD prag)
   = do { prag' <- cvtPragmaD prag
        ; returnL $ Hs.SigD prag' }
@@ -250,7 +254,7 @@ cvt_ci_decs :: MsgDoc -> [TH.Dec]
 -- ie signatures, bindings, and associated types
 cvt_ci_decs doc decs
   = do  { decs' <- mapM cvtDec decs
-        ; let (ats', bind_sig_decs') = partitionWith is_tycl decs'
+        ; let (ats', bind_sig_decs') = partitionWith is_fam_inst decs'
 	; let (sigs', prob_binds') = partitionWith is_sig bind_sig_decs'
 	; let (binds', bads) = partitionWith is_bind prob_binds'
 	; unless (null bads) (failWith (mkBadDecMsg doc bads))
@@ -302,9 +306,9 @@ cvt_tyinst_hdr cxt tc tys
 --		Partitioning declarations
 -------------------------------------------------------------------
 
-is_tycl :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName)
-is_tycl (L loc (Hs.TyClD tcd)) = Left (L loc tcd)
-is_tycl decl                   = Right decl
+is_fam_inst :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName)
+is_fam_inst (L loc (Hs.InstD (FamInstDecl d))) = Left (L loc d)
+is_fam_inst decl                               = Right decl
 
 is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
 is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
@@ -791,12 +795,11 @@ cvtTvs tvs = mapM cvt_tv tvs
 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
 cvt_tv (TH.PlainTV nm) 
   = do { nm' <- tName nm
-       ; returnL $ UserTyVar nm' placeHolderKind
-       }
+       ; returnL $ UserTyVar nm' }
 cvt_tv (TH.KindedTV nm ki) 
   = do { nm' <- tName nm
        ; ki' <- cvtKind ki
-       ; returnL $ KindedTyVar nm' (HsBSig ki' placeHolderBndrs) placeHolderKind }
+       ; returnL $ KindedTyVar nm' (HsBSig ki' placeHolderBndrs) }
 
 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
@@ -877,9 +880,18 @@ cvtKind (ArrowK k1 k2) = do
   k2' <- cvtKind k2
   returnL (HsFunTy k1' k2')
 
-cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName))
+cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (HsBndrSig (LHsKind RdrName)))
 cvtMaybeKind Nothing = return Nothing
-cvtMaybeKind (Just ki) = cvtKind ki >>= return . Just
+cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki
+                            ; return (Just (HsBSig ki' placeHolderBndrs)) }
+
+-----------------------------------------------------------
+cvtFixity :: TH.Fixity -> Hs.Fixity
+cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir)
+   where
+     cvt_dir TH.InfixL = Hs.InfixL
+     cvt_dir TH.InfixR = Hs.InfixR
+     cvt_dir TH.InfixN = Hs.InfixN
 
 -----------------------------------------------------------