Support tuple syntax without having to declare PairN (#162)

Author: j-hui

regression-tests/tests/func_match_tuple.ssl

@@ -1,13 +1,3 @@
-// checking that 3-tuples and 4-tuples can be declared with new syntax
-type Pair2 a b
-    Pair2 a b
-
-
-type Pair3 a b c
-  Pair3 a b c
-
-
-
 putip_ putc x =
   if x < 10
     putc (x + 48)

regression-tests/tests/tuple-lib.lib

@@ -40,10 +40,9 @@ main cin cout =
     let puti = puti_ putc
     let printl l = printl_ puti putc l
 
-    
     let x_ = Pair3 1 2 3
     let y_ = Pair3 4 5 6
-    
+
     printl x_
     putnl ()
     printl y_

regression-tests/tests/tuple1.ssl

@@ -1,15 +1,9 @@
 // tests whether a 2-tuple(Pair) can be implemented in Ssland with ADTs
+// without builtin syntax
+
 type Pair2 a b
     Pair2 a b
 
-
-type Pair3 a b c
-  Pair3 a b c
-
-
-type Pair4 a b c d
-    Pair4 a b c d
-
 putip_ putc x =
   if x < 10
     putc (x + 48)
@@ -27,12 +21,12 @@ puti_ putc x =
 // tests the pattern match of pairs
 printl_ puti putc p =
   match p
-    (x,y) = puti x
-            putc 32
-            puti y
+    Pair2 x y = puti x
+                putc 32
+                puti y
 
 
-main cin cout = 
+main cin cout =
     let putc c = after 1, cout <- c
                  wait cout
     let puti = puti_ putc

regression-tests/tests/tuple2.ssl

@@ -1,15 +1,3 @@
-// checking that 2-tuples can be declared with new syntax
-type Pair2 a b
-    Pair2 a b
-
-
-type Pair3 a b c
-  Pair3 a b c
-
-
-type Pair4 a b c d
-    Pair4 a b c d
-
 putip_ putc x =
   if x < 10
     putc (x + 48)

regression-tests/tests/tuple2_nsyntax.ssl

@@ -1,15 +1,3 @@
-// checking that 3-tuples and 4-tuples can be declared with new syntax
-type Pair2 a b
-    Pair2 a b
-
-
-type Pair3 a b c
-  Pair3 a b c
-
-
-type Pair4 a b c d
-    Pair4 a b c d
-
 putip_ putc x =
   if x < 10
     putc (x + 48)

regression-tests/tests/tuple3.ssl

@@ -1,15 +1,3 @@
-// checking that 3-tuples and 4-tuples can be declared with new syntax
-type Pair2 a b
-    Pair2 a b
-
-
-type Pair3 a b c
-  Pair3 a b c
-
-
-type Pair4 a b c d
-    Pair4 a b c d
-
 putip_ putc x =
   if x < 10
     putc (x + 48)

regression-tests/tests/tuple_nested.ssl

@@ -1,12 +1,4 @@
 // checking that 5 tuples, 6 tuples.... can be declared with new syntax
-
-type Pair6 a b c d e f
-    Pair6 a b c d e f
-
-type Pair5 a b c d e
-    Pair5 a b c d e
-
-
 putip_ putc x =
   if x < 10
     putc (x + 48)

regression-tests/tests/tuplen.ssl

@@ -57,11 +57,11 @@ module Common.Identifiers (
   isVar,
   mangle,
   mangleVars,
+  isReserved,
+  reserved,
   isGenerated,
   genId,
   ungenId,
-  tuple,
-  tempTuple,
   cons,
   nil,
 ) where
@@ -87,6 +87,7 @@ import Data.String (IsString (..))
 
 import Language.C (Id (..))
 import Language.C.Quote (ToIdent (..))
+import Data.List (isPrefixOf)
 
 
 -- | A type that may be used as a Sslang identifier.
@@ -264,6 +265,16 @@ isVar :: Identifiable a => a -> Bool
 isVar = not . isCons
 
 
+-- | Create a reserved identifier (that can be code-generated as long as a can)
+reserved :: Identifiable a => a -> a
+reserved a = fromString $ "__sslang_builtin__" <> ident a
+
+
+-- | Whether an identifier is reserved.
+isReserved :: Identifiable a => a -> Bool
+isReserved i = "__sslang_builtin__" `isPrefixOf` s
+  where s = ident i
+
 -- | Whether an identifier is an compiler-generated variable name.
 isGenerated :: Identifiable a => a -> Bool
 isGenerated i
@@ -321,16 +332,6 @@ mangleVars :: (Data a) => a -> a
 mangleVars = mangle (Proxy :: Proxy VarId) . mangle (Proxy :: Proxy TVarId)
 
 
--- | the tuple identifier
-tuple :: Identifier
-tuple = Identifier "(,)"
-
-
--- | we'll use this temp tuple name for now due to the naming issue
-tempTuple :: Identifier
-tempTuple = Identifier "Pair"
-
-
 -- | Cons identifier for Lists
 cons :: Identifier
 cons = Identifier "Cons"

src/Common/Identifiers.hs

@@ -60,7 +60,7 @@ import Common.Compiler (
   warn,
  )
 import Common.Default (Default (..))
-import Common.Identifiers (Identifiable (..), Identifier (..), isCons, isVar)
+import Common.Identifiers (Identifiable (..), Identifier (..), isCons, isReserved, isVar)
 
 import qualified Front.Ast as A
 import Front.Identifiers (
@@ -168,28 +168,32 @@ ensureUnique ids = do
     i : _ -> throwError $ ScopeError $ "Defined more than once: " <> showId i
 
 
+-- | Ensure that an identifier will not clash with compiler-generated ones
+ensureNotReserved :: Identifier -> ScopeFn ()
+ensureNotReserved i = do
+  when (isReserved i) $ throwError nameErr
+ where
+  nameErr = NameError $ showId i <> " may clash with internal sslang-generated identifiers"
+
+
 -- | Check that a constructor 'Identifier' has the right naming convention.
 ensureCons :: Identifier -> ScopeFn ()
 ensureCons i = do
   ensureNonempty i
+  ensureNotReserved i
   unless (isCons i) $ throwError nameErr
  where
-  nameErr =
-    NameError $
-      showId i
-        <> " should begin with upper case or begin and end with ':'"
+  nameErr = NameError $ showId i <> " should begin with upper case or begin and end with ':'"
 
 
 -- | Check that a variable 'Identifier' has the right naming convention.
 ensureVar :: Identifier -> ScopeFn ()
 ensureVar i = do
   ensureNonempty i
+  ensureNotReserved i
   unless (isVar i) $ throwError nameErr
  where
-  nameErr =
-    NameError $
-      showId i
-        <> " should begin with upper case or begin and end with ':'"
+  nameErr = NameError $ showId i <> " should begin with upper case or begin and end with ':'"
 
 
 {- | Validate a declaration of a data 'Identifier'.

src/Front/Scope.hs

@@ -30,9 +30,10 @@ import qualified IR.Types as I
 
 import Control.Monad (unless)
 import Data.Bifunctor (Bifunctor (..))
+import Data.Generics (everything, mkQ)
 import Data.Maybe (fromMaybe)
 import qualified Data.Set as S
-import IR.Types.Type (tempTupleId)
+import IR.Types.Type (tupleId)
 
 
 -- | Unannotated terms appear as an empty stack.
@@ -52,9 +53,9 @@ annType = ann . I.AnnType
 
 -- | Lower an AST 'Program' into IR.
 lowerProgram :: A.Program -> Compiler.Pass (I.Program I.Annotations)
-lowerProgram (A.Program ds) = do
+lowerProgram p@(A.Program ds) = do
   let (tds, cds, xds, dds) = A.getTops ds
-  tds' <- mapM lowerTypeDef tds
+  tds' <- (++) <$> lowerTupleDefs p <*> mapM lowerTypeDef tds
   xds' <- mapM lowerExternDecl xds
   dds' <- mapM lowerDef dds
   return $
@@ -66,21 +67,58 @@ lowerProgram (A.Program ds) = do
       , I.cDefs = concat cds
       , I.symTable = I.uninitializedSymTable
       }
+
+
+lowerTypeDef :: A.TypeDef -> Compiler.Pass (I.TConId, I.TypeDef)
+lowerTypeDef td = do
+  tds <- mapM lowerTypeVariant $ A.typeVariants td
+  return
+    ( fromId $ A.typeName td
+    , I.TypeDef{I.targs = map TVarId $ A.typeParams td, I.variants = tds}
+    )
+ where
+  lowerTypeVariant ::
+    A.TypeVariant -> Compiler.Pass (I.DConId, I.TypeVariant)
+  lowerTypeVariant (A.VariantUnnamed vn ts) =
+    (fromId vn,) . I.VariantUnnamed <$> mapM lowerType ts
+
+
+lowerTupleDefs :: A.Program -> Compiler.Pass [(I.TConId, I.TypeDef)]
+lowerTupleDefs dds = return $ map lowerTupleDef $ S.toList tupleSizes
  where
-  lowerTypeDef :: A.TypeDef -> Compiler.Pass (I.TConId, I.TypeDef)
-  lowerTypeDef td = do
-    tds <- mapM lowerTypeVariant $ A.typeVariants td
-    return
-      ( fromId $ A.typeName td
-      , I.TypeDef{I.targs = map TVarId $ A.typeParams td, I.variants = tds}
-      )
-   where
-    lowerTypeVariant
-      :: A.TypeVariant -> Compiler.Pass (I.DConId, I.TypeVariant)
-    lowerTypeVariant (A.VariantUnnamed vn ts) =
-      (fromId vn,) . I.VariantUnnamed <$> mapM lowerType ts
-  lowerExternDecl :: A.ExternDecl -> Compiler.Pass (I.VarId, I.Type)
-  lowerExternDecl (A.ExternDecl i t) = (fromId i,) <$> lowerType t
+  tupleSizes :: S.Set Int
+  tupleSizes =
+    -- This is so hilariously inefficient but I tell myself it's ok
+    everything S.union (mkQ S.empty dconTupleLen) dds
+      `S.union` everything S.union (mkQ S.empty patTupleLen) dds
+      `S.union` everything S.union (mkQ S.empty typeTupleLen) dds
+
+  dconTupleLen :: A.Expr -> S.Set Int
+  dconTupleLen (A.Tuple es) = S.singleton $ length es
+  dconTupleLen (A.Par es) = S.singleton $ length es
+  dconTupleLen _ = S.empty
+
+  patTupleLen :: A.Pat -> S.Set Int
+  patTupleLen (A.PatTup es) = S.singleton $ length es
+  patTupleLen _ = S.empty
+
+  typeTupleLen :: A.Typ -> S.Set Int
+  typeTupleLen (A.TTuple tys) = S.singleton $ length tys
+  typeTupleLen _ = S.empty
+
+  lowerTupleDef :: Int -> (I.TConId, I.TypeDef)
+  lowerTupleDef i =
+    let targs = map (TVarId . fromString . (("tup" ++ show i ++ "arg") ++) . show) [1 .. i]
+     in ( tupleId i
+        , I.TypeDef
+            { I.targs = targs
+            , I.variants = [(tupleId i, I.VariantUnnamed $ map I.TVar targs)]
+            }
+        )
+
+
+lowerExternDecl :: A.ExternDecl -> Compiler.Pass (I.VarId, I.Type)
+lowerExternDecl (A.ExternDecl i t) = (fromId i,) <$> lowerType t
 
 
 -- | Lower an 'A.Definition' into a name and bound expression.
@@ -207,7 +245,7 @@ lowerExpr (A.Match s ps) =
  where
   lowerArm (a, e) = (,) <$> lowerPatAlt a <*> lowerExpr e
 lowerExpr (A.Tuple es) =
-  apply_recurse (I.Data (I.DConId (tempTupleId $ length es)) untyped) <$> mapM lowerExpr es
+  apply_recurse (I.Data (I.DConId (tupleId $ length es)) untyped) <$> mapM lowerExpr es
  where
   apply_recurse e [] = e
   apply_recurse e (x : xs) = apply_recurse (I.App e x untyped) xs
@@ -223,7 +261,7 @@ lowerPatAlt (A.PatId i)
   | otherwise = return $ I.AltData (I.DConId i) [] untyped
 lowerPatAlt (A.PatLit l) = I.AltLit <$> lowerLit l <*> pure untyped
 lowerPatAlt (A.PatTup ps) =
-  I.AltData (I.tempTupleId $ length ps) <$> mapM lowerPatAlt ps <*> pure untyped
+  I.AltData (I.tupleId $ length ps) <$> mapM lowerPatAlt ps <*> pure untyped
 lowerPatAlt p@(A.PatApp _) = case A.collectPApp p of
   (A.PatId i, ps) | isCons i -> I.AltData (fromId i) <$> mapM lowerPatAlt ps <*> pure untyped
   _ -> Compiler.unexpected "lowerPatAlt: app head should be a data constructor"