From 2fab7f2bdf340a121ee24f71f3b291d2ad26fc89 Mon Sep 17 00:00:00 2001
From: sebastianselander <sebastian.selander@gmail.com>
Date: Mon, 8 May 2023 20:22:57 +0200
Subject: [PATCH] more sample programs, added strings, added desugar for
 strings

---
 Grammar.cf                        |  1 +
 sample-programs/PriorityQueue.crf | 41 +++++++++++++++++++++++++++++++
 src/Desugar/Desugar.hs            |  7 +++++-
 src/Main.hs                       |  7 +++---
 4 files changed, 52 insertions(+), 4 deletions(-)
 create mode 100644 sample-programs/PriorityQueue.crf

diff --git a/Grammar.cf b/Grammar.cf
index a9ef462..e8eac5b 100644
--- a/Grammar.cf
+++ b/Grammar.cf
@@ -82,6 +82,7 @@ define infixSymbol e1 vn e3 = EApp (EApp (EVarS (VSymbol vn)) e1) e3;
 
 LInt.  Lit ::= Integer;
 LChar. Lit ::= Char;
+LString. Lit ::= String ;
 
 -------------------------------------------------------------------------------
 -- * AUX
diff --git a/sample-programs/PriorityQueue.crf b/sample-programs/PriorityQueue.crf
new file mode 100644
index 0000000..cd8487d
--- /dev/null
+++ b/sample-programs/PriorityQueue.crf
@@ -0,0 +1,41 @@
+data Skewheap where
+    Empty : Skewheap
+    Node : Skewheap -> Int -> Skewheap -> Skewheap
+
+data Maybe a where
+    Nothing : Maybe a
+    Just : a -> Maybe a
+
+data Pair a b where
+    Pair : a -> b -> Pair a b
+
+data List a where
+    Nil : List a
+    Cons : a -> List a -> List a
+
+empty = Empty
+
+singleton x = Node Empty x Empty
+
+peek : Skewheap -> Maybe Int
+peek tree = case tree of
+    Node _ x _ => Just x
+    _ => Nothing
+
+pop tree = case tree of
+    Node l x r => Just (Pair x (merge l r))
+    Empty => Nothing 
+
+merge tree1 tree2 = case tree1 of
+    Node left1 val1 right1 => case tree2 of
+        Node left2 val2 right2 => case val1 < val2 of
+            True => Node (merge right1 (Node left2 val2 right2)) val1 left1
+            False => Node (merge right2 (Node left1 val1 right1)) val2 left2
+        _ => tree1
+    Empty => tree2
+
+insert x tree = merge (singleton x) tree
+
+main = case peek (insert 1 (insert 2 (insert 3 (singleton 4)))) of
+    Nothing => (0 - 1)
+    Just x => x
diff --git a/src/Desugar/Desugar.hs b/src/Desugar/Desugar.hs
index 7bcf417..1879d0c 100644
--- a/src/Desugar/Desugar.hs
+++ b/src/Desugar/Desugar.hs
@@ -71,10 +71,14 @@ desugarExp = \case
     EAnn e t                      -> EAnn (desugarExp e) (desugarType t)
     EVarS (VSymbol (Symbol symb)) -> EVar (LIdent $ fixName symb)
     EVarS (VIdent (LIdent ident)) -> EVar $ LIdent $ fixName ident
-    EVar i                        -> EVar i
+    EVar (LIdent i)                        -> EVar (LIdent $ fixName i)
+    ELit (LString str)            -> toList str
     ELit l                        -> ELit l
     EInj i                        -> EInj i
 
+toList :: String -> Exp
+toList = foldr (EApp . EApp (EInj (UIdent "Cons")) . ELit . LChar) (EInj (UIdent "Nil"))
+
 desugarBranch :: Branch -> Branch
 desugarBranch (Branch p e) = Branch (desugarPattern p) (desugarExp e)
 
@@ -89,6 +93,7 @@ desugarPattern = \case
 desugarLit :: Lit -> Lit
 desugarLit (LInt i)  = LInt i
 desugarLit (LChar c) = LChar c
+desugarLit (LString c) = LString c
 
 fixName :: String -> String
 fixName = concatMap mapSymbols
diff --git a/src/Main.hs b/src/Main.hs
index 9862d8e..ad7d335 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -69,7 +69,7 @@ initOpts =
         , debug = False
         , gc = True
         , typechecker = Nothing
-        , preludeOpt = True
+        , preludeOpt = False
         }
 
 enableHelp :: Options -> Options
@@ -97,7 +97,7 @@ data Options = Options
     , debug       :: Bool
     , gc          :: Bool
     , typechecker :: Maybe TypeChecker
-    , preludeOpt     :: Bool
+    , preludeOpt  :: Bool
     }
 
 main' :: Options -> String -> IO ()
@@ -110,7 +110,8 @@ main' opts s =
             file <- readFile s
 
             printToErr "-- Parse Tree -- "
-            parsed <- fromErr . pProgram . resolveLayout True $ myLexer (file ++ prelude)
+            let file' = if opts.preludeOpt then file else file ++ prelude
+            parsed <- fromErr . pProgram . resolveLayout True $ myLexer file'
             log parsed
 
             printToErr "-- Desugar --"