Extended syntax: Named alternatives GRIN directory

grin/src/Grin/ExtendedSyntax/Lint.hs

@@ -248,6 +248,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
     ECaseF var alts ->
       (do case catMaybes $ map extract alts of
             [] -> Nothing
@@ -446,6 +447,10 @@ lint warningKinds mTypeEnv exp@(Program exts _) =
     -- 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
+      syntaxE AltCtx
 
     where
       syntaxE = syntaxExp ctx

grin/src/Grin/ExtendedSyntax/Nametable.hs

@@ -95,6 +95,7 @@ convert = second (view nametable) . flip runState emptyNS . cata build where
     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
 
 -- * Restore
 
@@ -116,6 +117,7 @@ restore (exp, nt) = cata build exp where
     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
 
   rname :: Name -> Name
   rname (NI i) = maybe (error $ show i ++ " is not found") NM $ Map.lookup i nt

grin/src/Grin/ExtendedSyntax/Parse/AST.hs

@@ -49,7 +49,7 @@ ifThenElse i = do
 
 simpleExp :: Pos -> Parser SimpleExp
 simpleExp i = SReturn <$ kw "pure" <*> value <|>
-              ECase <$ kw "case" <*> var <* kw "of" <*> (L.indentGuard sc GT i >>= some . alternative) <|>
+              ECase <$ kw "case" <*> var <* kw "of" <*> (L.indentGuard sc GT i >>= some . (\pos -> try (alternative pos) <|> nAlternative pos)) <|>
               SStore <$ kw "store" <*> var <|>
               SFetch <$ kw "fetch" <*> var <|>
               SUpdate <$ kw "update" <*> var <*> var <|>
@@ -64,6 +64,9 @@ 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)
+
 -- NOTE: The parser `value` already handles the parentheses around "complex" values,
 -- and we don't want to parenthesize variables, literals and units.
 bindingPat :: Parser BPat

grin/src/Grin/ExtendedSyntax/Pretty.hs

@@ -118,7 +118,8 @@ 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
+    AltF cpat exp           -> pretty cpat <+> text "->" <$$> indent 2 exp
+    NAltF cpat scrut exp    -> pretty cpat <+> pretty '@' <+> pretty scrut <+> text "->" <$$> indent 2 exp
 
 
 instance Pretty Exp where

grin/src/Grin/ExtendedSyntax/PrettyLint.hs

@@ -51,4 +51,5 @@ 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)
+      AltF cpat exp           -> pretty cpat <+> text "->" <$$> indent 2 (pretty exp)
+      NAltF cpat n exp        -> pretty cpat <+> pretty '@' <+> pretty n <+> text "->" <$$> indent 2 (pretty exp)

grin/src/Grin/ExtendedSyntax/Statistics.hs

@@ -63,6 +63,7 @@ statistics = cata $ \case
   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 }
   -- general case
   e -> Data.Foldable.fold e
 

grin/src/Grin/ExtendedSyntax/Syntax.hs

@@ -99,6 +99,7 @@ makeLenses ''BPat
 
 type SimpleExp = Exp
 type Alt = Exp
+type NAlt = Exp
 type Def = Exp
 type Program = Exp
 
@@ -117,6 +118,7 @@ data Exp
   | SBlock      Exp
   -- Alt
   | Alt CPat Exp
+  | NAlt CPat Name Exp
   deriving (Generic, Data, NFData, Binary, Eq, Ord, Show)
 
 externals :: Exp -> [External]
@@ -142,6 +144,14 @@ _AltFCPat :: Traversal' (ExpF a) CPat
 _AltFCPat f (AltF p e) = (`AltF` e) <$> f p
 _AltFCPat _ other      = pure other
 
+_NAltCPat :: Traversal' Exp CPat
+_NAltCPat f (NAlt p n e) = NAlt <$> f p <*> pure n <*> pure e
+_NAltCPat _ other       = pure other
+
+_NAltFCPat :: Traversal' (ExpF a) CPat
+_NAltFCPat f (NAltF p n e) = NAltF <$> f p <*> pure n <*> pure e
+_NAltFCPat _ other        = pure other
+
 _ValVar :: Traversal' Val Name
 _ValVar f (Var name) = Var <$> f name
 _ValVar _ other      = pure other

grin/src/Transformations/ExtendedSyntax/Conversion.hs

@@ -12,6 +12,7 @@ import qualified Data.Map    as M
 import qualified Data.Vector as V
 
 import Control.Monad
