From: Mart Lubbers <mart@martlubbers.net>
Date: Thu, 2 Sep 2021 07:07:44 +0000 (+0200)
Subject: allow case in expressions, parse expressions
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=181be5d6aa016a8ca9da9f1c0c19362f35934ed9;p=clean-tests.git

allow case in expressions, parse expressions
---

diff --git a/datatype/Compiler.hs b/datatype/Compiler.hs
index 5669725..79ee6b7 100644
--- a/datatype/Compiler.hs
+++ b/datatype/Compiler.hs
@@ -7,12 +7,12 @@ module Compiler where
 
 import Language
 import Serialise
-
+--
 import qualified Data.Map as DM
 import Control.Monad.Writer
 import Control.Monad.State
 import Control.Monad.ST
-import Debug.Trace
+--import Debug.Trace
 import Data.Array
 import Data.Array.ST
 import Data.Function
diff --git a/datatype/Language/Quote.hs b/datatype/Language/Quote.hs
index 8682f0e..f062647 100644
--- a/datatype/Language/Quote.hs
+++ b/datatype/Language/Quote.hs
@@ -59,6 +59,9 @@ pNonfix op p = flip id <$> p <*> op <*> p <|> p
 pSepBy :: (Monad m, Alternative m) => RParser m t s -> RParser m t a -> RParser m t [a]
 pSepBy sep el = (:) <$> el <*> many (sep *> el) <|> pure []
 
+pOptional :: (Monad m, Alternative m) => RParser m t a -> RParser m t (Maybe a)
+pOptional p = Just <$> p <|> pure Nothing
+
 pBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token s
 pBrack p = pSat (BOpen==) *> p <* pSat (BClose==)
 
@@ -66,7 +69,7 @@ pCBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token
 pCBrack p = pSat (COpen==) *> p <* pSat (CClose==)
 
 pCase :: (MonadFail m, Alternative m) => RParser m Token Exp
-pCase = mkCase <$ pSat (==Case) <*> pExp <* pSat (==Of) <*> some pCaseMatch
+pCase = mkCase <$ pSat (Case==) <*> pExp <* pSat (Of==) <*> some pCaseMatch
   where
     mkCase :: Exp -> [(Pat, Exp)] -> Exp
     mkCase name cases = foldr (uncurry mkCaseMatch) (VarE (mkName "bottom") `AppE` LitE (StringL "Exhausted case")) cases
@@ -107,7 +110,7 @@ pCase = mkCase <$ pSat (==Case) <*> pExp <* pSat (==Of) <*> some pCaseMatch
         mkCaseBinding _ p _ = error $ "Unsupported pat: " ++ show p
 
 pCaseMatch :: (MonadFail m, Alternative m) => RParser m Token (Pat, Exp)
-pCaseMatch = (,) <$> pPat <* pSat (==(Op "->")) <*> pExp <* optional (pSat (==SColon))
+pCaseMatch = (,) <$> pPat <* pSat ((Op "->")==) <*> pExp <* optional (pSat (SColon==))
 
 pExp :: (MonadFail m, Alternative m) => RParser m Token Exp
 pExp
@@ -120,12 +123,18 @@ pExp
     , pChainr $ parseOps ["|."]
     ] 
   where
-    parseOps = foldr1 (<|>) . map (\op->ifx op <$ pSat (==(Op op)))
+    parseOps :: (MonadFail m, Alternative m) => [String] -> RParser m Token (Exp -> Exp -> Exp)
+    parseOps = foldr1 (<|>) . map (\op->ifx op <$ pSat ((Op op)==))
 
+    pBasic :: (MonadFail m, Alternative m) => RParser m Token Exp
     pBasic
-        =   VarE <$> pVar
+        =   flip ($) . VarE <$> pVar <*> pFuncall
         <|> AppE (VarE (mkName "lit")) . LitE <$> pLit
         <|> pBrack pExp
+        <|> pCase
+
+    pFuncall :: (MonadFail m, Alternative m) => RParser m Token (Exp -> Exp)
+    pFuncall = maybe id (flip AppE . TupE) <$> pOptional (pBrack (pSepBy (pSat (Comma==)) pExp))
 
 pLit :: (MonadFail m, Alternative m) => RParser m Token Lit
 pLit = unlit <$> pSat (\x->case x of Lit _ -> True; _ -> False)
@@ -146,12 +155,12 @@ pPat
     <|> LitP <$> pLit
     <|> pBrack pPat
   where
-    pFieldPat = pSepBy (pSat (==Comma)) $
-        (,) <$> pVar <* pSat (==Equal) <*> pPat
+    pFieldPat = pSepBy (pSat (Comma==)) $
+        (,) <$> pVar <* pSat (Equal==) <*> pPat
 
 parseCP :: MonadFail m => [Char] -> m Exp
 --parseCP s = case runParser pCase (lexer s) of
-parseCP s = case runParser pCase (lexer (trace (show s) s)) of
+parseCP s = case runParser pExp (lexer (trace (show s) s)) of
     Nothing -> fail $ "Parsing failed for: " ++ show (lexer s)
 --    [] -> fail $ "Parsing failed for: " ++ show (lexer s)
     Just (_, t@(_:_)) -> fail $ "Non-exhaustive parse found: " ++ show t
diff --git a/datatype/Main.hs b/datatype/Main.hs
index bccc35d..8d31f60 100644
--- a/datatype/Main.hs
+++ b/datatype/Main.hs
@@ -94,7 +94,7 @@ f4
 f5 :: (List' v, Expression v, Function (v (List Int)) v) => Main (v Int)
 f5
     = fun ( \sumf->(\l->[cp|case l of
-                Cons e rest -> e +. sumf rest
+                Cons e rest -> e +. sumf(rest)
                 Nil -> 0
             |])
 --    :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))}
@@ -125,7 +125,7 @@ f7'
             \(from, to)->if' (from >. to) nil (from `cons` fromto (from +. lit 1, to))
     ) :- fun ( \mullist->(
             \l->[cp|case l of
-                Cons e rest -> e *. mullist rest
+                Cons e rest -> e *. mullist(rest)
                 Nil -> 1
             |]
     ) :- fun ( \fac->(