From 71992db7d0e51f87934f7d9c0cf9ddbd3a8d0300 Mon Sep 17 00:00:00 2001
From: Mirek Kratochvil <exa.exa@gmail.com>
Date: Wed, 14 Dec 2022 20:47:29 +0100
Subject: [PATCH] lists

---
 app/Compiler.hs | 10 ++++++++++
 app/Frontend.hs |  5 ++++-
 app/IR.hs       |  6 ++++++
 app/Parser.hs   |  7 ++++---
 4 files changed, 24 insertions(+), 4 deletions(-)

diff --git a/app/Compiler.hs b/app/Compiler.hs
index 67ca20f..84a63a4 100644
--- a/app/Compiler.hs
+++ b/app/Compiler.hs
@@ -6,6 +6,16 @@ import qualified Data.Map as M
 import Code (Code, Datum(..), Heap, Instr(..), heapStruct)
 import IR (Id(..), PrlgInt(..), StrTable(..))
 
+desugarPrlg :: Int -> PrlgInt -> PrlgInt
+desugarPrlg list = go
+  where
+    go (CallI id ps) = CallI id $ map go ps
+    go (ListI (x:xs) t) =
+      CallI Id {str = list, arity = 2} [go x, go (ListI xs t)]
+    go (ListI [] Nothing) = LiteralI list
+    go (ListI [] (Just x)) = go x
+    go x = x
+
 varname :: String -> Bool
 varname ('_':_) = True
 varname (c:_) = isUpper c
diff --git a/app/Frontend.hs b/app/Frontend.hs
index 39689f2..8f908ef 100644
--- a/app/Frontend.hs
+++ b/app/Frontend.hs
@@ -47,9 +47,12 @@ interpret = (>> return True) . lex
     intern prlgs = do
       prlgi <- withStrTable $ \st -> IR.internPrlg st prlgs
       underscore <- findAtom "_"
+      list <- findAtom "[]"
       prlgv <-
         withStrTable $ \st ->
-          (st, C.squashVars $ C.variablizePrlg underscore st prlgi)
+          ( st
+          , C.squashVars $
+            C.variablizePrlg underscore st $ C.desugarPrlg list prlgi)
       compile prlgv
     compile prlgv = do
       commaId <- findStruct "," 2
diff --git a/app/IR.hs b/app/IR.hs
index 631cd16..f17547d 100644
--- a/app/IR.hs
+++ b/app/IR.hs
@@ -6,6 +6,7 @@ import qualified Data.Map as M
 data PrlgStr
   = CallS String [PrlgStr]
   | LiteralS String
+  | ListS [PrlgStr] (Maybe PrlgStr)
   deriving (Show)
 
 data Id =
@@ -18,6 +19,7 @@ data Id =
 data PrlgInt
   = CallI Id [PrlgInt] --TODO this should be Int
   | LiteralI Int
+  | ListI [PrlgInt] (Maybe PrlgInt) -- only exists before desugaring
   | VarI Int Int -- VarI localIndex strTableString
   | VoidI
   deriving (Show)
@@ -40,3 +42,7 @@ internPrlg = go
     go t (CallS str ps) =
       let (t', i) = strtablize t str
        in CallI (Id i $ length ps) <$> mapAccumL go t' ps
+    go t (ListS elems Nothing) = flip ListI Nothing <$> mapAccumL go t elems
+    go t (ListS elems (Just tail)) =
+      let (t', tail') = go t tail
+       in flip ListI (Just tail') <$> mapAccumL go t' elems
diff --git a/app/Parser.hs b/app/Parser.hs
index a9e4473..864cdc5 100644
--- a/app/Parser.hs
+++ b/app/Parser.hs
@@ -145,7 +145,7 @@ instance TraversableStream [Lexeme] where
 data PAST
   = Call String [[PAST]]
   | Seq [PAST]
-  | List [PAST] (Maybe [PAST])
+  | List [[PAST]] (Maybe [PAST])
   | Literal String
   deriving (Show, Eq)
 
@@ -181,7 +181,7 @@ list = do
   free lBracket
   choice
     [ List [] Nothing <$ free rBracket
-    , do items <- some seqItem
+    , do items <- splitOn [Literal ","] <$> some seqItem
          choice
            [ List items Nothing <$ free rBracket
            , List items . Just <$>
@@ -223,7 +223,8 @@ shuntPrlg :: Ops -> PAST -> ShuntResult
 shuntPrlg ot = shuntPrlg' (("", Op 0 $ Infix X Y) : ot)
 
 shuntPrlg' :: Ops -> PAST -> ShuntResult
-shuntPrlg' ot (List _ _) = err "no lists yet"
+shuntPrlg' ot (List hs t) =
+  ListS <$> traverse (shunt ot) hs <*> traverse (shunt ot) t
 shuntPrlg' ot (Seq ss) = shunt ot ss
 shuntPrlg' ot (Literal s) = pure (LiteralS s)
 shuntPrlg' ot (Call fn ss) = CallS fn <$> traverse (shunt ot) ss