add support for <{..}> and ~~> syntax as well as typing for Kappa-calculus

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 2ac19ce..64b3476 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -217,12 +217,29 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
 dsExpr :: HsExpr Id -> DsM CoreExpr
 dsExpr (HsPar e)             = dsLExpr e
 
 dsExpr :: HsExpr Id -> DsM CoreExpr
 dsExpr (HsPar e)             = dsLExpr e
 

-dsExpr (HsHetMetBrak c   e)   = do { e' <- dsExpr (unLoc e)
-                                 ; brak <- dsLookupGlobalId hetmet_brak_name
-                                 ; return $ mkApps (Var brak) [ (Type c), (Type $ exprType e'), e'] }
-dsExpr (HsHetMetEsc  c t e)   = do { e' <- dsExpr (unLoc e)
-                                 ; esc <- dsLookupGlobalId hetmet_esc_name
-                                 ; return $ mkApps (Var esc)  [ (Type c), (Type t), e'] }
+dsExpr (HsHetMetBrak c   e)   =
+    do { e' <- dsExpr (unLoc e)
+       ; brak <- dsLookupGlobalId hetmet_brak_name
+       ; return $ mkApps (Var brak) [ (Type c), (Type $ exprType e'), e'] }
+dsExpr (HsHetMetEsc  c t e)   =
+    do { e' <- dsExpr (unLoc e)
+       ; esc <- dsLookupGlobalId hetmet_esc_name
+       ; return $ mkApps (Var esc)  [ (Type c), (Type t), e'] }
+dsExpr (HsKappa a_Match) =
+    do { e' <- dsExpr (HsLam a_Match)
+       ; let ([ua],bc) = tcSplitFunTys (exprType e')
+       ; let (_,[_,a]) = tcSplitAppTys ua
+       ; let (_,[b,c]) = tcSplitAppTys bc
+       ; kap <- dsLookupGlobalId hetmet_kappa_name
+       ; return $ mkApps (Var kap)  [ (Type a), (Type b), (Type c), e'] }
+dsExpr (HsKappaApp e1 e2) =
+    do { e1' <- dsExpr (unLoc e1)
+       ; e2' <- dsExpr (unLoc e2)
+       ; let (_,[_ ,a]) = tcSplitAppTys $ exprType e2'
+       ; let (_,[ab,c]) = tcSplitAppTys $ exprType e1'
+       ; let (_,[a,b])  = tcSplitAppTys $ ab
+       ; kap_app <- dsLookupGlobalId hetmet_kappa_app_name
+       ; return $ mkApps (Var kap_app)  [ (Type a), (Type b), (Type c), e1', e2'] }

 dsExpr (HsHetMetCSP  c   e)   = do { e' <- dsExpr (unLoc e)
                                  ; csp <- dsLookupGlobalId hetmet_csp_name
                                  ; return $ mkApps (Var csp)  [ (Type c), (Type $ exprType e'), e'] }
 dsExpr (HsHetMetCSP  c   e)   = do { e' <- dsExpr (unLoc e)
                                  ; csp <- dsLookupGlobalId hetmet_csp_name
                                  ; return $ mkApps (Var csp)  [ (Type c), (Type $ exprType e'), e'] }

@@ -247,6 +264,7 @@ dsExpr (HsLam a_Match)
 
 dsExpr (HsApp fun arg)
   = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
 
 dsExpr (HsApp fun arg)
   = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg

+

 \end{code}
 
 Operator sections.  At first it looks as if we can convert
 \end{code}
 
 Operator sections.  At first it looks as if we can convert

diff --git a/compiler/hetmet b/compiler/hetmet
index 6e1e4b6..7523e50 160000 (submodule)
--- a/compiler/hetmet
+++ b/compiler/hetmet
@@ -1 +1 @@
-Subproject commit 6e1e4b67d01a6447f7dd44f7b5450ddc400000d9
+Subproject commit 7523e5094db5e00224ba034b00aa243e69211c9f

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index c3c372d..8ea0c4f 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -106,6 +106,10 @@ data HsExpr id
 
   | HsApp     (LHsExpr id) (LHsExpr id) -- Application
 
 
   | HsApp     (LHsExpr id) (LHsExpr id) -- Application
 

+  | HsKappa    (MatchGroup id)
+
+  | HsKappaApp (LHsExpr id) (LHsExpr id)
+

   -- Operator applications:
   -- NB Bracketed ops such as (+) come out as Vars.
 
   -- Operator applications:
   -- NB Bracketed ops such as (+) come out as Vars.
 

@@ -360,13 +364,15 @@ ppr_expr (HsIPVar v)     = ppr v
 ppr_expr (HsLit lit)     = ppr lit
 ppr_expr (HsOverLit lit) = ppr lit
 ppr_expr (HsPar e)       = parens (ppr_lexpr e)
 ppr_expr (HsLit lit)     = ppr lit
 ppr_expr (HsOverLit lit) = ppr lit
 ppr_expr (HsPar e)       = parens (ppr_lexpr e)

-ppr_expr (HsHetMetBrak _   e) = ptext (sLit "<[") <> (ppr_lexpr e) <> ptext (sLit "]>")
-ppr_expr (HsHetMetEsc  _ _ e) = ptext (sLit "~~") <> (ppr_lexpr e)
-ppr_expr (HsHetMetCSP  _   e) = ptext (sLit "%%") <> (ppr_lexpr e)
+ppr_expr (HsHetMetBrak  _   e) = ptext (sLit "<[") <> (ppr_lexpr e) <> ptext (sLit "]>")
+ppr_expr (HsHetMetEsc   _ _ e) = ptext (sLit "~~") <> (ppr_lexpr e)
+ppr_expr (HsHetMetCSP   _   e) = ptext (sLit "%%") <> (ppr_lexpr e)

 
 ppr_expr (HsCoreAnn s e)
   = vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e]
 
 
 ppr_expr (HsCoreAnn s e)
   = vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e]
 

+ppr_expr (HsKappaApp e1 e2) = ppr_expr $ HsApp e1 e2
+ppr_expr (HsKappa    e) = ppr_expr $ HsLam e

 ppr_expr (HsApp e1 e2)
   = let (fun, args) = collect_args e1 [e2] in
     hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args))
 ppr_expr (HsApp e1 e2)
   = let (fun, args) = collect_args e1 [e2] in
     hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args))

diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs
index ce748eb..be7e003 100644 (file)
--- a/compiler/hsSyn/HsSyn.lhs
+++ b/compiler/hsSyn/HsSyn.lhs
@@ -23,7 +23,7 @@ module HsSyn (
        module HsDoc,
        Fixity,
 
        module HsDoc,
        Fixity,
 

-       HsModule(..), HsExtCore(..),
+       HsModule(..), HsExtCore(..), CodeFlavor(..)

 ) where
 
 -- friends:
 ) where
 
 -- friends:

@@ -50,6 +50,9 @@ import Data.Data hiding ( Fixity )
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

+
+data CodeFlavor = LambdaFlavor | KappaFlavor
+

 -- | All we actually declare here is the top-level structure for a module.
 data HsModule name
   = HsModule {
 -- | All we actually declare here is the top-level structure for a module.
 data HsModule name
   = HsModule {

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 75e6c23..c64dfd8 100644 (file)
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -152,6 +152,9 @@ data HsType name
   | HsFunTy            (LHsType name)   -- function type
                        (LHsType name)
 
   | HsFunTy            (LHsType name)   -- function type
                        (LHsType name)
 

+  | HsKappaTy          (LHsType name)   -- first-order function type
+                       (LHsType name)
+

   | HsListTy           (LHsType name)  -- Element type
 
   | HsPArrTy           (LHsType name)  -- Elem. type of parallel array: [:t:]
   | HsListTy           (LHsType name)  -- Element type
 
   | HsPArrTy           (LHsType name)  -- Elem. type of parallel array: [:t:]

@@ -453,7 +456,8 @@ ppr_mono_ty _    (HsTupleTy con tys) = tupleParens con (interpp'SP tys)
 ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind)
 ppr_mono_ty _    (HsListTy ty)      = brackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsPArrTy ty)      = pabrackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind)
 ppr_mono_ty _    (HsListTy ty)      = brackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsPArrTy ty)      = pabrackets (ppr_mono_lty pREC_TOP ty)

-ppr_mono_ty _    (HsModalBoxType ecn ty) = ppr_modalBoxType (ppr ecn) (ppr_mono_lty pREC_TOP ty)
+ppr_mono_ty prec (HsKappaTy ty1 ty2) = ppr_kappa_ty prec ty1 ty2
+ppr_mono_ty _    (HsModalBoxType  ecn ty) = ppr_modalBoxType  (ppr ecn) (ppr_mono_lty pREC_TOP ty)

 ppr_mono_ty _    (HsPredTy pred)     = ppr pred
 ppr_mono_ty _    (HsSpliceTy s _ _)  = pprSplice s
 ppr_mono_ty _    (HsCoreTy ty)       = ppr ty
 ppr_mono_ty _    (HsPredTy pred)     = ppr pred
 ppr_mono_ty _    (HsSpliceTy s _ _)  = pprSplice s
 ppr_mono_ty _    (HsCoreTy ty)       = ppr ty

@@ -487,6 +491,14 @@ ppr_fun_ty ctxt_prec ty1 ty2
     maybeParen ctxt_prec pREC_FUN $
     sep [p1, ptext (sLit "->") <+> p2]
 
     maybeParen ctxt_prec pREC_FUN $
     sep [p1, ptext (sLit "->") <+> p2]
 

+ppr_kappa_ty :: (OutputableBndr name) => Int -> LHsType name -> LHsType name -> SDoc
+ppr_kappa_ty ctxt_prec ty1 ty2
+  = let p1 = ppr_mono_lty pREC_FUN ty1
+       p2 = ppr_mono_lty pREC_TOP ty2
+    in
+    maybeParen ctxt_prec pREC_FUN $
+    sep [p1, ptext (sLit "~~>") <+> p2]
+

 --------------------------
 pabrackets :: SDoc -> SDoc
 pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
 --------------------------
 pabrackets :: SDoc -> SDoc
 pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index cc57e05..9767afa 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -737,3 +737,6 @@ collect_sig_pat (TuplePat pats _ _) acc = foldr collect_sig_lpat acc pats
 collect_sig_pat (ConPatIn _ ps)     acc = foldr collect_sig_lpat acc (hsConPatArgs ps)
 collect_sig_pat _                   acc = acc       -- Literals, vars, wildcard
 \end{code}
 collect_sig_pat (ConPatIn _ ps)     acc = foldr collect_sig_lpat acc (hsConPatArgs ps)
 collect_sig_pat _                   acc = acc       -- Literals, vars, wildcard
 \end{code}

+
+
+

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index c9b2e1c..5bf9800 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -56,7 +56,7 @@ module Lexer (
    getLexState, popLexState, pushLexState,
    extension, bangPatEnabled, datatypeContextsEnabled,
    addWarning,
    getLexState, popLexState, pushLexState,
    extension, bangPatEnabled, datatypeContextsEnabled,
    addWarning,

-   incrBracketDepth, decrBracketDepth, getParserBrakDepth,
+   incrBracketDepth, incrBracketDepth1, decrBracketDepth, getParserBrakDepth, pushBracketDepth, popBracketDepth,

    lexTokenStream
   ) where
 
    lexTokenStream
   ) where
 

@@ -72,6 +72,7 @@ import Module
 import Ctype
 import BasicTypes      ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )
 import Util            ( readRational )
 import Ctype
 import BasicTypes      ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )
 import Util            ( readRational )

