Merge pull request #67 from grin-compiler/32-alt-remove-unnamed

Anabra · web-flow · commit a5e680bacfac · 2020-01-17T01:29:22.000+01:00
Extended syntax: remove unnamed alternatives from syntax
diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs
@@ -24,8 +24,6 @@ import AbstractInterpretation.ExtendedSyntax.CreatedBy.CodeGenBase
 import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.CodeGen (litToSimpleType, unitType, codegenSimpleType) -- FIXME: why? remove, refactor
 import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.Result (undefinedProducer) -- FIXME: why? remove, refactor
 
--- TODO: remove
-import Debug.Trace
 
 data CByMapping
   = CByMapping
@@ -335,9 +333,8 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where
     {- NOTE: The alternatives are already evaluated,
        we only have return them.
     -}
-    AltF cpat (_, cgAlt) -> pure $ A cpat cgAlt
     -- NOTE: Currently, the names of the alternatives are ignored by the analysis.
-    NAltF cpat n (_, cgAlt) -> do
+    AltF cpat n (_, cgAlt) -> do
       altNameReg <- newReg
       addReg n altNameReg
       pure $ A cpat cgAlt
diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/EffectTracking/CodeGen.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/EffectTracking/CodeGen.hs
@@ -79,9 +79,8 @@ codeGenM = cata folder where
         emit IR.Move { srcReg = altReg, dstReg = caseResultReg }
       pure $ R caseResultReg
 
-    AltF _ exp -> exp
     -- NOTE: Currently, the names of the alternatives are ignored by the analysis.
-    NAltF _ n exp -> do
+    AltF _ n exp -> do
       altNameReg <- newReg
       addReg n altNameReg
       exp
diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/HeapPointsTo/CodeGen.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/HeapPointsTo/CodeGen.hs
@@ -289,9 +289,8 @@ codeGenM = cata folder where
 
       pure $ R caseResultReg
 
-    AltF cpat exp -> pure $ A cpat exp
     -- NOTE: Currently, the names of the alternatives are ignored by the analysis.
-    NAltF cpat n exp -> do
+    AltF cpat n exp -> do
       altNameReg <- newReg
       addReg n altNameReg
       pure $ A cpat exp
diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/LiveVariable/CodeGen.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/LiveVariable/CodeGen.hs
@@ -396,9 +396,8 @@ codeGenM e = (cata folder >=> const setMainLive) e
 
       pure $ R caseResultReg
 
-    AltF cpat exp -> pure $ A cpat exp
     -- NOTE: Currently, the names of the alternatives are ignored by the analysis.
-    NAltF cpat n exp -> do
+    AltF cpat n exp -> do
       altNameReg <- newReg
       addReg n altNameReg
       pure $ A cpat exp
diff --git a/grin/src/Grin/ExtendedSyntax/GADT.hs b/grin/src/Grin/ExtendedSyntax/GADT.hs
@@ -68,6 +68,7 @@ data Exp (role' :: Role) where
 
   Alt
     :: CPat         -- ^ Pattern to match against
+    -> Name         -- ^ Name of the alternative
     -> Exp 'Bind'   -- ^ Body of the alternative
     -> Exp 'Alt'
 
@@ -108,5 +109,5 @@ convertToExp = \case
   Fetch name          -> E.SFetch name
   Update lName nName  -> E.SUpdate lName nName
   Case name alts      -> E.ECase name (convertToExp <$> alts)
-  Alt cpat body       -> E.Alt cpat (convertToExp body)
+  Alt cpat name body  -> E.Alt cpat name (convertToExp body)
   Bind lhs bpat rhs   -> E.EBind (convertToExp lhs) bpat (convertToExp rhs)
diff --git a/grin/src/Grin/ExtendedSyntax/Lint.hs b/grin/src/Grin/ExtendedSyntax/Lint.hs
@@ -247,8 +247,7 @@ annotate te = cata builder where
       )
       :< SFetchF var -- Fetch returns a value based on its arguments that is associated in its binded variable
     SAppF name params -> (te ^? function . at name . _Just . _1) :< SAppF name params
