cleanup compactify, improve

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

diff --git a/datatype/Language/Quote.hs b/datatype/Language/Quote.hs
index c6b94bc..8682f0e 100644 (file)
--- a/datatype/Language/Quote.hs
+++ b/datatype/Language/Quote.hs
@@ -73,8 +73,12 @@ pCase = mkCase <$ pSat (==Case) <*> pExp <* pSat (==Of) <*> some pCaseMatch
       where
         mkCaseMatch :: Pat -> Exp -> Exp -> Exp
         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
+            Nothing -> mkCaseLets (mkCaseBinding name a []) e
+            Just p -> VarE (mkName "if'") `AppE` p `AppE` (mkCaseLets (mkCaseBinding name a []) e) `AppE` rest
+
+        mkCaseLets :: [Dec] -> Exp -> Exp
+        mkCaseLets [] e = e
+        mkCaseLets defs e = LetE defs e
 
         mkCasePred :: Exp -> Pat -> Maybe Exp
         mkCasePred objName (ConP consName fields) = Just $ foldl (ifx "&.")
@@ -93,7 +97,7 @@ pCase = mkCase <$ pSat (==Case) <*> pExp <* pSat (==Of) <*> some pCaseMatch
         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 objName (RecP _ 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
@@ -148,12 +152,12 @@ 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
---    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
+    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
+    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
@@ -182,6 +186,12 @@ lexer (')':rest) = BClose:lexer rest
 lexer ('_':rest) = Underscore:lexer rest
 lexer (';':rest) = SColon:lexer rest
 lexer ('@':rest) = At:lexer rest
+lexer ('-':'-':rest) = lexer $ dropWhile (/='\n') rest
+lexer ('{':'-':rest) = gobble rest
+  where
+    gobble [] = []
+    gobble ('-':'}':xs) = lexer xs
+    gobble (_:xs) = gobble xs
 lexer ('{':rest) = COpen:lexer rest
 lexer ('}':rest) = CClose:lexer rest
 lexer ('=':rest) = Equal:lexer rest
@@ -199,12 +209,6 @@ lexer ('\'':'\\':x:'\'':rest) = case x of
         _ -> error $ "Unknown character escape: " ++ show x
 lexer ('\'':x:'\'':rest)
     | x /= '\'' && x /= '\\'= Lit (CharL x):lexer rest
-lexer ('-':'-':rest) = lexer $ dropWhile (/='\n') rest
-lexer ('{':'-':rest) = gobble rest
-  where
-    gobble [] = []
-    gobble ('-':'}':xs) = lexer xs
-    gobble (_:xs) = gobble xs
 lexer (d:rest)
     | isAlpha d && isUpper d = case span isAlpha rest of
         (s, rest') -> Con (d:s):lexer rest'