new tag syntax; preparing for Core patterns

new tag syntax; preparing for data names

CHANGELOG.md

@@ -0,0 +1,17 @@
+# unreleased
+
+* New tag syntax:
+  ```hs
+  case x of
+    { 1 -> something
+    ; 2 -> another
+    }
+  ```
+  is now written as
+  ```hs
+  case x of
+    { <1> -> something
+    ; <2> -> another
+    }
+  ```
+

examples/factorial.hs

@@ -1,6 +1,6 @@
 fac n = case (==#) n 0 of
-    { 1 -> 1
-    ; 0 -> (*#) n (fac ((-#) n 1))
+    { <1> -> 1
+    ; <0> -> (*#) n (fac ((-#) n 1))
     };
 
 main = fac 3;

examples/sumList.hs

@@ -2,8 +2,8 @@ nil = Pack{0 0};
 cons x y = Pack{1 2} x y;
 list = cons 1 (cons 2 (cons 3 nil));
 sum l = case l of
-    { 0      -> 0
-    ; 1 x xs -> (+#) x (sum xs)
+    { <0>      -> 0
+    ; <1> x xs -> (+#) x (sum xs)
     };
 main = sum list;
 

src/Core/Examples.hs

@@ -147,8 +147,8 @@ simple1 = [coreProg|
 caseBool1 :: Program'
 caseBool1 = [coreProg|
     _if c x y = case c of
-        { 1 -> x
-        ; 0 -> y
+        { <1> -> x
+        ; <0> -> y
         };
 
     false = Pack{0 0};
@@ -160,8 +160,8 @@ caseBool1 = [coreProg|
 fac3 :: Program'
 fac3 = [coreProg|
     fac n = case (==#) n 0 of
-        { 1 -> 1
-        ; 0 -> (*#) n (fac ((-#) n 1))
+        { <1> -> 1
+        ; <0> -> (*#) n (fac ((-#) n 1))
         };
 
     main = fac 3;
@@ -175,8 +175,8 @@ sumList = [coreProg|
         cons x y = Pack{1 2} x y;
         list = cons 1 (cons 2 (cons 3 nil));
         sum l = case l of
-            { 0      -> 0
-            ; 1 x xs -> (+#) x (sum xs)
+            { <0>      -> 0
+            ; <1> x xs -> (+#) x (sum xs)
             };
         main = sum list;
     |]
@@ -192,7 +192,7 @@ idCase = [coreProg|
         id x = x;
 
         main = id (case Pack{1 0} of
-            { 1 -> (+#) 2 3
+            { <1> -> (+#) 2 3
             })
     |]
 

src/Core/Lex.x

@@ -65,6 +65,8 @@ $white_no_nl = $white # $nl
 
 @decimal = $digit+
 
+@alttag    = "<" $digit+ ">"
+
 rlp :-
 
 <0>
@@ -92,6 +94,8 @@ rlp :-
     "="                     { constTok TokenEquals }
     "->"                    { constTok TokenArrow }
 
+    @alttag                 { lexWith ( TokenAltTag . read @Int . T.unpack
+                                      . T.drop 1 . T.init ) }
     @varname                { lexWith TokenVarName }
     @conname                { lexWith TokenConName }
     @varsym                 { lexWith TokenVarSym }
@@ -135,6 +139,7 @@ data CoreToken = TokenLet
                | TokenConName Name
                | TokenVarSym Name
                | TokenConSym Name
+               | TokenAltTag Tag
                | TokenEquals
                | TokenLParen
                | TokenRParen

src/Core/Parse.y

@@ -49,6 +49,7 @@ import Data.HashMap.Strict  qualified as H
       varsym          { Located _ _ _ (TokenVarSym $$) }
       conname         { Located _ _ _ (TokenConName $$) }
       consym          { Located _ _ _ (TokenConSym $$) }
+      alttag          { Located _ _ _ (TokenAltTag $$) }
       word            { Located _ _ _ (TokenWord $$) }
       'λ'             { Located _ _ _ TokenLambda }
       '->'            { Located _ _ _ TokenArrow }
@@ -149,7 +150,7 @@ Alters          : Alter ';' Alters              { $1 : $3 }
                 | Alter                         { [$1] }
 
 Alter           :: { Alter Name }
-Alter           : litint ParList '->' Expr      { Alter (AltData $1) $2 $4 }
+Alter           : alttag ParList '->' Expr      { Alter (AltTag $1) $2 $4 }
 
 Expr1           :: { Expr Name }
 Expr1           : litint                        { Lit $ IntL $1 }

src/Core/Syntax.hs

@@ -42,6 +42,7 @@ import Data.Pretty
 import Data.List                    (intersperse)
 import Data.Function                ((&))
 import Data.String
+import Data.HashMap.Strict          (HashMap)
 import Data.HashMap.Strict          qualified as H
 import Data.Hashable
 import Data.Text                    qualified as T
@@ -105,7 +106,8 @@ data Rec = Rec
          | NonRec
          deriving (Show, Read, Eq, Lift)
 
-data AltCon = AltData Tag
+data AltCon = AltData Name
+            | AltTag Tag
             | AltLit Lit
             | Default
             deriving (Show, Read, Eq, Lift)
@@ -127,7 +129,9 @@ data Module b = Module (Maybe (Name, [Name])) (Program b)
 
 data Program b = Program
     { _programScDefs   :: [ScDef b]
-    , _programTypeSigs :: H.HashMap b Type
+    , _programTypeSigs :: HashMap b Type
+    -- map constructors to their tag and arity
+    , _programDataTags :: HashMap b (Tag, Int)
     }
     deriving (Show, Lift, Generic)
     deriving (Semigroup, Monoid)
@@ -152,13 +156,6 @@ instance IsString Type where
         | otherwise     = TyVar . fromString $ s
         where (c:_) = s
 
--- instance (Hashable b) => Semigroup (Program b) where
---     p <> q = Program
---         { _programScDefs = _programScDefs p <> _programScDefs q }
-
--- instance (Hashable b) => Monoid (Program b) where
---     mempty = Program mempty mempty
-
 ----------------------------------------------------------------------------------
 
 class HasRHS s t a b | s -> a, t -> b, s b -> t, t a -> s where

src/GM.hs

@@ -724,7 +724,7 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
         compileD g as = fmap (compileA g) as
 
         compileA :: Env -> Alter' -> (Tag, Code)
-        compileA g (Alter (AltData t) as e) = (t, [Split n] <> c <> [Slide n])
+        compileA g (Alter (AltTag t) as e) = (t, [Split n] <> c <> [Slide n])
             where
                 n = length as
                 binds = (NameKey <$> as) `zip` [0..]