+import HsSyn (CodeFlavor(..))

 
 import Control.Monad
 import Data.Bits
 
 import Control.Monad
 import Data.Bits

@@ -330,6 +331,9 @@ $tab+         { warn Opt_WarnTabs (text "Warning: Tab character") }
   "<[" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol }
                                        { special ITopenBrak }
   "]>" / { ifExtension hetMetEnabled }  { special ITcloseBrak }
   "<[" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol }
                                        { special ITopenBrak }
   "]>" / { ifExtension hetMetEnabled }  { special ITcloseBrak }

+  "<{" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol }
+                                       { special ITopenBrak1 }
+  "}>" / { ifExtension hetMetEnabled }  { special ITcloseBrak1 }

   "~~" / { ifExtension hetMetEnabled }  { special ITescape }
   "%%" / { ifExtension hetMetEnabled }  { special ITdoublePercent }
   "~~$" / { ifExtension hetMetEnabled }  { special ITescapeDollar }
   "~~" / { ifExtension hetMetEnabled }  { special ITescape }
   "%%" / { ifExtension hetMetEnabled }  { special ITdoublePercent }
   "~~$" / { ifExtension hetMetEnabled }  { special ITescapeDollar }

@@ -503,6 +507,7 @@ data Token
   | ITvbar
   | ITlarrow
   | ITrarrow
   | ITvbar
   | ITlarrow
   | ITrarrow

+  | ITkappa

   | ITat
   | ITtilde
   | ITdarrow
   | ITat
   | ITtilde
   | ITdarrow

@@ -582,6 +587,8 @@ data Token
   -- Heterogeneous Metaprogramming extension
   | ITopenBrak                 --  <[
   | ITcloseBrak                        --  ]>
   -- Heterogeneous Metaprogramming extension
   | ITopenBrak                 --  <[
   | ITcloseBrak                        --  ]>