+import Control.Monad.Identity
 
 import Lens.Micro.Extra
 import Lens.Micro.Platform
@@ -27,15 +28,12 @@ import qualified Grin.ExtendedSyntax.Syntax as New
 import qualified Grin.ExtendedSyntax.SyntaxDefs as New
 import qualified Grin.ExtendedSyntax.TypeEnvDefs as New
 
+import Transformations.Util
 import Transformations.Names
 import Transformations.BindNormalisation
 import Transformations.Simplifying.ProducerNameIntroduction
 import Transformations.Simplifying.BindingPatternSimplification
 
--- TODO: remove these
-import Test.QuickCheck
-import Test.ExtendedSyntax.Old.Test()
-import qualified Test.ExtendedSyntax.Old.Grammar as OG
 
 class Convertible a b where
   convert :: a -> b
@@ -109,7 +107,7 @@ instance Convertible CPat New.CPat where
     NodePat t args -> New.NodePat (convert t) (map convert args)
     LitPat l       -> New.LitPat (convert l)
     DefaultPat     -> New.DefaultPat
-    TagPat _ -> error "covnert: Tag patterns are not supported in the new syntax."
+    TagPat _ -> error "convert: Tag patterns are not supported in the new syntax."
 
 instance Convertible Val New.Val where
   convert n@(ConstTagNode t vals)
@@ -123,38 +121,42 @@ instance Convertible Val New.Val where
   convert (Undefined t) = New.Undefined (convert t)
 
 instance Convertible Exp New.Exp where
