[commit: ghc] wip/gadtpm: Fixed AsPat, NPlusKPat, ViewPat and ListPat translation (b9ed6e8)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/gadtpm
Link       : http://ghc.haskell.org/trac/ghc/changeset/b9ed6e8cdfba8c02e8e02cf274b89e8776a08407/ghc

>---------------------------------------------------------------

commit b9ed6e8cdfba8c02e8e02cf274b89e8776a08407
Author: George Karachalias <george.karachalias at gmail.com>
Date:   Thu Mar 19 16:22:23 2015 +0100

    Fixed AsPat, NPlusKPat, ViewPat and ListPat translation


>---------------------------------------------------------------

b9ed6e8cdfba8c02e8e02cf274b89e8776a08407
 compiler/deSugar/Check.hs | 47 +++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 41 insertions(+), 6 deletions(-)

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index fdac5c7..7fc22e7 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -729,7 +729,7 @@ data Abstraction = P -- Pattern abstraction
                  | V -- Value   abstraction
 
 data PmPat2 :: Abstraction -> * where
-  GBindAbs :: [PmPat2 P] -> HsExpr Id -> PmPat2 P     -- Guard: P <- e (strict be default) Instead of a single P use a list [AsPat]
+  GBindAbs :: [PmPat2 P] -> HsExpr Id -> PmPat2 P   -- Guard: P <- e (strict by default) Instead of a single P use a list [AsPat]
   ConAbs   :: DataCon -> [PmPat2 abs] -> PmPat2 abs -- Constructor: K ps
   VarAbs   :: Id -> PmPat2 abs                      -- Variable: x
 
@@ -773,12 +773,47 @@ translatePat usupply pat = case pat of
   ParPat p           -> translatePat usupply (unLoc p)
   LazyPat p          -> translatePat usupply (unLoc p) -- COMEHERE: We ignore laziness   for now
   BangPat p          -> translatePat usupply (unLoc p) -- COMEHERE: We ignore strictness for now
-  AsPat lid p        -> VarAbs (unLoc lid) : translatePat usupply (unLoc p)
+  AsPat lid p ->
+    let ps  = translatePat usupply (unLoc p)
+        idp = VarAbs (unLoc lid)
+        g   = GBindAbs ps (HsVar (unLoc lid))
+    in  [idp, g]
   SigPatOut p ty     -> translatePat usupply (unLoc p) -- COMEHERE: FIXME: Exploit the signature?
   CoPat wrapper p ty -> translatePat usupply p         -- COMEHERE: Make sure the coercion is not useful
-  NPlusKPat n k ge minus    -> error "COMEHERE"
-  ViewPat lexpr lpat arg_ty -> error "COMEHERE"
-  ListPat _ _ (Just (_,_))  -> error "COMEHERE: FIXME: Overloaded List"
+  NPlusKPat n k ge minus ->
+    let x  = mkPmId usupply (idType (unLoc n)) -- x as Id
+        xe = noLoc (HsVar x)                   -- x as located expression
+        ke = noLoc (HsOverLit k)               -- k as located expression
+        np = [VarAbs (unLoc n)]                -- n as a list of value abstractions
+
+        xp = VarAbs x                                          -- x
+        g1 = eqTrueExpr  $ OpApp xe (noLoc ge)    no_fixity ke -- True <- (x >= k)
+        g2 = GBindAbs np $ OpApp xe (noLoc minus) no_fixity ke -- n    <- (x -  k)
+    in  [xp, g1, g2]
+
+  ViewPat lexpr lpat arg_ty ->
+    let (usupply1, usupply2) = splitUniqSupply usupply
+
+        x  = mkPmId usupply1 arg_ty             -- x as Id
+        xe = noLoc (HsVar x)                    -- x as located expression
+        ps = translatePat usupply2 (unLoc lpat) -- p translated recursively
+
+        xp = VarAbs x                     -- x
+        g  = GBindAbs ps (HsApp lexpr xe) -- p <- f x
+    in  [xp,g]
+
+  ListPat lpats elem_ty (Just (pat_ty, to_list)) ->
+    let (usupply1, usupply2) = splitUniqSupply usupply
+
+        x  = mkPmId usupply1 (hsPatType pat)          -- x as Id
+        xe = noLoc (HsVar x)                          -- x as located expression
+        ps = translatePats usupply2 (map unLoc lpats) -- list as value abstraction
+
+        xp = VarAbs x                                        -- x
+        g  = GBindAbs (concat ps) $ HsApp (noLoc to_list) xe -- [...] <- toList x
+    in  [xp,g]
+
+
   ConPatOut { pat_con = L _ (PatSynCon _) } -> error "COMEHERE: FIXME: Pattern Synonym" -- PATTERN SYNONYM - WHAT TO DO WITH IT?
 
   ConPatOut { pat_con = L _ (RealDataCon con), pat_args = ps } -> -- DO WE NEED OTHER STUFF FROM IT?
@@ -791,7 +826,7 @@ translatePat usupply pat = case pat of
         expr     = OpApp hs_var (noLoc eq) no_fixity expr_lit -- COMEHERE: I do not like the noLoc thing
     in  [VarAbs var, eqTrueExpr expr]
 
-  LitPat lit -> [mkPmVar usupply (hsPatType pat)] -- COMEHERE: Wrong. Should be like NPat (which eq to use?)
+  LitPat lit -> error "COMEHERE" -- [mkPmVar usupply (hsPatType pat)] -- COMEHERE: Wrong. Should be like NPat (which eq to use?)
 
   ListPat ps ty Nothing -> -- WHAT TO DO WITH TY??
     let tidy_ps       = translatePats usupply (map unLoc ps)