Make _ a keyword in Grin. Fix related problems in MemberSelect.

UU-ComputerScience · May 26, 2009 · bde5891 · bde5891
1 parent 01965ef
commit bde5891
Show file tree

Hide file tree

Showing 6 changed files with 20 additions and 15 deletions.
diff --git a/src/ehc/GrinCode/Parser.chs b/src/ehc/GrinCode/Parser.chs
@@ -130,15 +130,12 @@ pGrBindAnn      =    pSucceed GrBindAnnNormal
                 <|>  GrBindAnnSpecialized <$
                        pKey "SPECIALIZED" <*> pGrNm <*> pInt <*> pCurlyList pMbGrNm
 
--- TODO O jee: DICTOVERLOADED{-1} clasht met commentaarsyntax {- ... -}
 pCurlyList      ::   GRIParser a -> GRIParser [a]
 pCurlyList p    =    pCurly $ pListSep pComma p
 
--- TODO niet een vieze hack gebruiken voor _
 pMbGrNm         ::   GRIParser (Maybe HsName)
-pMbGrNm         =    f <$> pGrNm
-  where f n | show n == "_" = Nothing
-            | otherwise     = Just n
+pMbGrNm         =    Just    <$> pGrNm
+                <|>  Nothing <$  pKey "_"
 
 pPatLam         ::   GRIParser GrPatLam
 pPatLam         =    GrPatLam_Var      <$> pGrNm
@@ -156,8 +153,9 @@ pPatLam         =    GrPatLam_Var      <$> pGrNm
                         )
 
 pPatAlt         ::   GRIParser GrPatAlt
-pPatAlt         =    GrPatAlt_LitInt   <$> pInt
-                <|>  GrPatAlt_Tag      <$> pTag
+pPatAlt         =    GrPatAlt_LitInt    <$> pInt
+                <|>  GrPatAlt_Tag       <$> pTag
+                <|>  GrPatAlt_Otherwise <$  pKey "_"
                 <|>  pParens
                         (    pTag
                              <**>  (pGrNm
@@ -193,7 +191,7 @@ pBasicAnnot     =    BasicAnnot_Size          <$> pBasicSize <*> pBasicTy
 
 pTag            ::   GRIParser GrTag
 pTag            =    pKey "#"
-                     *>  (   (\i c n -> c i n) <$> pInt <* pKey "/" <*> pTagCateg <* pKey "/" <*> pGrNm
+                     *>  (   (\i c n -> c i n) <$> pInt <* pKey "/" <*> pTagCateg <* pKey "/" <*> ((undefined <$ pKey "_") <|> pGrNm)
                          <|> GrTag_Unboxed <$ pKey "U"
                          <|> GrTag_Any     <$ pKey "*"
                          )

diff --git a/src/ehc/GrinCode/Pretty.cag b/src/ehc/GrinCode/Pretty.cag
@@ -110,6 +110,9 @@ ppCurlysSemisV :: [PP_Doc] -> PP_Doc
 ppCurlysSemisV pL = vlist pL
 %%]]
 
+ppCurlyList :: (a -> PP_Doc) -> [a] -> PP_Doc
+ppCurlyList pL xs = ppListSep "{ " " }" ", " $ map pL xs
+
 ppGrAltAnn :: GrAltAnn -> PP_Doc
 ppGrAltAnn GrAltAnnNormal         = pp ""
 ppGrAltAnn GrAltAnnIdent          = pp "ident "
@@ -118,10 +121,10 @@ ppGrAltAnn GrAltAnnReenter        = pp "reenter "
 
 ppGrBindAnn :: PPGrNm -> GrBindAnn -> PP_Doc
 ppGrBindAnn _      GrBindAnnNormal            = pp ""
-ppGrBindAnn ppGrNm (GrBindAnnClass xs)        = pp "DICTCLASS"       >|<  ppCurlysCommasWith (ppMbGrNm ppGrNm) xs
-ppGrBindAnn ppGrNm (GrBindAnnInstance xs)     = pp "DICTINSTANCE"    >|<  ppCurlysCommasWith (ppMbGrNm ppGrNm) xs
-ppGrBindAnn _      (GrBindAnnOverloaded xs)   = pp "DICTOVERLOADED"  >|<  ppCurlysCommasWith ppInt xs
-ppGrBindAnn ppGrNm (GrBindAnnSpecialized nm i xs)  = pp "SPECIALIZED"  >#< (ppGrNm nm) >#< show i >#<  ppCurlysCommasWith (ppMbGrNm ppGrNm) xs
+ppGrBindAnn ppGrNm (GrBindAnnClass xs)        = pp "DICTCLASS"       >|<  ppCurlyList (ppMbGrNm ppGrNm) xs
+ppGrBindAnn ppGrNm (GrBindAnnInstance xs)     = pp "DICTINSTANCE"    >|<  ppCurlyList (ppMbGrNm ppGrNm) xs
+ppGrBindAnn _      (GrBindAnnOverloaded xs)   = pp "DICTOVERLOADED"  >|<  ppCurlyList ppInt xs
+ppGrBindAnn ppGrNm (GrBindAnnSpecialized nm i xs)  = pp "SPECIALIZED"  >#< (ppGrNm nm) >#< show i >#<  ppCurlyList (ppMbGrNm ppGrNm) xs
 
 ppMbGrNm :: PPGrNm -> Maybe HsName -> PP_Doc
 ppMbGrNm ppGrNm = maybe (ppGrNm (hsnFromString "_")) ppGrNm

diff --git a/src/ehc/GrinCode/Trf/DropUnreachableBindings.cag b/src/ehc/GrinCode/Trf/DropUnreachableBindings.cag
@@ -142,7 +142,7 @@ ATTR GrBind GrGlobal
 SEM GrModule
   | Mod  loc   . mainfn   =  if @lhs.numbered then mainNr else hsnMain
          -- loc   . lifeList =  reachable @graph (maybe (error (show @loc.mainfn ++ " not found in " ++ show @globalL.genEnv) ) id (Map.lookup @loc.mainfn @globalL.genEnv))
-         loc   . lifeList =  reachable @graph (maybe (error (show @loc.mainfn ++ " not found in " ++ show @loc.bothEnv) ) id (Map.lookup @loc.mainfn @loc.bothEnv))
+         loc   . lifeList =  reachable @graph (maybe (error ("DropUnreachableBindings: " ++ show @loc.mainfn ++ " not found in " ++ show @loc.bothEnv) ) id (Map.lookup @loc.mainfn @loc.bothEnv))
                . lifeSet  =  Set.fromList @loc.lifeList
 
 SEM GrBind

diff --git a/src/ehc/GrinCode/Trf/MemberSelect.cag b/src/ehc/GrinCode/Trf/MemberSelect.cag
@@ -35,6 +35,8 @@ by
 %%]
 %%[(8 codegen grin) hs import(qualified Data.Map as Map, Data.Maybe)
 %%]
