From: Mart Lubbers <mart@martlubbers.net>
Date: Thu, 2 Sep 2021 11:44:29 +0000 (+0200)
Subject: use parsec for the parser
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=dad9c516619f2f3e09ba3fb5959a1f270c44f892;p=clean-tests.git

use parsec for the parser
---

diff --git a/datatype/Language/GenDSL.hs b/datatype/Language/GenDSL.hs
index 69dff4b..47a6b29 100644
--- a/datatype/Language/GenDSL.hs
+++ b/datatype/Language/GenDSL.hs
@@ -19,11 +19,14 @@ stringName (Name occ _) = occString occ
 numberedArgs :: [a] -> Q [Name]
 numberedArgs = zipWithM (\i _->newName $ "f" ++ show i) [0 :: Int ..]
 
+adtFieldName :: Name -> Int -> Name
+adtFieldName consName idx = mkName $ map toLower (stringName consName) ++ "f" ++ show idx
+
 data Field = Field { fname :: Name, ffresh :: Name, ftype :: Type }
 
 toNameType :: Con -> Q [Field]
 toNameType (NormalC consName fs) = numberedArgs fs
-    >>= \nfs->pure [Field (mkName $ map toLower (stringName consName) ++ "f" ++ show i) nf t | (_, t) <- fs | nf <- nfs | i <- [0 :: Int ..]]
+    >>= \nfs->pure [Field (adtFieldName consName i) nf t | (_, t) <- fs | nf <- nfs | i <- [0 :: Int ..]]
 toNameType (RecC _ fs) = numberedArgs fs
     >>= \nfs->pure [Field n nf t | (n, _, t)<-fs | nf <- nfs]
 toNameType c = fail $ "Unsupported constructor type: " ++ show c
diff --git a/datatype/Language/Quote.hs b/datatype/Language/Quote.hs
index f062647..6e9e373 100644
--- a/datatype/Language/Quote.hs
+++ b/datatype/Language/Quote.hs
@@ -2,238 +2,150 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ParallelListComp #-}
-module Language.Quote where
+module Language.Quote (cp) where
 
 import Data.Char
-import Data.List
-import Data.Maybe
-import Debug.Trace
-
-import Control.Applicative
+import Data.Functor.Identity
+--
 import Language.Haskell.TH.Syntax
 import Language.Haskell.TH.Quote
-
+--
+import Text.Parsec
+import Text.Parsec.String
+import Text.Parsec.Expr as E
+import qualified Text.Parsec.Token as P
+import Text.Parsec.Language (haskell)
+--
 import Language.GenDSL
 
 cp :: QuasiQuoter
 cp = QuasiQuoter
