- 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