import Data.Char
import Data.List
+import Data.Maybe
import Debug.Trace
import Control.Applicative
pBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token s
pBrack p = pSat (BOpen==) *> p <* pSat (BClose==)
+pCBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token s
+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
where
mkCase name cases = foldr (uncurry mkCaseMatch) (VarE (mkName "bottom") `AppE` LitE (StringL "Exhausted case")) cases
where
mkCaseMatch :: Pat -> Exp -> Exp -> Exp
- mkCaseMatch (VarP v) e _ = LetE [FunD v [Clause [] (NormalB name) []]] e
- mkCaseMatch WildP e _ = e
- mkCaseMatch (ConP consName fields) e rest
- = VarE (mkName "if'")
- `AppE` (VarE (mkName $ "is" ++ stringName consName) `AppE` name) --Predicate
- `AppE` LetE [mkFieldMatch idx f | f <- fields | idx <- [0 :: Int ..]] e
- `AppE` rest
- where
- mkFieldMatch idx (VarP v) = FunD v [Clause [] (NormalB $ VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` name) []]
--- mkFieldMatch idx p@(ConP consName fields) = FunD (mkName "f0") [Clause [] (NormalB $ mkCaseMatch p e (LitE (StringL "Exhausted case"))) []]
- mkFieldMatch _ p = error $ "Unsupported subpat: " ++ show p
-
- mkCaseMatch p _ _ = error $ "Unsupported pat: " ++ show p
+ mkCaseMatch a e rest = case mkCasePred name a of
+ Nothing -> LetE (mkCaseBinding name a []) e
+ Just p -> VarE (mkName "if'") `AppE` p `AppE` LetE (mkCaseBinding name a []) e `AppE` rest
+
+ mkCasePred :: Exp -> Pat -> Maybe Exp
+ mkCasePred objName (ConP consName fields) = Just $ foldl (ifx "&.")
+ (VarE (mkName $ "is" ++ stringName consName) `AppE` objName)
+ $ catMaybes $ [mkCasePred (VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` objName) f | f <- fields | idx <- [0 :: Int ..]]
+ mkCasePred objName (RecP consName fields) = Just $ foldl (ifx "&.")
+ (VarE (mkName $ "is" ++ stringName consName) `AppE` objName)
+ $ catMaybes $ [mkCasePred (VarE (selectorName n) `AppE` objName) p | (n, p) <- fields]
+ mkCasePred _ (VarP _) = Nothing
+ mkCasePred _ WildP = Nothing
+ mkCasePred objName (ParensP p) = mkCasePred objName p
+ mkCasePred objName (AsP _ p) = mkCasePred objName p
+ mkCasePred objName (LitP v) = Just (ifx "==." (VarE (mkName "lit") `AppE` LitE v) objName)
+ mkCasePred _ p = error $ "Unsupported pat: " ++ show p
+
+ mkCaseBinding :: Exp -> Pat -> [Dec] -> [Dec]
+ mkCaseBinding objName (ConP consName fields) ds = foldr ($) ds $
+ [mkCaseBinding (VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` objName) f | f <- fields | idx <- [0 :: Int ..]]
+ mkCaseBinding objName (RecP consName fields) ds = foldr ($) ds $
+ [mkCaseBinding (VarE (selectorName n) `AppE` objName) p| (n, p) <- fields]
+ mkCaseBinding objName (VarP v) ds = FunD v [Clause [] (NormalB $ objName) []]:ds
+ mkCaseBinding objName (AsP n v) ds = mkCaseBinding objName (VarP n) $ mkCaseBinding objName v ds
+ mkCaseBinding _ (LitP _) ds = ds
+ mkCaseBinding _ WildP ds = ds
+ mkCaseBinding objName (ParensP p) ds = mkCaseBinding objName p ds
+ mkCaseBinding _ p _ = error $ "Unsupported pat: " ++ show p
pCaseMatch :: (MonadFail m, Alternative m) => RParser m Token (Pat, Exp)
-pCaseMatch = (,) <$> pPat <* pSat (==(Op "->")) <*> pExp
+pCaseMatch = (,) <$> pPat <* pSat (==(Op "->")) <*> pExp <* optional (pSat (==SColon))
pExp :: (MonadFail m, Alternative m) => RParser m Token Exp
pExp
pPat :: (MonadFail m, Alternative m) => RParser m Token Pat
pPat
- = ConP <$> pCon <*> many pPat
+ = RecP <$> pCon <*> pCBrack pFieldPat
+ <|> ConP <$> pCon <*> many pPat
+ <|> AsP <$> pVar <* pSat (At==) <*> pPat
<|> VarP <$> pVar
<|> WildP <$ pSat (Underscore==)
+ <|> LitP <$> pLit
<|> pBrack pPat
+ where
+ pFieldPat = pSepBy (pSat (==Comma)) $
+ (,) <$> pVar <* pSat (==Equal) <*> pPat
parseCP :: MonadFail m => [Char] -> m Exp
-parseCP s = case runParser pCase (lexer s) of
- Nothing -> fail "Parsing failed"
- Just (_, _:_) -> fail "Non-exhaustive parse found"
- Just (e, []) -> pure e
-
-data Token = Lit {unlit :: Lit} | Con {uncon :: String} | Var {unvar :: String} | Case | Of | Op String | BOpen | BClose | Underscore | Unknown Char
+--parseCP s = case runParser pCase (lexer s) of
+parseCP s = case runParser pCase (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
+ (e, []):_ -> pure e
+-- x -> fail $ "Multiple parses: " ++ show x
+-- Just (e, []) -> pure e
+
+data Token = Lit {unlit :: Lit} | Con {uncon :: String} | Var {unvar :: String}
+ | Case | Of | Op String | BOpen | BClose | Underscore | SColon | At | COpen | CClose | Equal | Comma
+ | Unknown Char
deriving (Eq, Show)
lexer :: [Char] -> [Token]
lexer ('(':rest) = BOpen:lexer rest
lexer (')':rest) = BClose:lexer rest
lexer ('_':rest) = Underscore:lexer rest
+lexer (';':rest) = SColon:lexer rest
+lexer ('@':rest) = At:lexer rest
+lexer ('{':rest) = COpen:lexer rest
+lexer ('}':rest) = CClose:lexer rest
+lexer ('=':rest) = Equal:lexer rest
+lexer (',':rest) = Comma:lexer rest
lexer ('\'':'\\':x:'\'':rest) = case x of
'\'' -> Lit (CharL '\''):lexer rest
'\\' -> Lit (CharL '\\'):lexer rest
| isAlpha d && isLower d = case span isAlpha rest of
(s, rest') -> Var (d:s):lexer rest'
| isDigit d || d == '-' || d == '+' = case span isDigit rest of
- (s, rest') -> Lit (IntegerL $ read (d:s)):lexer rest'
+ (s, rest') -> trace (show (d:s)) $ Lit (IntegerL $ read (d:s)):lexer rest'
| isSpace d = lexer rest
| otherwise = Unknown d:lexer rest
lexer [] = []
repositories / clean-tests.git / blobdiff