-    { quoteExp = quoteCPExp
+    { quoteExp = \s->location >>= parseExpr s
     , quotePat = undefined
     , quoteType = undefined
     , quoteDec = undefined
     }
-
-newtype RParser m t a = Parser {runParser :: [t] -> m (a, [t])}
-type Parser t a = RParser Maybe t a
-instance Functor m => Functor (RParser m t) where
-    fmap f m = Parser $ fmap (\(a, b)->(f a, b)) . runParser m
-instance Monad m => Applicative (RParser m t) where
-    pure a = Parser $ pure . (a,)
-    l <*> r = Parser $ \ts->runParser l ts >>= \(a, ts')->runParser r ts' >>= \(b, ts'')->pure (a b, ts'')
-instance Monad m => Monad (RParser m t) where
-    ma >>= a2mb = Parser $ \ts->runParser ma ts >>= \(a, ts')->runParser (a2mb a) ts'
-instance (Monad m, Alternative m) => Alternative (RParser m t) where
-    empty = Parser $ \_->empty
-    l <|> r = Parser $ \ts->runParser l ts <|> runParser r ts
-instance (MonadFail m) => MonadFail (RParser m t) where
-    fail msg = Parser $ \_->fail msg
-
-pTop :: Alternative m => RParser m t t
-pTop = Parser $ maybe empty pure . uncons
-
-pFail :: (MonadFail m, Alternative m) => String -> RParser m t a
-pFail msg = Parser $ \_->fail msg
-
-pSat :: (Alternative m, MonadFail m, Show t) => (t -> Bool) -> RParser m t t
-pSat p = pTop >>= \v->if p v then pure v else pFail ("unexpected: " ++ show v)
-
-pChainl :: (Monad m, Alternative m) => RParser m t (a -> a -> a) -> RParser m t a -> RParser m t a
-pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
-
-pChainr :: (Monad m, Alternative m) => RParser m t (a -> a -> a) -> RParser m t a -> RParser m t a
-pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
-
-pNonfix :: (Monad m, Alternative m) => RParser m t (a -> a -> a) -> RParser m t a -> RParser m t a
-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==)
-
-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 :: Exp -> [(Pat, Exp)] -> Exp
-    mkCase name cases = foldr (uncurry mkCaseMatch) (VarE (mkName "bottom") `AppE` LitE (StringL "Exhausted case")) cases
+    parseExpr :: MonadFail m => String -> Loc -> m Exp
+    parseExpr s loc =
+        case runParser p () "" s of
+          Left err -> fail $ show err
+          Right e  -> return e
       where
-        mkCaseMatch :: Pat -> Exp -> Exp -> Exp
-        mkCaseMatch a e rest = case mkCasePred name a of
-            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 "&.")
-            (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 _ 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 <* optional (pSat (SColon==))
-
-pExp :: (MonadFail m, Alternative m) => RParser m Token Exp
-pExp
-    = foldr ($) (pChainl (pure AppE) pBasic)
-    [ pChainr $ parseOps ["^."]
-    , pChainl $ parseOps ["*.", "/."]
-    , pChainl $ parseOps ["+.", "-."]
-    , pNonfix $ parseOps ["==.", "/=.", "<.", ">.", "<=.", ">=."]
-    , pChainr $ parseOps ["&."]
-    , pChainr $ parseOps ["|."]
-    ] 
-  where
-    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
-        =   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)
-
-pVar :: (MonadFail m, Alternative m) => RParser m Token Name
-pVar = mkName . unvar <$> pSat (\x->case x of Var _ -> True; _ -> False)
-
-pCon :: (MonadFail m, Alternative m) => RParser m Token Name
-pCon = mkName . uncon <$> pSat (\x->case x of Con _ -> True; _ -> False)
-
-pPat :: (MonadFail m, Alternative m) => RParser m Token Pat
-pPat
-    =   RecP <$> pCon <*> pCBrack pFieldPat
-    <|> ConP <$> pCon <*> many pPat
-    <|> AsP <$> pVar <* pSat (At==) <*> pPat
-    <|> VarP <$> pVar
-    <|> WildP <$ pSat (Underscore==)
-    <|> LitP <$> pLit
-    <|> pBrack pPat
+        file = loc_filename loc
+        (line, col) = loc_start loc
+        p = getPosition >>= setPosition . mPos >> expr <* eof
+        mPos = (flip setSourceName) file .
+            (flip setSourceLine) line .
+            (flip setSourceColumn) col
+
+-- Lexer
+identifier,operator :: Parser String
+identifier = P.identifier haskell
+operator = P.operator haskell
+
+parens,braces :: Parser a -> Parser a
+braces = P.braces haskell
+parens = P.parens haskell
+
+commaSep :: Parser a -> Parser [a]
+commaSep = P.commaSep haskell
+
+symbol :: String -> Parser String
+symbol = P.symbol haskell
+
+reserved,reservedOp :: String -> Parser ()
+reserved = P.reserved haskell
+reservedOp = P.reservedOp haskell
+
+-- Parser
+pat :: Parser Pat
+pat
+    =   try (RecP <$> con <*> braces (commaSep $ (,) <$> var <* reservedOp "=" <*> pat))
+    <|> ConP <$> con <*> many pat
+    <|> try (AsP <$> var <* reservedOp "@" <*> pat)
+    <|> VarP <$> var
+    <|> WildP <$ symbol "_"
+    <|> LitP <$> lit
+    <|> parens pat
+
+expr :: Parser Exp
+expr = buildExpressionParser
+    [ [bin "^." AssocRight]
+    , [bin "*." AssocLeft, bin "/." AssocLeft]
+    , [bin "+." AssocLeft, bin "-." AssocLeft]
+    , [bin o AssocNone | o <- ["==.", "/=.", "<.", ">.", "<=.", ">=."]]
+    , [bin "&." AssocRight]
+    , [bin "|." AssocRight]
+    ] basic
   where
-    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 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
---    (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 ('c':'a':'s':'e':rest) = Case:lexer rest
-lexer ('o':'f':rest) = Of:lexer rest
-lexer ('-':'>':rest) = Op "->":lexer rest
-lexer ('^':'.':rest) = Op "^.":lexer rest
-lexer ('*':'.':rest) = Op "*.":lexer rest
-lexer ('/':'.':rest) = Op "/.":lexer rest
-lexer ('+':'.':rest) = Op "+.":lexer rest
-lexer ('-':'.':rest) = Op "-.":lexer rest
-lexer ('|':'.':rest) = Op "|.":lexer rest
-lexer ('&':'.':rest) = Op "&.":lexer rest
-lexer ('=':'=':'.':rest) = Op "==.":lexer rest
-lexer ('/':'=':'.':rest) = Op "/=.":lexer rest
-lexer ('<':'=':'.':rest) = Op "<=.":lexer rest
-lexer ('>':'=':'.':rest) = Op ">=.":lexer rest
-lexer ('<':'.':rest) = Op "<.":lexer rest
-lexer ('>':'.':rest) = Op ">.":lexer rest
-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) = lexer $ dropWhile (/='\n') rest
-lexer ('{':'-':rest) = gobble rest
+    bin :: String -> Assoc -> Operator String () Identity Exp
+    bin str = E.Infix $ ifx str <$ sat operator (str==)
+        (("Expected operator " ++ str ++ " but got ")++)
+
+    basic :: Parser Exp
+    basic
+        =   try (AppE . VarE <$> var <*> (TupE <$> parens (commaSep expr)))
+        <|> VarE <$> var
+        <|> AppE (VarE (mkName "lit")) . LitE <$> lit
+        <|> parens expr
+        <|> mkCase <$ reserved "case" <*> expr <* reserved "of" <*> many1 match
+
+    match = (,) <$> pat <* reservedOp "->" <*> expr
+
+sat :: Parser a -> (a -> Bool) -> (a -> String) -> Parser a
+sat p f msg = try (p >>= \a->if f a then pure a else fail (msg a))
+
+lit :: Parser Lit
+lit
+    =   CharL <$> P.charLiteral haskell
+    <|> IntegerL <$> P.natural haskell
+
+con,var :: Parser Name
+con = mkName <$> sat identifier (isUpper . head) ("Not a data constructor: "++)
+var = mkName <$> sat identifier (isLower . head) ("Not a variable identifier: "++)
+
+-- Convert case to if statements
+mkCase :: Exp -> [(Pat, Exp)] -> Exp
+mkCase name cases = foldr (uncurry mkCaseMatch) (VarE (mkName "bottom") `AppE` LitE (StringL "Exhausted case")) cases
   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
-lexer (',':rest) = Comma:lexer rest
-lexer ('\'':'\\':x:'\'':rest) = case x of
-        '\'' -> Lit (CharL '\''):lexer rest
-        '\\' -> Lit (CharL '\\'):lexer rest
-        'a' -> Lit (CharL '\a'):lexer rest
-        'b' -> Lit (CharL '\b'):lexer rest
-        't' -> Lit (CharL '\t'):lexer rest
-        'n' -> Lit (CharL '\n'):lexer rest
-        'v' -> Lit (CharL '\v'):lexer rest
-        'f' -> Lit (CharL '\f'):lexer rest
-        'r' -> Lit (CharL '\r'):lexer rest
-        _ -> error $ "Unknown character escape: " ++ show x
-lexer ('\'':x:'\'':rest)
-    | x /= '\'' && x /= '\\'= Lit (CharL x):lexer rest
-lexer (d:rest)
-    | isAlpha d && isUpper d = case span isAlpha rest of
-        (s, rest') -> Con (d:s):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') -> trace (show (d:s)) $ Lit (IntegerL $ read (d:s)):lexer rest'
-    | isSpace d = lexer rest
-    | otherwise = Unknown d:lexer rest
-lexer [] = []
-
-quoteCPExp :: String -> Q Exp
-quoteCPExp s = do 
---   loc <- location
---    let pos =  (loc_filename loc, fst (loc_start loc), snd (loc_start loc))
-    parseCP s
-
-quoteCPPat :: String -> Q Pat
-quoteCPPat _ = undefined
+    mkCaseMatch :: Pat -> Exp -> Exp -> Exp
+    mkCaseMatch a e rest = case mkCasePred name a of
+        [] -> mkCaseLets (mkCaseBinding name a) e
+        ps -> VarE (mkName "if'") `AppE` foldl1 (ifx "&.") ps `AppE` (mkCaseLets (mkCaseBinding name a) e) `AppE` rest
+
+    mkCaseLets :: [Dec] -> Exp -> Exp
+    mkCaseLets [] e = e
+    mkCaseLets defs e = LetE defs e
+
+    conPtoRecP :: Name -> [Pat] -> Pat
+    conPtoRecP consName = RecP consName . zip (map (adtFieldName consName) [0..])
+
+    mkCasePred :: Exp -> Pat -> [Exp]
+    mkCasePred e (LitP l) = [ifx "==." (VarE (mkName "lit") `AppE` LitE l) e]
+    mkCasePred _ (VarP _) = []
+    mkCasePred e (ConP cons fs) = mkCasePred e $ conPtoRecP cons fs
+    mkCasePred e (InfixP l cons r) = mkCasePred e (ConP cons [l,r])
+    mkCasePred e (UInfixP l cons r) = mkCasePred e (ConP cons [l,r])
+    mkCasePred e (ParensP p) = mkCasePred e p
+    mkCasePred e (TildeP p) = mkCasePred e p
+    mkCasePred e (BangP p) = mkCasePred e p
+    mkCasePred e (AsP _ p) = mkCasePred e p
+    mkCasePred _  WildP = []
+    mkCasePred e (RecP cons fs) = VarE (predicateName cons) `AppE` e
+        : concatMap (\(n, p)->mkCasePred (VarE (selectorName n) `AppE` e) p) fs
+    mkCasePred _  p = error $ "Unsupported pat: " ++ show p
+
+    mkCaseBinding :: Exp -> Pat -> [Dec]
+    mkCaseBinding _ (LitP _) = []
+    mkCaseBinding e (VarP v) = [FunD v [Clause [] (NormalB $ e) []]]
+    mkCaseBinding e (ConP cons fs) = mkCaseBinding e $ conPtoRecP cons fs
+    mkCaseBinding e (InfixP l cons r) = mkCaseBinding e (ConP cons [l,r])
+    mkCaseBinding e (UInfixP l cons r) = mkCaseBinding e (ConP cons [l,r])
+    mkCaseBinding e (ParensP p) = mkCaseBinding e p
+    mkCaseBinding e (TildeP p) = mkCaseBinding e p
+    mkCaseBinding e (BangP p) = mkCaseBinding e p
+    mkCaseBinding e (AsP n p) = FunD n [Clause [] (NormalB $ e) []]:mkCaseBinding e p
+    mkCaseBinding _  WildP = []
+    mkCaseBinding e (RecP _ fs) = concatMap (\(n, p)->mkCaseBinding (VarE (selectorName n) `AppE` e) p) fs
+    mkCaseBinding _  p = error $ "Unsupported pat: " ++ show p
diff --git a/datatype/Main.hs b/datatype/Main.hs
index 8d31f60..c68cb85 100644
--- a/datatype/Main.hs
+++ b/datatype/Main.hs
@@ -35,12 +35,12 @@ main
 --  >> putStrLn (show $ runInterpreter (unmain f4))
   >> putStrLn (runPrint $ unmain f5)
   >> putStrLn (show $ interpret 50 <$> runCompiler (unmain f5))
-  >> putStrLn (runPrint $ unmain f6)
-  >> putStrLn (show $ interpret 50 <$> runCompiler (unmain f6))
-  >> putStrLn (runPrint $ unmain f7)
-  >> putStrLn (show $ interpret 50 <$> runCompiler (unmain f7))
-  >> putStrLn (runPrint $ unmain f7')
-  >> putStrLn (show $ interpret 100 <$> runCompiler (unmain f7'))
+--  >> putStrLn (runPrint $ unmain f6)
+--  >> putStrLn (show $ interpret 50 <$> runCompiler (unmain f6))
+--  >> putStrLn (runPrint $ unmain f7)
+--  >> putStrLn (show $ interpret 50 <$> runCompiler (unmain f7))
+--  >> putStrLn (runPrint $ unmain f7')
+--  >> putStrLn (show $ interpret 100 <$> runCompiler (unmain f7'))
 
 e0 :: Expression v => v Int
 e0 = lit 2 -. lit 8
@@ -94,8 +94,8 @@ f4
 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)
                 Nil -> 0
+                Cons e rest -> e +. sumf(rest)
             |])
 --    :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))}
     :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))}
@@ -104,7 +104,7 @@ f5
 f6 :: (TupleR' v, Expression v, Function (v (TupleR Int Char)) v) => Main (v Int)
 f6
     = fun ( \firstfun->(\l->[cp|case l of
-                TupleR{first=f} -> f
+                TupleR {first=f} -> f
             |])
 --    :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))}
     :- Main {unmain=firstfun $ tupler (lit 1) (lit 'c')}
@@ -113,8 +113,8 @@ f6
 f7 :: (Expression v, Function (v Int) v) => Main (v Int)
 f7
     = fun ( \ffac->(\l->[cp|case l of
-                0 -> 1;
-                n -> n *. ffac (n -. 1);
+                0 -> 1
+                n -> n *. ffac (n -. 1)
             |])
     :- Main {unmain=ffac (lit 10)}
     )