+  | ITopenBrak1                        --  <{
+  | ITcloseBrak1               --  }>

   | ITescape                   --  ~~
   | ITescapeDollar             --  ~~$
   | ITdoublePercent             --  %%
   | ITescape                   --  ~~
   | ITescapeDollar             --  ~~$
   | ITdoublePercent             --  %%

@@ -702,6 +709,7 @@ reservedSymsFM = listToUFM $
        ,("|",   ITvbar,     always)
        ,("<-",  ITlarrow,   always)
        ,("->",  ITrarrow,   always)
        ,("|",   ITvbar,     always)
        ,("<-",  ITlarrow,   always)
        ,("->",  ITrarrow,   always)

+       ,("~~>",  ITkappa,   always)

        ,("@",   ITat,       always)
        ,("~",   ITtilde,    always)
        ,("=>",  ITdarrow,   always)
        ,("@",   ITat,       always)
        ,("~",   ITtilde,    always)
        ,("=>",  ITdarrow,   always)

@@ -1548,7 +1556,8 @@ data PState = PState {
         -- Have we just had the '}' for a let block? If so, than an 'in'
         -- token doesn't need to close anything:
         alr_justClosedExplicitLetBlock :: Bool,
         -- Have we just had the '}' for a let block? If so, than an 'in'
         -- token doesn't need to close anything:
         alr_justClosedExplicitLetBlock :: Bool,

-        code_type_bracket_depth :: Int
+        code_type_bracket_depth       :: [CodeFlavor],
+        code_type_bracket_depth_stack :: [CodeFlavor]

      }
        -- last_loc and last_len are used when generating error messages,
        -- and in pushCurrentContext only.  Sigh, if only Happy passed the
      }
        -- last_loc and last_len are used when generating error messages,
        -- and in pushCurrentContext only.  Sigh, if only Happy passed the

@@ -1616,10 +1625,20 @@ setSrcLoc :: RealSrcLoc -> P ()
 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
 
 incrBracketDepth :: P ()
 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
 
 incrBracketDepth :: P ()

-incrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)+1}) ()
+incrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = LambdaFlavor:(code_type_bracket_depth s)}) ()
+incrBracketDepth1 :: P ()
+incrBracketDepth1 = P $ \s -> POk (s{code_type_bracket_depth = KappaFlavor:(code_type_bracket_depth s)}) ()

 decrBracketDepth :: P ()
 decrBracketDepth :: P ()

-decrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)-1}) ()
-getParserBrakDepth :: P Int
+decrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = tail (code_type_bracket_depth s)}) ()
+pushBracketDepth :: P ()
+pushBracketDepth = P $ \s -> POk (s{code_type_bracket_depth       = tail (code_type_bracket_depth s),
+                                    code_type_bracket_depth_stack = (head (code_type_bracket_depth s)):(code_type_bracket_depth_stack s)
+                                   }) ()
+popBracketDepth :: P ()
+popBracketDepth = P $ \s -> POk (s{code_type_bracket_depth       = (head (code_type_bracket_depth_stack s)):(code_type_bracket_depth s),
+                                   code_type_bracket_depth_stack = tail (code_type_bracket_depth_stack s)
+                                   }) ()
+getParserBrakDepth :: P [CodeFlavor]

 getParserBrakDepth = P $ \s -> POk s (code_type_bracket_depth s)
 
 getSrcLoc :: P RealSrcLoc
 getParserBrakDepth = P $ \s -> POk s (code_type_bracket_depth s)
 
 getSrcLoc :: P RealSrcLoc

@@ -1905,7 +1924,8 @@ mkPState flags buf loc =
       alr_context = [],
       alr_expecting_ocurly = Nothing,
       alr_justClosedExplicitLetBlock = False,
       alr_context = [],
       alr_expecting_ocurly = Nothing,
       alr_justClosedExplicitLetBlock = False,

-      code_type_bracket_depth = 0
+      code_type_bracket_depth = [],
+      code_type_bracket_depth_stack = []

     }
     where
       bitmap =     ffiBit            `setBitIf` xopt Opt_ForeignFunctionInterface flags
     }
     where
       bitmap =     ffiBit            `setBitIf` xopt Opt_ForeignFunctionInterface flags

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 1a847ec..bd93101 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -60,8 +60,10 @@ import Control.Monad    ( unless )
 import GHC.Exts
 import Data.Char
 import Control.Monad    ( mplus )
 import GHC.Exts
 import Data.Char
 import Control.Monad    ( mplus )

+

 }
 
 }
 

