feat: syntactic variants

compiler/src/AddAmbientMethods.hs

@@ -21,27 +21,27 @@ printDecl :: FunDecl
 printDecl = FunDecl "print"  
     [Lambda [VarPattern "x"] $
         Let [ValDecl (VarPattern "out") (App (Var "getStdout") [Var "authority"]) NoPos]
-            (App (Var "fprintln") [Tuple [Var "out", Var "x"]])
+            (App (Var "fprintln") [Tuple [Var "out", Var "x"] False])
     ] NoPos
 
 printWithLabelsDecl :: FunDecl 
 printWithLabelsDecl = FunDecl "printWithLabels" 
     [Lambda [VarPattern "x"] $
         Let [ValDecl (VarPattern "out") (App (Var "getStdout") [Var "authority"]) NoPos]
-            (App (Var "fprintlnWithLabels") [Tuple [Var "out", Var "x"]])
+            (App (Var "fprintlnWithLabels") [Tuple [Var "out", Var "x"] False])
     ] NoPos
 
 
 printStringDecl :: FunDecl 
 printStringDecl = FunDecl "printString"
     [Lambda [VarPattern "x"] $
         Let [ValDecl (VarPattern "out") (App (Var "getStdout") [Var "authority"]) NoPos]
-            (App (Var "fwrite") [Tuple [Var "out", Bin Concat (Var "x") (Lit (LString "\\n"))]])
+            (App (Var "fwrite") [Tuple [Var "out", Bin Concat (Var "x") (Lit (LString "\\n"))] False])
     ] NoPos
 
 
 
 addAmbientMethods :: Prog -> Prog 
 addAmbientMethods (Prog imports atoms t) = 
     let t' = Let [FunDecs [printDecl,printWithLabelsDecl,printStringDecl]] t
-    in Prog imports atoms t'
+    in Prog imports atoms t'

compiler/src/AtomFolding.hs

@@ -2,19 +2,27 @@ module AtomFolding ( visitProg )
 where
 import Basics
 import Direct
-import Data.Maybe
 import Control.Monad
+import Data.List (find, any)
 
 visitProg :: Prog -> Prog
-visitProg (Prog imports (Atoms atms) tm) =
-  Prog imports (Atoms atms) (visitTerm atms tm)
+visitProg (Prog imports (DataTypes datatypes) tm) =
+  let tcs = concat $ map snd datatypes 
+  in Prog imports (DataTypes datatypes) (visitTerm tcs tm)
 
-visitTerm :: [AtomName] -> Term -> Term
+visitTerm :: [TypeConstructor] -> Term -> Term
 visitTerm atms (Lit lit) = Lit lit
 visitTerm atms (Var nm) =
-  if (elem nm atms)
-  then Lit (LAtom nm)
-  else Var nm
+  let tag = "tag"
+      value = "value"
+      var = "v"
+  in case find (\x -> (fst x) == nm) atms of
+    Nothing -> Var nm
+    Just (t, []) -> Tuple [Lit (LString nm)] True -- Convert atom into a tuple
+    Just (t, _) ->
+      Abs (Lambda [VarPattern var] (Tuple  [ Lit (LString nm)
+                                           , Var var
+                                           ] True))
 visitTerm atms (Abs lam) =
   Abs (visitLambda atms lam)
 visitTerm atms (Hnd (Handler pat maybePat maybeTerm term)) =
@@ -36,9 +44,9 @@ visitTerm atms (Case t declTermList p) =
   p
 visitTerm atms (If t1 t2 t3) =
   If (visitTerm atms t1) (visitTerm atms t2) (visitTerm atms t3)
-visitTerm atms (Tuple terms) =
-  Tuple (map (visitTerm atms) terms)
-visitTerm atms (Record fields) =  Record (visitFields atms fields)    
+visitTerm atms (Tuple terms tag) =
+  Tuple (map (visitTerm atms) terms) tag
+visitTerm atms (Record fields) = Record (visitFields atms fields)
 visitTerm atms (WithRecord e fields) = 
     WithRecord (visitTerm atms e) (visitFields atms fields)
 visitTerm atms (ProjField t f) =
