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==)
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
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
, 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)
<|> 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
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))}
\(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->(