+

 {-
 -----------------------------------------------------------------------------
 24 Februar 2006
 {-
 -----------------------------------------------------------------------------
 24 Februar 2006

@@ -277,6 +279,7 @@ incorrect.
  '|'           { L _ ITvbar }
  '<-'          { L _ ITlarrow }
  '->'          { L _ ITrarrow }
  '|'           { L _ ITvbar }
  '<-'          { L _ ITlarrow }
  '->'          { L _ ITrarrow }

+ '~~>'         { L _ ITkappa }

  '@'           { L _ ITat }
  '~'           { L _ ITtilde }
  '=>'          { L _ ITdarrow }
  '@'           { L _ ITat }
  '~'           { L _ ITtilde }
  '=>'          { L _ ITdarrow }

@@ -307,6 +310,8 @@ incorrect.
  '|)'          { L _ ITcparenbar }
  '<['          { L _ ITopenBrak }
  ']>'          { L _ ITcloseBrak }
  '|)'          { L _ ITcparenbar }
  '<['          { L _ ITopenBrak }
  ']>'          { L _ ITcloseBrak }

+ '<{'          { L _ ITopenBrak1 }
+ '}>'          { L _ ITcloseBrak1 }

  '~~'          { L _ ITescape }
  '~~$'         { L _ ITescapeDollar }
  '%%'          { L _ ITdoublePercent }
  '~~'          { L _ ITescape }
  '~~$'         { L _ ITescapeDollar }
  '%%'          { L _ ITdoublePercent }

@@ -475,7 +480,8 @@ export      :: { LIE RdrName }
        |  oqtycon '(' ')'              { LL (IEThingWith (unLoc $1) []) }
        |  oqtycon '(' qcnames ')'      { LL (IEThingWith (unLoc $1) (reverse $3)) }
        |  'module' modid               { LL (IEModuleContents (unLoc $2)) }
        |  oqtycon '(' ')'              { LL (IEThingWith (unLoc $1) []) }
        |  oqtycon '(' qcnames ')'      { LL (IEThingWith (unLoc $1) (reverse $3)) }
        |  'module' modid               { LL (IEModuleContents (unLoc $2)) }

-        | '<[' incdepth export decdepth ']>' { $3 }
+        | '<[' incdepth  export decdepth ']>' { $3 }
+        | '<{' incdepth1 export decdepth '}>' { $3 }

 qcnames :: { [RdrName] }
        :  qcnames ',' qcname_ext       { unLoc $3 : $1 }
        |  qcname_ext                   { [unLoc $1]  }
 qcnames :: { [RdrName] }
        :  qcnames ',' qcname_ext       { unLoc $3 : $1 }
        |  qcname_ext                   { [unLoc $1]  }

@@ -1000,6 +1006,7 @@ type :: { LHsType RdrName }
         | btype qtyconop type           { LL $ HsOpTy $1 $2 $3 }
         | btype tyvarop  type          { LL $ HsOpTy $1 $2 $3 }
        | btype '->'     ctype          { LL $ HsFunTy $1 $3 }
         | btype qtyconop type           { LL $ HsOpTy $1 $2 $3 }
         | btype tyvarop  type          { LL $ HsOpTy $1 $2 $3 }
        | btype '->'     ctype          { LL $ HsFunTy $1 $3 }

+       | btype '~~>'    ctype          { LL $ HsKappaTy $1 $3 }

         | btype '~'      btype         { LL $ HsPredTy (HsEqualP $1 $3) }
 
 typedoc :: { LHsType RdrName }
         | btype '~'      btype         { LL $ HsPredTy (HsEqualP $1 $3) }
 
 typedoc :: { LHsType RdrName }

@@ -1025,7 +1032,7 @@ atype :: { LHsType RdrName }
        | '(' ctype ',' comma_types1 ')'  { LL $ HsTupleTy Boxed  ($2:$4) }
        | '(#' comma_types1 '#)'        { LL $ HsTupleTy Unboxed $2     }
        | '[' ctype ']'                 { LL $ HsListTy  $2 }
        | '(' ctype ',' comma_types1 ')'  { LL $ HsTupleTy Boxed  ($2:$4) }
        | '(#' comma_types1 '#)'        { LL $ HsTupleTy Unboxed $2     }
        | '[' ctype ']'                 { LL $ HsListTy  $2 }

-       | '<[' ctype ']>' '@' tyvar     { LL $ HsModalBoxType (unLoc $5) $2 }
+       | '<[' ctype ']>' '@' tyvar     { LL $ HsModalBoxType  (unLoc $5) $2 }

        | '[:' ctype ':]'               { LL $ HsPArrTy  $2 }
        | '(' ctype ')'                 { LL $ HsParTy   $2 }
        | '(' ctype '::' kind ')'       { LL $ HsKindSig $2 (unLoc $4) }
        | '[:' ctype ':]'               { LL $ HsPArrTy  $2 }
        | '(' ctype ')'                 { LL $ HsParTy   $2 }
        | '(' ctype '::' kind ')'       { LL $ HsKindSig $2 (unLoc $4) }

@@ -1271,8 +1278,11 @@ quasiquote :: { Located (HsQuasiQuote RdrName) }
                                 ; quoterId = mkUnqual varName quoter }
                             in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
 
                                 ; quoterId = mkUnqual varName quoter }
                             in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
 

-incdepth :: { Located () } :  {% do { incrBracketDepth ; return $ noLoc () } }
-decdepth :: { Located () } :  {% do { decrBracketDepth ; return $ noLoc () } }
+incdepth   :: { Located () } :  {% do { incrBracketDepth  ; return $ noLoc () } }
+incdepth1  :: { Located () } :  {% do { incrBracketDepth1 ; return $ noLoc () } }
+decdepth   :: { Located () } :  {% do { decrBracketDepth  ; return $ noLoc () } }
+pushdepth  :: { Located () } :  {% do { pushBracketDepth  ; return $ noLoc () } }
+popdepth   :: { Located () } :  {% do { popBracketDepth   ; return $ noLoc () } }

 
 
 exp   :: { LHsExpr RdrName }
 
 
 exp   :: { LHsExpr RdrName }

@@ -1282,7 +1292,7 @@ exp   :: { LHsExpr RdrName }
        | infixexp '-<<' exp            { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True }
        | infixexp '>>-' exp            { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False}
        | infixexp                      { $1 }
        | infixexp '-<<' exp            { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True }
        | infixexp '>>-' exp            { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False}
        | infixexp                      { $1 }

-       | '~~$' decdepth exp incdepth   { sL (comb2 $3 $>) (HsHetMetEsc placeHolderType placeHolderType $3) }
+       | '~~$' pushdepth exp popdepth  {% do { x <- mkHsHetMetEsc placeHolderType placeHolderType $3; return $ sL (comb2 $3 $>) x } }

 
 infixexp :: { LHsExpr RdrName }
        : exp10                         { $1 }
 
 infixexp :: { LHsExpr RdrName }
        : exp10                         { $1 }

@@ -1290,9 +1300,12 @@ infixexp :: { LHsExpr RdrName }
 
 exp10 :: { LHsExpr RdrName }
        : '\\' apat apats opt_asig '->' exp     
 
 exp10 :: { LHsExpr RdrName }
        : '\\' apat apats opt_asig '->' exp     

-                       { LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4
-                                                               (unguardedGRHSs $6)
-                                                           ]) }
+                       {% do { x <- getParserBrakDepth
+                              ; return
+                                  $ case x of
+                                   KappaFlavor:_ -> LL $ HsKappa (mkMatchGroup[LL $ Match ($2:$3) $4 (unguardedGRHSs $6) ])
+                                   _             -> LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4 (unguardedGRHSs $6) ])
+                              } }

        | 'let' binds 'in' exp                  { LL $ HsLet (unLoc $2) $4 }
        | 'if' exp optSemi 'then' exp optSemi 'else' exp
                                         {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
        | 'let' binds 'in' exp                  { LL $ HsLet (unLoc $2) $4 }
        | 'if' exp optSemi 'then' exp optSemi 'else' exp
                                         {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>

@@ -1342,7 +1355,12 @@ hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) }
                                                 }
 
 fexp   :: { LHsExpr RdrName }
                                                 }
 
 fexp   :: { LHsExpr RdrName }

-       : fexp aexp                             { LL $ HsApp $1 $2 }
+       : fexp aexp                             {% do { x <- getParserBrakDepth
+                                                      ; return $ case x of 
+                                                                   []             -> LL $ HsApp $1 $2
+                                                                   LambdaFlavor:_ -> LL $ HsApp $1 $2
+                                                                   KappaFlavor:_  -> LL $ HsKappaApp $1 $2
+                                                      } }

        | aexp                                  { $1 }
 
 aexp   :: { LHsExpr RdrName }
        | aexp                                  { $1 }
 
 aexp   :: { LHsExpr RdrName }

@@ -1409,9 +1427,10 @@ aexp2    :: { LHsExpr RdrName }
        | '(|' aexp2 cmdargs '|)'       { LL $ HsArrForm $2 Nothing (reverse $3) }
 
        -- code type notation extension
        | '(|' aexp2 cmdargs '|)'       { LL $ HsArrForm $2 Nothing (reverse $3) }
 
        -- code type notation extension

