allow case in expressions, parse expressions

[clean-tests.git] / datatype / Language / Quote.hs

diff --git a/datatype/Language/Quote.hs b/datatype/Language/Quote.hs
index 8682f0e..f062647 100644 (file)
--- 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