@@ -63,10 +71,10 @@ visitFields atms fs  =  map visitField fs
     where visitField (f, Nothing) = (f, Nothing) 
           visitField (f, Just t) = (f, Just (visitTerm atms t))
 
-visitPattern :: [AtomName] -> DeclPattern -> DeclPattern
+visitPattern :: [TypeConstructor] -> DeclPattern -> DeclPattern
 visitPattern atms pat@(VarPattern nm) =
-  if (elem nm atms)
-  then ValPattern (LAtom nm)
+  if any (\x -> x == (nm, [])) atms
+  then TuplePattern [ValPattern (LString nm)] -- Convert atom match into a record match
   else pat
 visitPattern _ pat@(ValPattern _) = pat
 visitPattern atms (AtPattern p l) = AtPattern (visitPattern atms p) l
@@ -77,7 +85,11 @@ visitPattern atms (ListPattern pats) = ListPattern (map (visitPattern atms) pats
 visitPattern atms (RecordPattern fields mode) = RecordPattern (map visitField fields) mode
       where visitField pat@(_, Nothing) = pat 
             visitField (f, Just p) = (f, Just (visitPattern atms p))
+visitPattern atms (DataTypePattern nm pat) =
+  TuplePattern [ ValPattern (LString nm), visitPattern atms pat]
+
 
-visitLambda :: [AtomName] -> Lambda -> Lambda
+visitLambda :: [TypeConstructor] -> Lambda -> Lambda
 visitLambda atms (Lambda pats term) =
   (Lambda (map (visitPattern atms) pats) (visitTerm atms term))
+

compiler/src/Basics.hs

@@ -10,7 +10,12 @@ import Data.Serialize (Serialize)
 
 type VarName = String
 type AtomName = String
+type DataTypeName = String
+type TypeConstructorName = String
+type TypeConstructor = (TypeConstructorName, [VarName])
+type DataTypeDef = (DataTypeName, [TypeConstructor])
 type FieldName = String
+type ADTTag = Bool
 
 -- | Eq and Neq: deep equality check on the two parameters, including the types (any type inequality results in false being returned).
 data BinOp = Plus | Minus | Mult | Div | Mod |  Eq | Neq | Le | Lt | Ge | Gt | And | Or | RaisedTo | FlowsTo | Concat| IntDiv | BinAnd | BinOr | BinXor | BinShiftLeft | BinShiftRight | BinZeroShiftRight | HasField | LatticeJoin | LatticeMeet

compiler/src/CPSOpt.hs

@@ -77,8 +77,8 @@ instance Substitutable SimpleTerm where
     case simpleTerm of
       Bin op v1 v2 -> Bin op (fwd v1) (fwd v2)
       Un op v -> Un op (fwd v)
-      Tuple vs -> Tuple (map fwd vs)
-      Record fields -> Record $ fwdFields fields
+      Tuple vs tag -> Tuple (map fwd vs) tag
+      Record fields -> Record (fwdFields fields)
       WithRecord x fields -> WithRecord (fwd x) $ fwdFields fields
       ProjField x f -> ProjField (fwd x) f
       ProjIdx x idx -> ProjIdx (fwd x) idx
@@ -145,7 +145,7 @@ instance CensusCollectible SimpleTerm where
       Bin _ v1 v2 -> updateCensus [v1,v2]
       Un _ v -> updateCensus v 
       ValSimpleTerm sv -> updateCensus sv 
-      Tuple vs -> updateCensus vs 
+      Tuple vs _ -> updateCensus vs 
       Record fs -> let (_,vs) = unzip fs in updateCensus vs 
       WithRecord v fs -> updateCensus v >> (let (_,vs) = unzip fs in updateCensus vs )
       ProjField v _ -> updateCensus v
@@ -326,30 +326,30 @@ simplifySimpleTerm t =
     v <- look operand 
     -- TODO should write out all cases
     case (op,v) of 
-        (Basics.IsTuple, St (Tuple _))          -> _ret __trueLit 
-        (Basics.IsTuple, St (Record _))         -> _ret __falseLit
+        (Basics.IsTuple, St (Tuple _ _))          -> _ret __trueLit 
+        (Basics.IsTuple, St (Record _))       -> _ret __falseLit
         (Basics.IsTuple, St (WithRecord _ _))   -> _ret __falseLit
         (Basics.IsTuple, St (List _))           -> _ret __falseLit
         (Basics.IsTuple, St (ListCons _ _))     -> _ret __falseLit
         (Basics.IsTuple, St (ValSimpleTerm _))  -> _ret __falseLit
 
 
-        (Basics.IsRecord, St (Record _))        -> _ret __trueLit
+        (Basics.IsRecord, St (Record _))      -> _ret __trueLit
         (Basics.IsRecord, St (WithRecord _ _))  -> _ret __trueLit 
-        (Basics.IsRecord, St (Tuple _))         -> _ret __falseLit
+        (Basics.IsRecord, St (Tuple _ _))         -> _ret __falseLit
         (Basics.IsRecord, St (List _))          -> _ret __falseLit
         (Basics.IsRecord, St (ListCons _ _))    -> _ret __falseLit
         (Basics.IsRecord, St (ValSimpleTerm _)) -> _ret __falseLit
 
 
         (Basics.IsList, St (List _))          -> _ret __trueLit
         (Basics.IsList, St (ListCons _ _))    -> _ret __trueLit
-        (Basics.IsList, St (Record _))        -> _ret __falseLit
+        (Basics.IsList, St (Record _))      -> _ret __falseLit
         (Basics.IsList, St (WithRecord _ _))  -> _ret __falseLit 
-        (Basics.IsList, St (Tuple _))         -> _ret __falseLit
+        (Basics.IsList, St (Tuple _ _))         -> _ret __falseLit
         (Basics.IsList, St (ValSimpleTerm _)) -> _ret __falseLit
 
-        (Basics.TupleLength, St (Tuple xs)) -> 
+        (Basics.TupleLength, St (Tuple xs _)) -> 
             _ret $ lit (C.LInt (fromIntegral (length xs)) NoPos)
         -- 2023-08 Revision: Added this case
         (Basics.ListLength, St (List xs)) -> 
@@ -366,7 +366,7 @@ simplifySimpleTerm t =
   ProjIdx x idx -> do
     t <- look x
     case t of
-      St (Tuple vs) | fromIntegral (length vs) > idx ->
+      St (Tuple vs _) | fromIntegral (length vs) > idx ->
         _subst (vs !! fromIntegral idx)
       _ -> _nochange
 
@@ -409,7 +409,7 @@ failFree st = case st of
   Bin op _ _ ->  op `elem` [Basics.Eq, Basics.Neq] -- Equality comparisons are safe (return boolean)
   Un _ _ -> False  -- Unary operations can fail (e.g., head on empty list, arithmetic on non-numbers)
   ValSimpleTerm _ -> True 
-  Tuple _ -> True 
+  Tuple _ _ -> True 
   Record _ -> True 
   WithRecord _ _ -> True 
   ProjField _ _ -> False  -- Field projection can fail if field doesn't exist
@@ -546,4 +546,4 @@ iter kt =
 
 rewrite :: Prog -> Prog
 rewrite (Prog atoms kterm) = 
- Prog atoms (iter kterm)
+ Prog atoms (iter kterm)

compiler/src/CaseElimination.hs

@@ -31,8 +31,8 @@
   tm'' <- transTerm tm'
   return (T.Prog imports atms' tm'')
 
-transAtoms :: S.Atoms -> Trans T.Atoms
-transAtoms (S.Atoms atms) = return (T.Atoms atms)
+transAtoms :: S.DataTypes -> Trans T.DataTypes
+transAtoms (S.DataTypes atms) = return (T.DataTypes atms)
 
 transLit :: S.Lit -> T.Lit
 transLit (S.LInt n pi)    = T.LInt n pi
@@ -41,7 +41,7 @@
 transLit (S.LDCLabel dc)  = T.LDCLabel dc
 transLit (S.LUnit)     = T.LUnit
 transLit (S.LBool b)   = T.LBool b
-transLit (S.LAtom a)   = T.LAtom a
+transLit (S.LDataType a)   = T.LDataType a
 
 
 transLambda_aux :: S.Lambda -> ReaderT T.Term Trans Lambda
@@ -95,8 +95,8 @@
               Just pat2 -> pat2
               Nothing   -> S.Wildcard      
       lambdaPats = [S.VarPattern argInput] 
-      callFailure = S.Tuple [S.Lit (S.LInt 1 _srcRT), S.Lit S.LUnit ]  
-      body' =  S.Tuple[ S.Lit (S.LInt 0 _srcRT), S.Abs ( S.Lambda [S.Wildcard] body )  ]
+      callFailure = S.Tuple [S.Lit (S.LInt 1 _srcRT), S.Lit S.LUnit ] False
+      body' =  S.Tuple[ S.Lit (S.LInt 0 _srcRT), S.Abs ( S.Lambda [S.Wildcard] body )  ] False
       guardCheck = case guard of
          Nothing -> body'
          Just g -> S.If g body' callFailure
@@ -120,7 +120,7 @@
 -- v: the term to be assigned to the pattern
 -- The Reader monad stores the error term.
 compilePattern :: T.Term -> (T.Term, S.DeclPattern) -> ReaderT T.Term Trans T.Term
 compilePattern succ (v, (S.AtPattern p l))  = do
   fail <- ask
   succ' <- compilePattern succ (v, p)
   return $ ifpat (Bin Eq (Un LevelOf v) (Lit (LLabel l))) succ' fail
@@ -211,7 +211,7 @@
       let lams' = map (transLambda_aux . (\(S.Lambda args e) -> S.Lambda [S.TuplePattern args] e)) lams
           names = map (((f ++ "_pat") ++) . show) [1..(length lams)]
           args =  map (((f ++ "_arg") ++) . show) [1..(argLength lams)]
-          args' =  Tuple (map Var args)
+          args' =  Tuple (map Var args) False
           errorMsg = Error (Lit (LString $ "pattern match failure in function " ++ f)) pos
       (fst, decls) <- foldr (\(n, l) acc -> do
             (fail, decls) <- acc
@@ -257,9 +257,9 @@
   t2' <- transTerm t2
   t3' <- transTerm t3
   return (If t1' t2' t3')
-transTerm (S.Tuple tms) = do
+transTerm (S.Tuple tms tag) = do
   tms' <- mapM transTerm tms
-  return (T.Tuple tms')
+  return (T.Tuple tms' tag)
 transTerm (S.Record fields) = do
   fields' <- transFields fields
   return (T.Record fields')
@@ -302,4 +302,4 @@
   (f, Nothing) -> return (f, T.Var f)
   (f, Just t) -> do
     t' <- transTerm t
-    return (f, t')
+    return (f, t')

compiler/src/ClosureConv.hs

@@ -162,9 +162,9 @@ cpsToIR (CPS.LetSimple vname@(VN ident) st kt) = do
         CPS.Un unop v -> do 
           v' <- transVar v
           _assign (Un unop v')
-        CPS.Tuple lst -> do 
+        CPS.Tuple lst tag -> do 
           lst' <- transVars lst 
-          _assign (Tuple lst')
+          _assign (Tuple lst' tag)
         CPS.Record fields -> do
           fields' <- transFields fields
           _assign (Record fields')

compiler/src/Core.hs

@@ -34,6 +34,7 @@ import           ShowIndent
 
 import           TroupePositionInfo
 import           DCLabels
+import Data.List (find)
 
 --------------------------------------------------
 -- AST is the same as Direct, but lambda are unary (or nullary)
@@ -57,7 +58,7 @@ data Lit
     | LDCLabel DCLabelExp
     | LUnit
     | LBool Bool
-    | LAtom AtomName
+    | LAtom TypeConstructorName
   deriving (Show, Generic)
 instance Serialize Lit
 instance Eq Lit where 
@@ -107,8 +108,8 @@ data Term
     | Let Decl Term
     | If Term Term Term
     | AssertElseError Term Term Term PosInf
-    | Tuple [Term]
-    | Record Fields 
+    | Tuple [Term] ADTTag
+    | Record Fields
     | WithRecord Term Fields
     | ProjField Term FieldName 
     | ProjIdx Term Word
@@ -157,8 +158,8 @@ lowerProg (D.Prog imports atms term) = Prog imports (trans atms) (lower term)
 
 -- the rest of the declarations in this part are not exported
 
-trans :: D.Atoms -> Atoms
-trans (D.Atoms atms) = Atoms atms
+trans :: D.DataTypes -> Atoms
+trans (D.DataTypes atms) = Atoms [] -- (concat $ map snd atms)
 
 lowerLam (D.Lambda vs t) =
   case vs of
@@ -172,7 +173,7 @@ lowerLit (D.LLabel s) = LLabel s
 lowerLit (D.LDCLabel dc) = LDCLabel dc
 lowerLit D.LUnit = LUnit
 lowerLit (D.LBool b) = LBool b
-lowerLit (D.LAtom n) = LAtom n
+lowerLit (D.LDataType n) = LAtom n
 
 lower :: D.Term -> Core.Term
 lower (D.Lit l) = Lit (lowerLit l)
@@ -198,7 +199,7 @@ lower (D.Let decls e) =
 -- lower (D.Case t patTermLst) = Case (lower t) (map (\(p,t) -> (lowerDeclPat p, lower t)) patTermLst)
 lower (D.If e1 e2 e3) = If (lower e1) (lower e2) (lower e3)
 lower (D.AssertElseError e1 e2 e3 p) = AssertElseError (lower e1 ) (lower e2) (lower e3) p
-lower (D.Tuple terms) = Tuple (map lower terms)
+lower (D.Tuple terms tag) = Tuple (map lower terms) tag
 lower (D.Record fields) = Record (map (\(f, t) -> (f, lower t)) fields)
 lower (D.WithRecord  e fields) = WithRecord (lower e) (map (\(f, t) -> (f, lower t)) fields)
 lower (D.ProjField t f) = ProjField (lower t) f
@@ -330,8 +331,8 @@ rename (AssertElseError t1 t2 t3 p) m = do
   return $ AssertElseError t1' t2' t3' p
 
 
-rename (Tuple terms) m =
-  Tuple <$> mapM (flip rename m) terms
+rename (Tuple terms tag) m =
+  (\x -> Tuple x tag) <$> mapM (flip rename m) terms
 
 rename (Record fields) m = 
   Record <$> mapM renameField fields 
@@ -438,10 +439,14 @@ ppTerm' (Lit literal) = ppLit literal
 
 ppTerm' (Error t _) = text "error " PP.<> ppTerm' t
 
-ppTerm'  (Tuple ts) =
+ppTerm' (Tuple ts False) =
   PP.parens $
   PP.hcat $
   PP.punctuate (text ",") (map (ppTerm 0) ts)
+ppTerm' (Tuple ts True) =
+  case ts of [Lit (LString nm)] -> text nm
+             [Lit (LString nm), t] -> text nm PP.<> PP.space PP.<> ppTerm 0 t
+             otherwise -> text "error: MissingADT"
 
 ppTerm'  (List ts) =
   PP.brackets $
@@ -561,7 +566,7 @@ ppLit (LDCLabel dc) = ppDCLabelExpLit dc
 
 termPrec :: Term -> Precedence
 termPrec (Lit _)         = maxPrec
-termPrec (Tuple _)       = maxPrec
+termPrec (Tuple _ _)     = maxPrec
 termPrec (List _ )       = maxPrec
 termPrec (Var _)         = maxPrec
 termPrec (App _ _)       = appPrec