-       | '<[' incdepth exp  decdepth ']>'      { sL (comb2 $3 $>) (HsHetMetBrak placeHolderType                 $3) }
-       | '~~' decdepth aexp incdepth           { sL (comb2 $3 $>) (HsHetMetEsc  placeHolderType placeHolderType $3) }
-       | '%%' decdepth aexp incdepth           { sL (comb2 $3 $>) (HsHetMetCSP  placeHolderType                 $3) }
+       | '<[' incdepth  exp  decdepth ']>'     { sL (comb2 $3 $>) (HsHetMetBrak  placeHolderType                 $3) }
+       | '<{' incdepth1 exp  decdepth '}>'     { sL (comb2 $3 $>) (HsHetMetBrak  placeHolderType                 $3) }
+       | '~~' pushdepth aexp popdepth          {% do { x <- mkHsHetMetEsc placeHolderType placeHolderType $3; return $ sL (comb2 $3 $>) x } }
+       | '%%' pushdepth aexp popdepth          { sL (comb2 $3 $>) (HsHetMetCSP   placeHolderType                 $3) }

 
 cmdargs        :: { [LHsCmdTop RdrName] }
        : cmdargs acmd                  { $2 : $1 }
 
 cmdargs        :: { [LHsCmdTop RdrName] }
        : cmdargs acmd                  { $2 : $1 }

@@ -1846,7 +1865,7 @@ qvarid :: { Located RdrName }
         | PREFIXQVARSYM         { L1 $! mkQual varName (getPREFIXQVARSYM $1) }
 
 varid :: { Located RdrName }
         | PREFIXQVARSYM         { L1 $! mkQual varName (getPREFIXQVARSYM $1) }
 
 varid :: { Located RdrName }

-       : VARID                 {% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth depth) (getVARID $1)) } }
+       : VARID                 {% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth $ length depth) (getVARID $1)) } }

        | special_id            { L1 $! mkUnqual varName (unLoc $1) }
        | 'unsafe'              { L1 $! mkUnqual varName (fsLit "unsafe") }
        | 'safe'                { L1 $! mkUnqual varName (fsLit "safe") }
        | special_id            { L1 $! mkUnqual varName (unLoc $1) }
        | 'unsafe'              { L1 $! mkUnqual varName (fsLit "unsafe") }
        | 'safe'                { L1 $! mkUnqual varName (fsLit "safe") }

@@ -1872,9 +1891,9 @@ varsym :: { Located RdrName }
 
 varsym_no_minus :: { Located RdrName } -- varsym not including '-'
        : VARSYM                {% do { depth <- getParserBrakDepth
 
 varsym_no_minus :: { Located RdrName } -- varsym not including '-'
        : VARSYM                {% do { depth <- getParserBrakDepth

-                                      ; return (L1 $! mkUnqual (varNameDepth depth) (getVARSYM $1)) } }
+                                      ; return (L1 $! mkUnqual (varNameDepth $ length depth) (getVARSYM $1)) } }

        | special_sym           {% do { depth <- getParserBrakDepth
        | special_sym           {% do { depth <- getParserBrakDepth

-                                      ; return (L1 $! mkUnqual (varNameDepth depth) (unLoc $1)) } }
+                                      ; return (L1 $! mkUnqual (varNameDepth $ length depth) (unLoc $1)) } }

 
 -- These special_ids are treated as keywords in various places, 
 -- but as ordinary ids elsewhere.   'special_id' collects all these
 
 -- These special_ids are treated as keywords in various places, 
 -- but as ordinary ids elsewhere.   'special_id' collects all these

@@ -2055,4 +2074,12 @@ fileSrcSpan = do
   l <- getSrcLoc; 
   let loc = mkSrcLoc (srcLocFile l) 1 1;
   return (mkSrcSpan loc loc)
   l <- getSrcLoc; 
   let loc = mkSrcLoc (srcLocFile l) 1 1;
   return (mkSrcSpan loc loc)

+
+mkHsHetMetEsc a b c = do { depth <- getParserBrakDepth
+                         ; return $ case head depth of
+                                    { LambdaFlavor -> HsHetMetEsc  a b c
+                                    ; KappaFlavor  -> HsHetMetEsc  a b c
+                                    }
+                         }
+

 }
 }

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 0e265e9..8c14214 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -122,6 +122,7 @@ extract_lty (L loc ty) acc
       HsAppTy ty1 ty2                  -> extract_lty ty1 (extract_lty ty2 acc)
       HsListTy ty                      -> extract_lty ty acc
       HsPArrTy ty                      -> extract_lty ty acc
       HsAppTy ty1 ty2                  -> extract_lty ty1 (extract_lty ty2 acc)
       HsListTy ty                      -> extract_lty ty acc
       HsPArrTy ty                      -> extract_lty ty acc

+      HsKappaTy ty1 ty2        -> extract_lty ty1 (extract_lty ty2 acc)

       HsModalBoxType ecn ty    -> extract_lty ty (extract_tv loc ecn acc)
       HsTupleTy _ tys                  -> extract_ltys tys acc
       HsFunTy ty1 ty2                  -> extract_lty ty1 (extract_lty ty2 acc)
       HsModalBoxType ecn ty    -> extract_lty ty (extract_tv loc ecn acc)
       HsTupleTy _ tys                  -> extract_ltys tys acc
       HsFunTy ty1 ty2                  -> extract_lty ty1 (extract_lty ty2 acc)

@@ -647,7 +648,7 @@ checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
 checkAPat dynflags loc e0 = case e0 of
    EWildPat -> return (WildPat placeHolderType)
    HsVar x  -> return (VarPat x)
 checkAPat dynflags loc e0 = case e0 of
    EWildPat -> return (WildPat placeHolderType)
    HsVar x  -> return (VarPat x)

-   HsHetMetBrak _ p -> checkAPat dynflags loc (unLoc p)
+   HsHetMetBrak  _ p -> checkAPat dynflags loc (unLoc p)

    HsLit l  -> return (LitPat l)
 
    -- Overloaded numeric patterns (e.g. f 0 x = x)
    HsLit l  -> return (LitPat l)
 
    -- Overloaded numeric patterns (e.g. f 0 x = x)

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index eaa3e8a..9206ad5 100644 (file)
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -215,6 +215,7 @@ basicKnownKeyNames
 
         -- Code types
         hetmet_brak_name, hetmet_esc_name, hetmet_csp_name,
 
         -- Code types
         hetmet_brak_name, hetmet_esc_name, hetmet_csp_name,

+        hetmet_kappa_name, hetmet_kappa_app_name,

         hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name, hetmet_guest_char_literal_name,
 
         -- Annotation type checking
         hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name, hetmet_guest_char_literal_name,
 
         -- Annotation type checking