-  convert (Program exts defs)  = New.Program (map convert exts) (map convert defs)
-  convert (Def name args body) = New.Def (convert name) (map convert args) (convert body)
-  {- NOTE: we assume Binding Pattern Simplification has been run
-    v.0 <- pure <value>
-    <non-var pat> <- pure v.0
-    <rhs2>
-  -}
-  convert (EBind lhs1 (Var var) rhs1)
-    | EBind (SReturn (Var var')) pat rhs2 <- rhs1
-    , isn't _Var pat
-    , var == var'
-    = New.EBind (convert lhs1) (New.AsPat (convert var) (convert pat)) (convert rhs2)
-  convert (EBind lhs (Var var) rhs)
-    = New.EBind (convert lhs) (New.VarPat $ convert var) (convert rhs)
-  convert (ECase scrut alts)
-    | isn't _Var scrut   = error $ "Non-variable pattern in case scrutinee: " ++ show (PP scrut)
-    | (Var var) <- scrut = New.ECase (convert var) (map convert alts)
-  convert e@(SApp f vals)
-    | any (isn't _Var) vals = error $ "Non-variable value in application: " ++ show (PP e)
-    | otherwise             = New.SApp (convert f) $ map (convert . view _Var) vals
-  convert e@(SStore val)
-    | isn't _Var val   = error $ "Non-variable value in store: " ++ show (PP e)
-    | (Var var) <- val = New.SStore (convert var)
-  convert e@(SFetchI ptr mIx)
-    | Nothing <- mIx = New.SFetch (convert ptr)
-    | otherwise      = error $ "Indexed fetch is no longer supported: " ++ show (PP e)
-  convert e@(SUpdate ptr val)
-    | isn't _Var val   = error $ "Non-variable value in update: " ++ show (PP e)
-    | (Var var) <- val = New.SUpdate (convert ptr) (convert var)
-  convert (SReturn val)  = New.SReturn (convert val)
-  convert (SBlock exp)   = New.SBlock (convert exp)
-  convert (Alt cpat exp) = New.Alt (convert cpat) (convert exp)
+  convert exp = fst $ evalNameM exp $ flip anaM exp $ \case
+    (Program exts defs)  -> pure $ New.ProgramF (map convert exts) defs
+    (Def name args body) -> pure $ New.DefF (convert name) (map convert args) body
+    {- NOTE: we assume Binding Pattern Simplification has been run
+      v.0 <- pure <value>
+      <non-var pat> <- pure v.0
+      <rhs2>
+    -}
+    (EBind lhs1 (Var var) rhs1)
+      | EBind (SReturn (Var var')) pat rhs2 <- rhs1
+      , isn't _Var pat
+      , var == var'
+      -> pure $ New.EBindF lhs1 (New.AsPat (convert var) (convert pat)) rhs2
+    (EBind lhs (Var var) rhs)
+      -> pure $ New.EBindF lhs (New.VarPat $ convert var) rhs
+    (ECase scrut alts)
+      | isn't _Var scrut   -> error $ "Non-variable pattern in case scrutinee: " ++ show (PP scrut)
+      | (Var var) <- scrut -> pure $ New.ECaseF (convert var) alts
+    e@(SApp f vals)
+      | any (isn't _Var) vals -> error $ "Non-variable value in application: " ++ show (PP e)
+      | otherwise             -> pure $ New.SAppF (convert f) $ map (convert . view _Var) vals
+    e@(SStore val)
+      | isn't _Var val   -> error $ "Non-variable value in store: " ++ show (PP e)
+      | (Var var) <- val -> pure $ New.SStoreF (convert var)
+    e@(SFetchI ptr mIx)
+      | Nothing <- mIx -> pure $ New.SFetchF (convert ptr)
+      | otherwise      -> error $ "Indexed fetch is no longer supported: " ++ show (PP e)
+    e@(SUpdate ptr val)
+      | isn't _Var val   -> error $ "Non-variable value in update: " ++ show (PP e)
+      | (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
 
 instance Convertible New.TagType TagType where
   convert = \case
@@ -248,6 +250,8 @@ instance Convertible New.Exp Exp where
   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)
 
 convertToNew :: Exp -> New.Exp
 convertToNew = convert . nameEverything

grin/src/Transformations/ExtendedSyntax/Util.hs

@@ -55,6 +55,8 @@ 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
   _                     -> mempty
 
 mapNamesCPat :: (Name -> Name) -> CPat -> CPat
@@ -197,6 +199,7 @@ collectTagInfo = flip execState (TagInfo Map.empty) . cataM alg
     alg = \case
       SReturnF val   -> goVal val
       AltF cpat _    -> goCPat cpat
+      NAltF cpat _ _ -> goCPat cpat
       _              -> pure ()
 
     goVal :: Val -> State TagInfo ()

grin/test/ExtendedSyntax/ParserSpec.hs

@@ -112,16 +112,16 @@ spec = do
       let before = [prog|
         test p =
           _unit@() <- case p of
-            #default ->
+            #default @ _1 ->
               pure ()
           case p of
-            #default ->
+            #default @ _2 ->
               pure p
         |]
       let after = Program []
             [ Def "test"[ "p" ]
-              ( EBind ( ECase "p" [ Alt DefaultPat ( SReturn Unit ) ] ) (AsPat "_unit" Unit)
-                ( ECase "p" [ Alt DefaultPat ( SReturn (Var "p") ) ] )
+              ( EBind ( ECase "p" [ NAlt DefaultPat "_1" ( SReturn Unit ) ] ) (AsPat "_unit" Unit)
+                ( ECase "p" [ NAlt DefaultPat "_2" ( SReturn (Var "p") ) ] )
               )
             ]
       before `sameAs` after
@@ -163,29 +163,29 @@ spec = do
       let before = [prog|
         grinMain =
           case scrut of
-            13.1415   -> pure ()
-            +14.1415  -> pure ()
-            -14.1415  -> pure ()
-            42        -> pure ()
-            +43       -> pure ()
-            -42       -> pure ()
-            64u       -> pure ()
-            (CNode a1 a2 a3 a4 a5) -> pure ()
-            #default  -> pure ()
-            #True     -> pure ()
-            #False    -> pure ()
+            13.1415 @ _1   -> pure ()
+            +14.1415 @ _2  -> pure ()
+            -14.1415 @ _3  -> pure ()
+            42 @ _4        -> pure ()
+            +43 @ _5       -> pure ()
+            -42 @ _6       -> pure ()
+            64u @ _7       -> pure ()
+            (CNode a1 a2 a3 a4 a5) @ _8 -> pure ()
+            #default @ _9  -> pure ()
+            #True @ _10    -> pure ()
+            #False @ _11   -> pure ()
         |]
       let after = Program []
             [ Def "grinMain"[]
                 ( ECase "scrut"
-                    [ Alt ( LitPat ( LFloat 13.1415 ) ) ( SReturn Unit )
-                    , Alt ( LitPat ( LFloat 14.1415 ) ) ( SReturn Unit )
-                    , Alt ( LitPat ( LFloat ( -14.1415 ) ) ) ( SReturn Unit )
-                    , Alt ( LitPat ( LInt64 42 ) ) ( SReturn Unit )
-                    , Alt ( LitPat ( LInt64 43 ) ) ( SReturn Unit )
-                    , Alt ( LitPat ( LInt64 ( -42 ) ) ) ( SReturn Unit )
-                    , Alt ( LitPat ( LWord64 64 ) ) ( SReturn Unit )
-                    , Alt
+                    [ NAlt ( LitPat ( LFloat 13.1415 ) ) "_1" ( SReturn Unit )
+                    , NAlt ( LitPat ( LFloat 14.1415 ) ) "_2" ( SReturn Unit )
+                    , NAlt ( LitPat ( LFloat ( -14.1415 ) ) ) "_3" ( SReturn Unit )
+                    , NAlt ( LitPat ( LInt64 42 ) ) "_4" ( SReturn Unit )
+                    , NAlt ( LitPat ( LInt64 43 ) ) "_5" ( SReturn Unit )
+                    , NAlt ( LitPat ( LInt64 ( -42 ) ) ) "_6" ( SReturn Unit )
+                    , NAlt ( LitPat ( LWord64 64 ) ) "_7" ( SReturn Unit )
+                    , NAlt
                         ( NodePat
                             ( Tag
                                 { tagType = C
@@ -198,10 +198,10 @@ spec = do
                             , "a4"
                             , "a5"
                             ]
-                        ) ( SReturn Unit )
-                    , Alt DefaultPat ( SReturn Unit )
-                    , Alt ( LitPat ( LBool True ) ) ( SReturn Unit )
-                    , Alt ( LitPat ( LBool False ) ) ( SReturn Unit )
+                        ) "_8" ( SReturn Unit )
+                    , NAlt DefaultPat "_9" ( SReturn Unit )
+                    , NAlt ( LitPat ( LBool True ) ) "_10" ( SReturn Unit )
+                    , NAlt ( LitPat ( LBool False ) ) "_11" ( SReturn Unit )
                     ]
                 )
             ]
@@ -294,9 +294,9 @@ spec = do
             v1 <- pure #""
             v2 <- pure #"a"
             v3 <- case v1 of
-              #"" -> pure 1
-              #"a" -> pure 2
-              #default -> pure 3
+              #"" @ _1 -> pure 1
+              #"a" @ _2 -> pure 2
+              #default @ _3 -> pure 3
             _x@#"a" <- pure v2
             pure ()
         |]
@@ -305,9 +305,9 @@ spec = do
             EBind (SReturn (Lit (LString ""))) (VarPat "v1") $
             EBind (SReturn (Lit (LString "a"))) (VarPat "v2") $
             EBind (ECase "v1" $
-              [Alt (LitPat (LString "")) (SReturn (Lit (LInt64 1)))
-              ,Alt (LitPat (LString "a")) (SReturn (Lit (LInt64 2)))
-              ,Alt DefaultPat (SReturn (Lit (LInt64 3)))
+              [NAlt (LitPat (LString "")) "_1" (SReturn (Lit (LInt64 1)))
+              ,NAlt (LitPat (LString "a")) "_2" (SReturn (Lit (LInt64 2)))
+              ,NAlt DefaultPat "_3" (SReturn (Lit (LInt64 3)))
               ]) (VarPat "v3") $
             EBind (SReturn $ Var "v2") (AsPat "_x" $ (Lit (LString "a"))) $
             SReturn Unit
@@ -319,19 +319,19 @@ spec = do
           grinMain =
             v2 <- pure #'a'
             v3 <- case v2 of
-              #'b' -> pure 1
-              #'c' -> pure 2
-              #default -> pure 3
+              #'b' @ _1 -> pure 1
+              #'c' @ _2 -> pure 2
+              #default @ _3 -> pure 3
             _c@#'a' <- pure v2
             pure ()
         |]
     let after = Program []
           [Def "grinMain" [] $
             EBind (SReturn (Lit (LChar 'a'))) (VarPat "v2") $
             EBind (ECase "v2" $
-              [Alt (LitPat (LChar 'b')) (SReturn (Lit (LInt64 1)))
-              ,Alt (LitPat (LChar 'c')) (SReturn (Lit (LInt64 2)))
-              ,Alt DefaultPat (SReturn (Lit (LInt64 3)))
+              [NAlt (LitPat (LChar 'b')) "_1" (SReturn (Lit (LInt64 1)))
+              ,NAlt (LitPat (LChar 'c')) "_2" (SReturn (Lit (LInt64 2)))
+              ,NAlt DefaultPat "_3" (SReturn (Lit (LInt64 3)))
               ]) (VarPat "v3") $
             EBind (SReturn $ Var "v2") (AsPat "_c" $ Lit (LChar 'a')) $
             SReturn Unit