+%%[(8 codegen grin) hs import(Control.Monad(when))
+%%]
 %%[(8 codegen grin) hs import(Debug.Trace)
 %%]
 
@@ -96,9 +98,10 @@ SEM GrExpr
                                id
                                (do
                                 { f <- @expr.storedSelectedFunction
+                                ; when (show f == "_") Nothing
                                 ; (ps,pat,rest) <- @body.seqStoredApplyRest
                                 ; let j = length ps
-                                ; let node = Map.findWithDefault (error (show f ++ " not found in " ++ show @lhs.allGlobs)) f @lhs.allGlobs
+                                ; let node = Map.findWithDefault (error ("MemberSelect: " ++ show f ++ " not found in " ++ show @lhs.allGlobs)) f @lhs.allGlobs
                                 ; let node2 = case node of (GrVal_Node (GrTag_PApp i g) qs) -> node
                                                            (GrVal_Node (GrTag_Fun f)    qs) -> GrVal_Node (GrTag_PApp 0 f) qs
                                                            _                                -> error (show f ++ " is not a PApp but a " ++ show node ++ " while pat is " ++ show pat)

diff --git a/src/ehc/GrinCode/Trf/NumberIdents.cag b/src/ehc/GrinCode/Trf/NumberIdents.cag
@@ -51,7 +51,7 @@ Haskell datatype NameMapping and utility functions for it
 %%[(8 codegen grin) hs
 type NameMapping = Map.Map HsName HsName
 
-findNewVar fm e  = Map.findWithDefault (trace (show e ++ " not found in " ++ show fm) e) e fm
+findNewVar fm e  = Map.findWithDefault (trace ("NumberIdents.findNewVar: " ++ show e ++ " not found in " ++ show fm) e) e fm
 
 
 -- numbers the non-wildcard variables in xs, counting from left-to-right (because that is needed when numbering argument lists)

diff --git a/src/ehc/Scanner/Common.chs b/src/ehc/Scanner/Common.chs
@@ -276,6 +276,7 @@ grinScanOpts
                                         , "annotfromtaggedptr", "annottotaggedptr", "annotdflt"
                                         , "word"
                                         , "DICTCLASS", "DICTINSTANCE", "DICTOVERLOADED", "SPECIALIZED"
+                                        , "_"
 %%[[97
                                         , "float", "double"
 %%]]