-    AltF cpat body -> extract body :< AltF cpat body
-    NAltF cpat n body -> extract body :< NAltF cpat n body
+    AltF cpat n body -> extract body :< AltF cpat n body
     ECaseF var alts ->
       (do case catMaybes $ map extract alts of
             [] -> Nothing
@@ -445,11 +444,9 @@ lint warningKinds mTypeEnv exp@(Program exts _) =
       syntaxE SEWithoutNodesCtx
 
     -- Alt
-    (_ :< AltF cpat _) -> checkWithChild ExpCtx $ do
-      syntaxE AltCtx
     -- TODO: Define some checks for the alt name.
     -- For example, that it is a fresh variable.
-    (_ :< NAltF cpat n _) -> checkWithChild ExpCtx $ do
+    (_ :< AltF cpat n _) -> checkWithChild ExpCtx $ do
       syntaxE AltCtx
 
     where
diff --git a/grin/src/Grin/ExtendedSyntax/Nametable.hs b/grin/src/Grin/ExtendedSyntax/Nametable.hs
@@ -94,8 +94,7 @@ convert = second (view nametable) . flip runState emptyNS . cata build where
     SFetchF ptr                 -> SFetch <$> nameToIdx ptr
     SUpdateF ptr var            -> SUpdate <$> nameToIdx ptr <*> nameToIdx var
     SBlockF body                -> SBlock <$> body
-    AltF cp e                   -> Alt <$> cpat cp <*> e
-    NAltF cp n e                -> NAlt <$> cpat cp <*> nameToIdx n <*> e
+    AltF cp n e                 -> Alt <$> cpat cp <*> nameToIdx n <*> e
 
 -- * Restore
 
@@ -116,8 +115,7 @@ restore (exp, nt) = cata build exp where
     SFetchF ptr                -> SFetch (rname ptr)
     SUpdateF ptr var           -> SUpdate (rname ptr) (rname var)
     SBlockF body               -> SBlock body
-    AltF cp e                  -> Alt (rcpat cp) e
-    NAltF cp n e               -> NAlt (rcpat cp) (rname n) e
+    AltF cp n e                -> Alt (rcpat cp) (rname n) e
 
   rname :: Name -> Name
   rname (NI i) = maybe (error $ show i ++ " is not found") NM $ Map.lookup i nt
diff --git a/grin/src/Grin/ExtendedSyntax/Parse/AST.hs b/grin/src/Grin/ExtendedSyntax/Parse/AST.hs
@@ -31,25 +31,11 @@ def = Def <$> try (L.indentGuard sc EQ pos1 *> var) <*> many var <* op "=" <*> (
 expr :: Pos -> Parser Exp
 expr i = L.indentGuard sc EQ i >>
   try ((\pat e b -> EBind e pat b) <$> try (bindingPat <* op "<-") <*> simpleExp i <*> expr i ) <|>
-  ifThenElse i <|>
   simpleExp i
 
-ifThenElse :: Pos -> Parser Exp
-ifThenElse i = do
-  kw "if"
-  b <- var
-  kw "then"
-  t <- (L.indentGuard sc GT i >>= expr)
-  L.indentGuard sc EQ i
-  kw "else"
-  e <- (L.indentGuard sc GT i >>= expr)
-  return $ ECase b [ Alt (LitPat (LBool True))  t
-                   , Alt (LitPat (LBool False)) e
-                   ]
-
 simpleExp :: Pos -> Parser SimpleExp
 simpleExp i = SReturn <$ kw "pure" <*> value <|>
-              ECase <$ kw "case" <*> var <* kw "of" <*> (L.indentGuard sc GT i >>= some . nAlternative) <|>
+              ECase <$ kw "case" <*> var <* kw "of" <*> (L.indentGuard sc GT i >>= some . alternative) <|>
               SStore <$ kw "store" <*> var <|>
               SFetch <$ kw "fetch" <*> var <|>
               SUpdate <$ kw "update" <*> var <*> var <|>
@@ -62,10 +48,7 @@ primNameOrDefName :: Parser Name
 primNameOrDefName = nMap ("_"<>) <$ char '_' <*> var <|> var
 
 alternative :: Pos -> Parser Alt
-alternative i = Alt <$> try (L.indentGuard sc EQ i *> altPat) <* op "->" <*> (L.indentGuard sc GT i >>= expr)
-
-nAlternative :: Pos -> Parser NAlt
-nAlternative i = NAlt <$> try (L.indentGuard sc EQ i *> altPat) <*> (op "@" *> var) <* op "->" <*> (L.indentGuard sc GT i >>= expr)
+alternative i = Alt <$> try (L.indentGuard sc EQ i *> altPat) <*> (op "@" *> var) <* op "->" <*> (L.indentGuard sc GT i >>= expr)
 
 -- NOTE: The parser `value` already handles the parentheses around "complex" values,
 -- and we don't want to parenthesize variables, literals and units.
diff --git a/grin/src/Grin/ExtendedSyntax/Pretty.hs b/grin/src/Grin/ExtendedSyntax/Pretty.hs
@@ -118,8 +118,7 @@ prettyHighlightExternals externals exp = cata prettyExpAlgebra exp where
     SUpdateF name v         -> keywordR "update" <+> pretty name <+> pretty v
     SBlockF exp             -> text "do" <$$> indent 2 exp
     -- Alt
-    AltF cpat exp           -> pretty cpat <+> text "->" <$$> indent 2 exp
-    NAltF cpat scrut exp    -> pretty cpat <+> pretty '@' <+> pretty scrut <+> text "->" <$$> indent 2 exp
+    AltF cpat scrut exp     -> pretty cpat <+> pretty '@' <+> pretty scrut <+> text "->" <$$> indent 2 exp
 
 
 instance Pretty Exp where
diff --git a/grin/src/Grin/ExtendedSyntax/PrettyLint.hs b/grin/src/Grin/ExtendedSyntax/PrettyLint.hs
@@ -51,5 +51,4 @@ prettyAnnExp exp = cata folder exp where
       SUpdateF ptr var        -> keywordR "update" <+> pretty ptr <+> pretty var
       SBlockF exp             -> text "do" <$$> indent 2 (pretty exp)
       -- Alt
-      AltF cpat exp           -> pretty cpat <+> text "->" <$$> indent 2 (pretty exp)
-      NAltF cpat n exp        -> pretty cpat <+> pretty '@' <+> pretty n <+> text "->" <$$> indent 2 (pretty exp)
+      AltF cpat n exp         -> pretty cpat <+> pretty '@' <+> pretty n <+> text "->" <$$> indent 2 (pretty exp)
diff --git a/grin/src/Grin/ExtendedSyntax/Statistics.hs b/grin/src/Grin/ExtendedSyntax/Statistics.hs
@@ -62,8 +62,7 @@ statistics = cata $ \case
   SUpdateF p v -> mempty { sUpdate = 1, vars = Set.singleton p <> Set.singleton v }
   SBlockF  s   -> s <> mempty { sBlock  = 1 }
   -- Alt
-  AltF p s     -> s <> mempty { alt = 1, vars = foldNames Set.singleton p, tags = tagInCPat p }
-  NAltF p n s  -> s <> mempty { alt = 1, vars = foldNames Set.singleton p <> Set.singleton n, tags = tagInCPat p }
+  AltF p n s   -> s <> mempty { alt = 1, vars = foldNames Set.singleton p <> Set.singleton n, tags = tagInCPat p }
   -- general case
   e -> Data.Foldable.fold e
 
diff --git a/grin/src/Grin/ExtendedSyntax/Syntax.hs b/grin/src/Grin/ExtendedSyntax/Syntax.hs
@@ -99,7 +99,6 @@ makeLenses ''BPat
 
 type SimpleExp = Exp
 type Alt = Exp
-type NAlt = Exp
 type Def = Exp
 type Program = Exp
 
@@ -117,8 +116,7 @@ data Exp
   | SUpdate     Name Name
   | SBlock      Exp
   -- Alt
-  | Alt CPat Exp
-  | NAlt CPat Name Exp
+  | Alt CPat Name Exp
   deriving (Generic, Data, NFData, Binary, Eq, Ord, Show)
 
 externals :: Exp -> [External]
@@ -137,14 +135,12 @@ deriving instance Ord a   => Ord  (ExpF a)
 pattern BoolPat b = LitPat (LBool b)
 
 _AltCPat :: Traversal' Exp CPat
-_AltCPat f (Alt p e)    = (`Alt` e) <$> f p
-_AltCPat f (NAlt p n e) = NAlt <$> f p <*> pure n <*> pure e
-_AltCPat _ other        = pure other
+_AltCPat f (Alt p n e) = Alt <$> f p <*> pure n <*> pure e
+_AltCPat _ other       = pure other
 
 _AltFCPat :: Traversal' (ExpF a) CPat
-_AltFCPat f (AltF p e)    = (`AltF` e) <$> f p
-_AltFCPat f (NAltF p n e) = NAltF <$> f p <*> pure n <*> pure e
-_AltFCPat _ other         = pure other
+_AltFCPat f (AltF p n e) = AltF <$> f p <*> pure n <*> pure e
+_AltFCPat _ other        = pure other
 
 _ValVar :: Traversal' Val Name
 _ValVar f (Var name) = Var <$> f name
diff --git a/grin/src/Transformations/ExtendedSyntax/Conversion.hs b/grin/src/Transformations/ExtendedSyntax/Conversion.hs
@@ -178,11 +178,9 @@ instance Convertible Exp New.Exp where
       | (Var var) <- val -> pure $ New.SUpdateF (convert ptr) (convert var)
     (SReturn val)  -> pure $ New.SReturnF (convert val)
     (SBlock exp)   -> pure $ New.SBlockF exp
-    -- TODO: to NAlt
     (Alt cpat exp) -> do
       altName <- deriveNewName "alt"
-      pure $ New.NAltF (convert cpat) (convert altName) exp
-    _ -> error "Conversion from Old to New has failed: unexpected AST pattern"
+      pure $ New.AltF (convert cpat) (convert altName) exp
 
 instance Convertible New.TagType TagType where
   convert = \case
@@ -275,9 +273,8 @@ instance Convertible New.Exp Exp where
   convert (New.SUpdate ptr var)    = SUpdate (convert ptr) (Var $ convert var)
   convert (New.SReturn val)        = SReturn (convert val)
   convert (New.SBlock exp)         = SBlock (convert exp)
-  convert (New.Alt cpat exp)       = Alt (convert cpat) (convert exp)
   -- TODO: This transformation is not sound if the body contains a reference to the alt name.
-  convert (New.NAlt cpat _ exp)    = Alt (convert cpat) (convert exp)
+  convert (New.Alt cpat _ exp)     = Alt (convert cpat) (convert exp)
 
 convertToNew :: Exp -> New.Exp
 convertToNew = convert . nameEverything
diff --git a/grin/src/Transformations/ExtendedSyntax/GenerateEval.hs b/grin/src/Transformations/ExtendedSyntax/GenerateEval.hs
@@ -20,13 +20,15 @@ genEval :: Set Name -> Name -> [Def] -> NameM Def
 genEval exclude evalName defs = do
   ptrName <- deriveNewName "p"
   valueName <- deriveNewName "v"
-  let defaultAlt = Alt DefaultPat . SReturn . Var $ valueName
+  defaultAltName <- deriveNewName "alt"
+  let defaultAlt = Alt DefaultPat defaultAltName . SReturn . Var $ valueName
       funAlt name args = do
         argNames <- replicateM (length args) $ deriveNewName "a"
         whnf <- deriveNewName "res"
         wildcard <- deriveWildCard
+        altName <- deriveNewName "alt"
         pure $
-          Alt (NodePat (Tag F name) argNames) $
+          Alt (NodePat (Tag F name) argNames) altName $
             EBind (SApp name $ argNames) (VarPat whnf) $
             EBind (SUpdate ptrName whnf) (VarPat wildcard) $
             SReturn $ Var whnf
@@ -43,8 +45,9 @@ genApply exclude applyName defs = do
   argName <- deriveNewName "x"
 
   let funAlt name arity missing = do
+        altName <- deriveNewName "alt"
         argNames <- replicateM (arity - missing) $ deriveNewName "a"
-        pure $ Alt (NodePat (Tag (P missing) name) argNames) $ if missing < 1 then error "genApply: internal error" else
+        pure $ Alt (NodePat (Tag (P missing) name) argNames) altName $ if missing < 1 then error "genApply: internal error" else
           if missing == 1
             then SApp name $ argNames ++ [argName]
             else SReturn $ ConstTagNode (Tag (P $ pred missing) name) $ argNames ++ [argName]
diff --git a/grin/src/Transformations/ExtendedSyntax/Names.hs b/grin/src/Transformations/ExtendedSyntax/Names.hs
@@ -127,8 +127,7 @@ mapNameDefExpM f = \case
   Def name args body          -> Def <$> f name <*> mapM f args <*> pure body
   EBind leftExp (VarPat var) rightExp -> do EBind leftExp <$> (VarPat <$> f var) <*> pure rightExp
   EBind leftExp (AsPat var val) rightExp -> EBind leftExp <$> (AsPat <$> f var <*> mapNamesValM f val) <*> pure rightExp
-  Alt cpat body               -> Alt <$> mapNamesCPatM f cpat <*> pure body
-  NAlt cpat n body            -> NAlt <$> mapNamesCPatM f cpat <*> f n <*> pure body
+  Alt cpat n body             -> Alt <$> mapNamesCPatM f cpat <*> f n <*> pure body
   exp                         -> pure exp
 
 mapNamesCPatM :: Monad m => (Name -> m Name) -> CPat -> m CPat
diff --git a/grin/src/Transformations/ExtendedSyntax/StaticSingleAssignment.hs b/grin/src/Transformations/ExtendedSyntax/StaticSingleAssignment.hs
@@ -42,12 +42,19 @@ staticSingleAssignment e = flip evalState (mempty, 1) $
       subst' <- foldM (\s n -> snd <$> calcName (n, s)) subst (foldNames (:[]) v)
       pure $ EBindF (subst', lhs) (mapNamesBPat (substName' subst') v) (subst', rhs)
 
-    Alt (NodePat tag names) body -> do
+    Alt (NodePat tag names) name body -> do
       (names0, subst0) <- first reverse <$> foldM
         (\(names1, subst1) name1 -> first (:names1) <$> calcName (name1, subst1))
         ([], subst)
         names
-      pure $ AltF (NodePat tag names0) (subst0, body)
+      -- QUESTION: is this correct?
+      (name0, subst1) <- calcName (name, subst0)
+      pure $ AltF (NodePat tag names0) name0 (subst1, body)
+
+    -- QUESTION: is this correct?
+    Alt cpat name body -> do
+      (name0, subst0) <- calcName (name, subst)
+      pure $ AltF cpat name0 (subst0, body)
 
     -- Substituitions
     ECase       scrut alts -> pure $ ECaseF (substName scrut) $ ((,) subst) <$> alts
diff --git a/grin/src/Transformations/ExtendedSyntax/Util.hs b/grin/src/Transformations/ExtendedSyntax/Util.hs
@@ -54,9 +54,8 @@ foldNameDefExpF :: (Monoid m) => (DefRole -> Name -> m) -> ExpF a -> m
 foldNameDefExpF f = \case
   DefF name args _      -> mconcat $ (f FunName name) : map (f FunParam) args
   EBindF _ bPat _       -> f BindVar (_bPatVar bPat)
-  AltF cpat _           -> foldNames (f AltVar) cpat
   -- QUESTION: What should be the alt name's DefRole? Now it is BindVar, because it rebinds the scrutinee.
-  NAltF cpat n _        -> f BindVar n <> foldNames (f AltVar) cpat
+  AltF cpat n _         -> f BindVar n <> foldNames (f AltVar) cpat
   _                     -> mempty
 
 mapNamesCPat :: (Name -> Name) -> CPat -> CPat
@@ -198,8 +197,7 @@ collectTagInfo = flip execState (TagInfo Map.empty) . cataM alg
     alg :: ExpF () -> State TagInfo ()
     alg = \case
       SReturnF val   -> goVal val
-      AltF cpat _    -> goCPat cpat
-      NAltF cpat _ _ -> goCPat cpat
+      AltF cpat _ _  -> goCPat cpat
       _              -> pure ()
 
     goVal :: Val -> State TagInfo ()
diff --git a/grin/test/ExtendedSyntax/ParserSpec.hs b/grin/test/ExtendedSyntax/ParserSpec.hs