@@ -894,10 +895,13 @@ appPName            pkg = varQual (gHC_PARR pkg) (fsLit "+:+")             appPI
 
 -- code type things
 hetmet_brak_name, hetmet_esc_name, hetmet_csp_name :: Name
 
 -- code type things
 hetmet_brak_name, hetmet_esc_name, hetmet_csp_name :: Name

+hetmet_kappa_name, hetmet_kappa_app_name :: Name

 hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name, hetmet_guest_char_literal_name :: Name
 hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name, hetmet_guest_char_literal_name :: Name

-hetmet_brak_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_brak") hetmet_brak_key
-hetmet_esc_name  = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_esc")  hetmet_esc_key
-hetmet_csp_name  = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_csp") hetmet_csp_key
+hetmet_brak_name  = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_brak") hetmet_brak_key
+hetmet_esc_name   = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_esc")  hetmet_esc_key
+hetmet_csp_name   = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_csp") hetmet_csp_key
+hetmet_kappa_name   = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_kappa")  hetmet_kappa_key
+hetmet_kappa_app_name   = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_kappa_app")  hetmet_kappa_app_key

 hetmet_guest_integer_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "guestIntegerLiteral") hetmet_guest_integer_literal_key
 hetmet_guest_string_literal_name  = varQual gHC_HETMET_CODETYPES (fsLit "guestStringLiteral")  hetmet_guest_string_literal_key
 hetmet_guest_char_literal_name    = varQual gHC_HETMET_CODETYPES (fsLit "guestCharLiteral")    hetmet_guest_char_literal_key
 hetmet_guest_integer_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "guestIntegerLiteral") hetmet_guest_integer_literal_key
 hetmet_guest_string_literal_name  = varQual gHC_HETMET_CODETYPES (fsLit "guestStringLiteral")  hetmet_guest_string_literal_key
 hetmet_guest_char_literal_name    = varQual gHC_HETMET_CODETYPES (fsLit "guestCharLiteral")    hetmet_guest_char_literal_key

@@ -1517,16 +1521,20 @@ mzipIdKey       = mkPreludeMiscIdUnique 134
 -- code types
 hetMetCodeTypeTyConKey :: Unique
 hetMetCodeTypeTyConKey                 = mkPreludeTyConUnique 135
 -- code types
 hetMetCodeTypeTyConKey :: Unique
 hetMetCodeTypeTyConKey                 = mkPreludeTyConUnique 135

+hetMetKappaTyConKey :: Unique
+hetMetKappaTyConKey                    = mkPreludeTyConUnique 137

 
 hetmet_guest_integer_literal_key, hetmet_guest_string_literal_key, hetmet_guest_char_literal_key :: Unique
 
 hetmet_guest_integer_literal_key, hetmet_guest_string_literal_key, hetmet_guest_char_literal_key :: Unique

-hetmet_guest_integer_literal_key = mkPreludeMiscIdUnique 134
-hetmet_guest_string_literal_key  = mkPreludeMiscIdUnique 135
-hetmet_guest_char_literal_key    = mkPreludeMiscIdUnique 136
+hetmet_guest_integer_literal_key = mkPreludeMiscIdUnique 138
+hetmet_guest_string_literal_key  = mkPreludeMiscIdUnique 139
+hetmet_guest_char_literal_key    = mkPreludeMiscIdUnique 140

 
 hetmet_brak_key, hetmet_esc_key, hetmet_csp_key :: Unique
 
 hetmet_brak_key, hetmet_esc_key, hetmet_csp_key :: Unique

-hetmet_brak_key    = mkPreludeMiscIdUnique 161
-hetmet_esc_key     = mkPreludeMiscIdUnique 162
-hetmet_csp_key     = mkPreludeMiscIdUnique 163
+hetmet_brak_key    = mkPreludeMiscIdUnique 141
+hetmet_esc_key     = mkPreludeMiscIdUnique 143
+hetmet_csp_key     = mkPreludeMiscIdUnique 145
+hetmet_kappa_key   = mkPreludeMiscIdUnique 146
+hetmet_kappa_app_key   = mkPreludeMiscIdUnique 147

 
 
 ---------------- Template Haskell -------------------
 
 
 ---------------- Template Haskell -------------------

diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index bc45028..e420d7b 100644 (file)
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -50,9 +50,16 @@ module TysWiredIn (
         -- * Heterogeneous Metaprogramming
        mkHetMetCodeTypeTy,
         hetMetCodeTypeTyConName,
         -- * Heterogeneous Metaprogramming
        mkHetMetCodeTypeTy,
         hetMetCodeTypeTyConName,

-       hetMetCodeTypeTyCon,     isHetMetCodeTypeTyCon,
+       hetMetCodeTypeTyCon,
+        isHetMetCodeTypeTyCon,

        hetMetCodeTypeTyCon_RDR,
 
        hetMetCodeTypeTyCon_RDR,
 

+       mkHetMetKappaTy,
+        hetMetKappaTyConName,
+       hetMetKappaTyCon,
+       hetMetKappaTyCon_RDR,
+        isHetMetKappaTyCon,
+

         -- * Parallel arrays
        mkPArrTy,
        parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon,
         -- * Parallel arrays
        mkPArrTy,
        parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon,

@@ -122,6 +129,7 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because
              , listTyCon
              , parrTyCon
              , hetMetCodeTypeTyCon
              , listTyCon
              , parrTyCon
              , hetMetCodeTypeTyCon

+             , hetMetKappaTyCon

              ]
 \end{code}
 
              ]
 \end{code}
 

@@ -172,8 +180,12 @@ hetMetCodeTypeDataConName :: Name
 hetMetCodeTypeDataConName      =
     mkWiredInDataConName  BuiltInSyntax gHC_HETMET_CODETYPES (fsLit "<[]>")      hetMetCodeTypeDataConKey hetMetCodeTypeDataCon
 
 hetMetCodeTypeDataConName      =
     mkWiredInDataConName  BuiltInSyntax gHC_HETMET_CODETYPES (fsLit "<[]>")      hetMetCodeTypeDataConKey hetMetCodeTypeDataCon
 

+hetMetKappaTyConName :: Name
+hetMetKappaTyConName = mkWiredInTyConName   BuiltInSyntax gHC_HETMET_CODETYPES (fsLit "~~>")  hetMetKappaTyConKey hetMetKappaTyCon
+

 boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR,
 boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR,

-    intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, hetMetCodeTypeTyCon_RDR :: RdrName
+    intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, hetMetCodeTypeTyCon_RDR,
+    hetMetKappaTyCon_RDR :: RdrName

 boolTyCon_RDR   = nameRdrName boolTyConName
 false_RDR      = nameRdrName falseDataConName
 true_RDR       = nameRdrName trueDataConName
 boolTyCon_RDR   = nameRdrName boolTyConName
 false_RDR      = nameRdrName falseDataConName
 true_RDR       = nameRdrName trueDataConName

@@ -184,6 +196,7 @@ listTyCon_RDR       = nameRdrName listTyConName
 consDataCon_RDR = nameRdrName consDataConName
 parrTyCon_RDR  = nameRdrName parrTyConName
 hetMetCodeTypeTyCon_RDR        = nameRdrName hetMetCodeTypeTyConName
 consDataCon_RDR = nameRdrName consDataConName
 parrTyCon_RDR  = nameRdrName parrTyConName
 hetMetCodeTypeTyCon_RDR        = nameRdrName hetMetCodeTypeTyConName

+hetMetKappaTyCon_RDR = nameRdrName hetMetKappaTyConName

 \end{code}
 
 
 \end{code}
 
 

@@ -614,16 +627,25 @@ Heterogeneous Metaprogramming
 mkHetMetCodeTypeTy    :: TyVar -> Type -> Type
 mkHetMetCodeTypeTy ecn ty = mkTyConApp hetMetCodeTypeTyCon [(mkTyVarTy ecn), ty]
 
 mkHetMetCodeTypeTy    :: TyVar -> Type -> Type
 mkHetMetCodeTypeTy ecn ty = mkTyConApp hetMetCodeTypeTyCon [(mkTyVarTy ecn), ty]
 

+mkHetMetKappaTy    :: Type -> Type -> Type
+mkHetMetKappaTy a b = mkTyConApp hetMetKappaTyCon [a, b]
+

 ecTyVar = head ecTyVars
 
 -- | Represents the type constructor of box types
 hetMetCodeTypeTyCon :: TyCon
 hetMetCodeTypeTyCon  = pcNonRecDataTyCon hetMetCodeTypeTyConName [ecTyVar, betaTyVar] [hetMetCodeTypeDataCon]
 
 ecTyVar = head ecTyVars
 
 -- | Represents the type constructor of box types
 hetMetCodeTypeTyCon :: TyCon
 hetMetCodeTypeTyCon  = pcNonRecDataTyCon hetMetCodeTypeTyConName [ecTyVar, betaTyVar] [hetMetCodeTypeDataCon]
 

+hetMetKappaTyCon :: TyCon
+hetMetKappaTyCon  = pcNonRecDataTyCon hetMetKappaTyConName [alphaTyVar, betaTyVar] []
+

 -- | Check whether a type constructor is the constructor for box types
 isHetMetCodeTypeTyCon    :: TyCon -> Bool
 isHetMetCodeTypeTyCon tc  = tyConName tc == hetMetCodeTypeTyConName
 
 -- | Check whether a type constructor is the constructor for box types
 isHetMetCodeTypeTyCon    :: TyCon -> Bool
 isHetMetCodeTypeTyCon tc  = tyConName tc == hetMetCodeTypeTyConName
 

+isHetMetKappaTyCon    :: TyCon -> Bool
+isHetMetKappaTyCon tc  = tyConName tc == hetMetKappaTyConName
+

 hetMetCodeTypeDataCon :: DataCon
 hetMetCodeTypeDataCon  = pcDataCon 
                 hetMetCodeTypeDataConName 
 hetMetCodeTypeDataCon :: DataCon
 hetMetCodeTypeDataCon  = pcDataCon 
                 hetMetCodeTypeDataConName 

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 9b1f08e..35300e0 100644 (file)
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -177,6 +177,13 @@ rnExpr (HsHetMetCSP c e)
   = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e
        ; return (HsHetMetCSP c e', fv_e)
        }
   = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e
        ; return (HsHetMetCSP c e', fv_e)
        }

+rnExpr (HsKappa matches)
+  = rnMatchGroup LambdaExpr matches    `thenM` \ (matches', fvMatch) ->
+    return (HsKappa matches', fvMatch)
+rnExpr (HsKappaApp fun arg)
+  = rnLExpr fun                `thenM` \ (fun',fvFun) ->
+    rnLExpr arg                `thenM` \ (arg',fvArg) ->
+    return (HsKappaApp fun' arg', fvFun `plusFV` fvArg)

 
     
 
 
     
 

diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs
index f4fdc3b..9e6cb9d 100644 (file)
--- a/compiler/rename/RnHsSyn.lhs
+++ b/compiler/rename/RnHsSyn.lhs
@@ -39,7 +39,7 @@ charTyCon_name    = getName charTyCon
 listTyCon_name    = getName listTyCon
 parrTyCon_name    = getName parrTyCon
 hetMetCodeTypeTyCon_name :: Name
 listTyCon_name    = getName listTyCon
 parrTyCon_name    = getName parrTyCon
 hetMetCodeTypeTyCon_name :: Name

-hetMetCodeTypeTyCon_name = getName hetMetCodeTypeTyCon
+hetMetCodeTypeTyCon_name  = getName hetMetCodeTypeTyCon

 
 tupleTyCon_name :: Boxity -> Int -> Name
 tupleTyCon_name boxity n = getName (tupleTyCon boxity n)
 
 tupleTyCon_name :: Boxity -> Int -> Name
 tupleTyCon_name boxity n = getName (tupleTyCon boxity n)

@@ -59,7 +59,12 @@ extractHsTyNames ty
     get (HsAppTy ty1 ty2)      = getl ty1 `unionNameSets` getl ty2
     get (HsListTy ty)          = unitNameSet listTyCon_name `unionNameSets` getl ty
     get (HsPArrTy ty)          = unitNameSet parrTyCon_name `unionNameSets` getl ty
     get (HsAppTy ty1 ty2)      = getl ty1 `unionNameSets` getl ty2
     get (HsListTy ty)          = unitNameSet listTyCon_name `unionNameSets` getl ty
     get (HsPArrTy ty)          = unitNameSet parrTyCon_name `unionNameSets` getl ty

-    get (HsModalBoxType ecn ty) = (unitNameSet ecn) `unionNameSets` (unitNameSet hetMetCodeTypeTyCon_name) `unionNameSets` (getl ty)
+    get (HsModalBoxType  ecn ty) = (unitNameSet ecn)
+                                   `unionNameSets`
+                                   (unitNameSet hetMetCodeTypeTyCon_name)
+                                   `unionNameSets`
+                                   (getl ty)
+    get (HsKappaTy ty1 ty2)    = getl ty1 `unionNameSets` getl ty2

     get (HsTupleTy _ tys)      = extractHsTyNames_s tys
     get (HsFunTy ty1 ty2)      = getl ty1 `unionNameSets` getl ty2
     get (HsPredTy p)           = extractHsPredTyNames p
     get (HsTupleTy _ tys)      = extractHsTyNames_s tys
     get (HsFunTy ty1 ty2)      = getl ty1 `unionNameSets` getl ty2
     get (HsPredTy p)           = extractHsPredTyNames p

diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 31382c2..88e3e26 100644 (file)
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -168,6 +168,11 @@ rnHsType doc (HsModalBoxType ecn ty) = do
     ty' <- rnLHsType doc ty
     return (HsModalBoxType ecn' ty')
 
     ty' <- rnLHsType doc ty
     return (HsModalBoxType ecn' ty')
 

+rnHsType doc (HsKappaTy ty1 ty2) = do
+    ty1' <- rnLHsType doc ty1
+    ty2' <- rnLHsType doc ty2
+    return $ HsKappaTy ty1' ty2'
+

 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 rnHsType doc (HsTupleTy tup_con tys) = do
 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 rnHsType doc (HsTupleTy tup_con tys) = do

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 70592af..86e8f09 100644 (file)
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -186,6 +186,26 @@ tcExpr (HsHetMetCSP _ e) res_ty =
                    $ tcExpr (unLoc e) res_ty
        ; return $ HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr') }
 
                    $ tcExpr (unLoc e) res_ty
        ; return $ HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr') }
 

+tcExpr (HsKappa  match) res_ty =
+    do { v1 <- newFlexiTyVar liftedTypeKind
+        ; v2 <- newFlexiTyVar liftedTypeKind
+        ; v3 <- newFlexiTyVar liftedTypeKind
+        ; (_, [ty_ab, ty_c]) <- matchExpectedTyConApp hetMetKappaTyCon res_ty
+        ; (_, [ty_a,  ty_b]) <- matchExpectedTyConApp pairTyCon ty_ab
+        ; (co_fn, match') <- tcMatchLambda match (mkFunTy
+                                                     (mkHetMetKappaTy unitTy ty_a)
+                                                     (mkHetMetKappaTy ty_b ty_c))
+       ; return (HsKappa match') }
+
+tcExpr (HsKappaApp e1 e2) res_ty =
+    do { v1 <- newFlexiTyVar liftedTypeKind
+        ; v2 <- newFlexiTyVar liftedTypeKind
+        ; v3 <- newFlexiTyVar liftedTypeKind
+        ; e1' <- tcExpr (unLoc e1) (mkHetMetKappaTy (mkTyConApp pairTyCon [(TyVarTy v1), (TyVarTy v2)]) (TyVarTy v3))
+        ; e2' <- tcExpr (unLoc e2) (mkHetMetKappaTy unitTy (TyVarTy v1))
+        ; unifyType res_ty (mkHetMetKappaTy (TyVarTy v2) (TyVarTy v3))
+       ; return (HsKappaApp (noLoc e1') (noLoc e2')) }
+

 tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
 
 tcExpr (HsLit lit)   res_ty =
 tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
 
 tcExpr (HsLit lit)   res_ty =

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 6ba78d9..5ce40fc 100644 (file)
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -562,6 +562,17 @@ zonkExpr env (HsHetMetCSP c e)
        e' <- zonkLExpr env e
        return (HsHetMetCSP c' e')
 
        e' <- zonkLExpr env e
        return (HsHetMetCSP c' e')
 

+zonkExpr env (HsKappa matches)
+  = do { matches' <- zonkMatchGroup env matches
+       ; returnM (HsKappa matches')
+       }
+
+zonkExpr env (HsKappaApp e1 e2)
+  = do { e1' <- zonkLExpr env e1
+       ; e2' <- zonkLExpr env e2
+       ; returnM (HsKappaApp e1' e2')
+       }
+

 zonkExpr env (SectionL expr op)
   = zonkLExpr env expr `thenM` \ new_expr ->
     zonkLExpr env op           `thenM` \ new_op ->
 zonkExpr env (SectionL expr op)
   = zonkLExpr env expr `thenM` \ new_expr ->
     zonkLExpr env op           `thenM` \ new_op ->

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index f826e72..4fe6b60 100644 (file)
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -370,6 +370,11 @@ kc_hs_type (HsModalBoxType ecn ty) = do
     ty' <- kcLiftedType ty
     return (HsModalBoxType ecn ty', liftedTypeKind)
 
     ty' <- kcLiftedType ty
     return (HsModalBoxType ecn ty', liftedTypeKind)
 

+kc_hs_type (HsKappaTy ty1 ty2) = do
+    ty1' <- kc_check_lhs_type ty1 (EK argTypeKind EkUnk)
+    ty2' <- kcTypeType ty2
+    return (HsKappaTy ty1' ty2', liftedTypeKind)
+

 kc_hs_type (HsKindSig ty k) = do
     ty' <- kc_check_lhs_type ty (EK k EkKindSig)
     return (HsKindSig ty' k, k)
 kc_hs_type (HsKindSig ty k) = do
     ty' <- kc_check_lhs_type ty (EK k EkKindSig)
     return (HsKindSig ty' k, k)

@@ -581,6 +586,11 @@ ds_type (HsModalBoxType ecn ty) = do
     checkWiredInTyCon hetMetCodeTypeTyCon
     return (mkHetMetCodeTypeTy (mkTyVar ecn ecKind) tau_ty)
 
     checkWiredInTyCon hetMetCodeTypeTyCon
     return (mkHetMetCodeTypeTy (mkTyVar ecn ecKind) tau_ty)
 

+ds_type (HsKappaTy ty1 ty2) = do
+    tau_ty1 <- dsHsType ty1
+    tau_ty2 <- dsHsType ty2
+    return (mkHetMetKappaTy tau_ty1 tau_ty2)
+

 ds_type (HsTupleTy boxity tys) = do
     tau_tys <- dsHsTypes tys
     checkWiredInTyCon tycon
 ds_type (HsTupleTy boxity tys) = do
     tau_tys <- dsHsTypes tys
     checkWiredInTyCon tycon

diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 4f0e9d8..ec20914 100644 (file)
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -652,6 +652,9 @@ pprTcApp p pp tc tys
   | isTupleTyCon tc && tyConArity tc == length tys
   = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map (pp TopPrec) tys)))
 
   | isTupleTyCon tc && tyConArity tc == length tys
   = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map (pp TopPrec) tys)))
 

+  | tc `hasKey` hetMetKappaTyConKey, [ty1,ty2] <- tys
+  = pp TopPrec ty1 <> ptext (sLit "~~>") <> pp TopPrec ty2
+

   | tc `hasKey` hetMetCodeTypeTyConKey, [ty1,ty2] <- tys
   = ptext (sLit "<[") <> pp TopPrec ty2 <> ptext (sLit "]>@") <> pp TopPrec ty1
 
   | tc `hasKey` hetMetCodeTypeTyConKey, [ty1,ty2] <- tys
   = ptext (sLit "<[") <> pp TopPrec ty2 <> ptext (sLit "]>@") <> pp TopPrec ty1