Switch from parsec to HSE for parsing

This fixes a lot of the bugs, but many remain
bmillwood · May 3, 2013 · 6489c80 · 6489c80
1 parent 88a74c9
commit 6489c80
Show file tree

Hide file tree

Showing 4 changed files with 84 additions and 225 deletions.
diff --git a/Plugin/Pl/Common.hs b/Plugin/Pl/Common.hs
@@ -19,7 +19,7 @@ import qualified Data.Map as M
 import Control.Monad
 import Control.Arrow (first, second, (***), (&&&), (|||), (+++))
 
-import Text.ParserCombinators.Parsec.Expr (Assoc(..))
+import Language.Haskell.Exts (Assoc(..))
 
 import GHC.Base (assert)
 

diff --git a/Plugin/Pl/Parser.hs b/Plugin/Pl/Parser.hs
@@ -7,222 +7,86 @@ module Plugin.Pl.Parser (parsePF) where
 
 import Plugin.Pl.Common
 
-import Text.ParserCombinators.Parsec
-import Text.ParserCombinators.Parsec.Expr
-import Text.ParserCombinators.Parsec.Language
-import qualified Text.ParserCombinators.Parsec.Token as T
-
--- is that supposed to be done that way?
-tp :: T.TokenParser ()
-tp = T.makeTokenParser $ haskellStyle { 
-  reservedNames = ["if","then","else","let","in"]
-}
-
-parens :: Parser a -> Parser a
-parens = T.parens tp
-
-brackets :: Parser a -> Parser a
-brackets = T.brackets tp
-
-symbol :: String -> Parser ()
-symbol = fmap (const ()) . T.symbol tp
-
-atomic :: Parser String
-atomic = try (show `fmap` T.natural tp) <|> T.identifier tp
-
-reserved :: String -> Parser ()
-reserved = T.reserved tp
-
-charLiteral :: Parser Char
-charLiteral = T.charLiteral tp
-
-stringLiteral :: Parser String
-stringLiteral = T.stringLiteral tp
-
-table :: [[Operator Char st Expr]]
-table = addToFirst def $ map (map inf) operators where
-  addToFirst y (x:xs) = ((y:x):xs)
-  addToFirst _ _ = assert False bt
-
-  def :: Operator Char st Expr
-  def = Infix (try $ do
-      name <- parseOp  
-      guard $ not $ isJust $ lookupOp name
-      spaces
-      return $ \e1 e2 -> App (Var Inf name) e1 `App` e2
-    ) AssocLeft
-
-  inf :: (String, (Assoc, Int)) -> Operator Char st Expr
-  inf (name, (assoc, _)) = Infix (try $ do 
-      _ <- string name
-      notFollowedBy $ oneOf opchars
-      spaces
-      let name' = if head name == '`' 
-                  then tail . reverse . tail . reverse $ name 
-                  else name
-      return $ \e1 e2 -> App (Var Inf name') e1 `App` e2
-    ) assoc
-
-
-parseOp :: CharParser st String
-parseOp = (between (char '`') (char '`') $ many1 (letter <|> digit))
-  <|> try (do 
-    op <- many1 $ oneOf opchars
-    guard $ not $ op `elem` reservedOps
-    return op)
-
-pattern :: Parser Pattern
-pattern = buildExpressionParser ptable ((PVar `fmap` 
-                       (    atomic 
-                        <|> (symbol "_" >> return ""))) 
-                        <|> parens pattern)
-    <?> "pattern" where
-  ptable = [[Infix (symbol ":" >> return PCons) AssocRight],
-            [Infix (symbol "," >> return PTuple) AssocNone]]
-
-lambda :: Parser Expr
-lambda = do
-    symbol "\\"
-    vs <- many1 pattern
-    symbol "->"
-    e <- myParser False
-    return $ foldr Lambda e vs
-  <?> "lambda abstraction"
-
-var :: Parser Expr
-var = try (makeVar `fmap` atomic <|> 
-           parens (try unaryNegation <|> try rightSection
-                   <|> try (makeVar `fmap` many1 (char ',')) 
-                   <|> tuple) <|> list <|> (Var Pref . show) `fmap` charLiteral
-                   <|> stringVar `fmap` stringLiteral)
-        <?> "variable" where
-  makeVar v | Just _ <- lookupOp v = Var Inf v -- operators always want to
-                                               -- be infixed
-            | otherwise            = Var Pref v
-  stringVar :: String -> Expr
-  stringVar str = makeList $ (Var Pref . show) `map` str
-
-list :: Parser Expr
-list = msum (map (try . brackets) plist) <?> "list" where
-  plist = [
-    foldr (\e1 e2 -> cons `App` e1 `App` e2) nil `fmap` 
-      (myParser False `sepBy` symbol ","),
-    do e <- myParser False
-       symbol ".."
-       return $ Var Pref "enumFrom" `App` e,
-    do e <- myParser False
-       symbol ","
-       e' <- myParser False
-       symbol ".."
-       return $ Var Pref "enumFromThen" `App` e `App` e',
-    do e <- myParser False
-       symbol ".."
-       e' <- myParser False
-       return $ Var Pref "enumFromTo" `App` e `App` e',
-    do e <- myParser False
-       symbol ","
-       e' <- myParser False
-       symbol ".."
-       e'' <- myParser False
-       return $ Var Pref "enumFromThenTo" `App` e `App` e' `App` e''
-    ] 
-
-tuple :: Parser Expr
-tuple = do
-    elts <- myParser False `sepBy` symbol ","
-    guard $ length elts /= 1
-    let name = Var Pref $ replicate (length elts - 1) ','
-    return $ foldl App name elts
-  <?> "tuple"
-
-unaryNegation :: Parser Expr
-unaryNegation = do
-    symbol "-"
-    e <- myParser False
-    return $ Var Pref "negate" `App` e
-  <?> "unary negation"
-
-rightSection :: Parser Expr
-rightSection = do
-    v <- Var Inf `fmap` parseOp
-    spaces
-    let rs e = flip' `App` v `App` e
-    option v (rs `fmap` myParser False)
-  <?> "right section"
-
-
-myParser :: Bool -> Parser Expr
-myParser b = lambda <|> expr b
-
-expr :: Bool -> Parser Expr
-expr b = buildExpressionParser table (term b) <?> "expression"
-
-decl :: Parser Decl
-decl = do
-  f <- atomic 
-  args <- pattern `endsIn` symbol "="
-  e <- myParser False
-  return $ Define f (foldr Lambda e args)
-
-letbind :: Parser Expr
-letbind = do
-  reserved "let"
-  ds <- decl `sepBy` symbol ";"
-  reserved "in"
-  e <- myParser False
-  return $ Let ds e
-
-ifexpr :: Parser Expr
-ifexpr = do
-  reserved "if"
-  p <- myParser False
-  reserved "then"
-  e1 <- myParser False
-  reserved "else"
-  e2 <- myParser False
-  return $ if' `App` p `App` e1 `App` e2
-
-term :: Bool -> Parser Expr
-term b = application <|> lambda <|> letbind <|> ifexpr <|>
-    (guard b >> (notFollowedBy (noneOf ")") >> return (Var Pref "")))
-  <?> "simple term"
-
-application :: Parser Expr
-application = do
-    e:es <- many1 $ var <|> parens (myParser True)
-    return $ foldl App e es
-  <?> "application"
-
-endsIn :: Parser a -> Parser b -> Parser [a]
-endsIn p end = do
-  xs <- many p
-  _ <- end
-  return $ xs
-
-input :: Parser TopLevel
-input = do
-  spaces
-  tl <- try (do 
-      f    <- atomic
-      args <- pattern `endsIn` symbol "="
-      e    <- myParser False
-      return $ TLD True $ Define f (foldr Lambda e args)
-    ) <|> TLE `fmap` myParser False
-  eof
-  return tl
+import qualified Language.Haskell.Exts as HSE
+
+todo :: (Show e) => e -> a
+todo thing = error ("pointfree: not supported: " ++ show thing)
+
+nameString :: HSE.Name -> String
+nameString (HSE.Ident s) = s
+nameString (HSE.Symbol s) = s
+
+qnameString :: HSE.QName -> String
+qnameString (HSE.Qual m n) = HSE.prettyPrint m ++ nameString n
+qnameString (HSE.UnQual n) = nameString n
+qnameString (HSE.Special sc) = case sc of
+  HSE.UnitCon -> "()"
+  HSE.ListCon -> "[]"
+  HSE.FunCon -> "->"
+  HSE.TupleCon HSE.Boxed n -> replicate (n-1) ','
+  HSE.TupleCon{} -> todo sc
+  HSE.Cons -> ":"
+  HSE.UnboxedSingleCon -> todo sc
+
+opString :: HSE.QOp -> String
+opString (HSE.QVarOp qn) = qnameString qn
+opString (HSE.QConOp qn) = qnameString qn
+
+hseToExpr :: HSE.Exp -> Expr
+hseToExpr expr = case expr of
+  HSE.Var qn -> Var Pref (qnameString qn)
+  HSE.IPVar{} -> todo expr
+  HSE.Con qn -> Var Pref (qnameString qn)
+  HSE.Lit l -> Var Pref (HSE.prettyPrint l)
+  HSE.InfixApp p op q -> apps (Var Inf (opString op)) [p,q]
+  HSE.App f x -> hseToExpr f `App` hseToExpr x
+  HSE.NegApp e -> Var Pref "negate" `App` hseToExpr e
+  HSE.Lambda _ ps e -> foldr (Lambda . hseToPattern) (hseToExpr e) ps
+  HSE.Let bs e -> case bs of
+    HSE.BDecls ds -> Let (map hseToDecl ds) (hseToExpr e)
+    HSE.IPBinds ips -> todo ips
+  HSE.If b t f -> apps if' [b,t,f]
+  HSE.Case{} -> todo expr
+  HSE.Do{} -> todo expr
+  HSE.MDo{} -> todo expr
+  HSE.Tuple es -> foldl (\a x -> a `App` hseToExpr x)
+    (Var Pref (replicate (length es - 1) ','))  es
+  HSE.TupleSection{} -> todo expr
+  HSE.List xs -> foldr (\y ys -> cons `App` hseToExpr y `App` ys) nil xs
+  HSE.Paren e -> hseToExpr e
+  HSE.LeftSection l op -> Var Inf (opString op) `App` hseToExpr l
+  HSE.RightSection op r -> flip' `App` Var Inf (opString op) `App` hseToExpr r
+  HSE.RecConstr{} -> todo expr
+  HSE.RecUpdate{} -> todo expr
+  HSE.EnumFrom x -> apps (Var Pref "enumFrom") [x]
+  HSE.EnumFromTo x y -> apps (Var Pref "enumFromTo") [x,y]
+  HSE.EnumFromThen x y -> apps (Var Pref "enumFromThen") [x,y]
+  HSE.EnumFromThenTo x y z -> apps (Var Pref "enumFromThenTo") [x,y,z]
+  _ -> todo expr
+
+apps :: Expr -> [HSE.Exp] -> Expr
+apps f xs = foldl (\a x -> a `App` hseToExpr x) f xs 
+
+hseToDecl :: HSE.Decl -> Decl
+hseToDecl dec = case dec of
+  HSE.PatBind _ (HSE.PVar n) Nothing (HSE.UnGuardedRhs e) (HSE.BDecls []) ->
+    Define (nameString n) (hseToExpr e)
+  HSE.FunBind [HSE.Match _ n ps Nothing (HSE.UnGuardedRhs e) (HSE.BDecls [])] ->
+    Define (nameString n) (foldr (\p x -> Lambda (hseToPattern p) x) (hseToExpr e) ps)
+  _ -> todo dec
+
+hseToPattern :: HSE.Pat -> Pattern
+hseToPattern pat = case pat of
+  HSE.PVar n -> PVar (nameString n)
+  HSE.PInfixApp l (HSE.Special HSE.Cons) r -> PCons (hseToPattern l) (hseToPattern r)
+  HSE.PTuple [p,q] -> PTuple (hseToPattern p) (hseToPattern q)
+  HSE.PParen p -> hseToPattern p
+  HSE.PWildCard -> PVar "_"
+  _ -> todo pat
 
 parsePF :: String -> Either String TopLevel
-parsePF inp = case runParser input () "" inp of
-    Left err -> Left $ show err
-    Right e  -> Right $ mapTopLevel postprocess e
-
-
-postprocess :: Expr -> Expr
-postprocess (Var f v) = (Var f v)
-postprocess (App e1 (Var Pref "")) = postprocess e1
-postprocess (App e1 e2) = App (postprocess e1) (postprocess e2)
-postprocess (Lambda v e) = Lambda v (postprocess e)
-postprocess (Let ds e) = Let (mapDecl postprocess `map` ds) $ postprocess e where
-  mapDecl :: (Expr -> Expr) -> Decl -> Decl
-  mapDecl f (Define foo e') = Define foo $ f e'
-
+parsePF inp = case HSE.parseExp inp of
+  HSE.ParseOk e -> Right (TLE (hseToExpr e))
+  HSE.ParseFailed _ _ -> case HSE.parseDecl inp of
+    HSE.ParseOk d -> Right (TLD True (hseToDecl d))
+    HSE.ParseFailed _ err -> Left err
diff --git a/Plugin/Pl/PrettyPrinter.hs b/Plugin/Pl/PrettyPrinter.hs
@@ -129,12 +129,6 @@ getInfName str = if isOperator str then str else "`"++str++"`"
 getPrefName :: String -> String
 getPrefName str = if isOperator str || ',' `elem` str then "("++str++")" else str
 
-instance Eq Assoc where
-  AssocLeft  == AssocLeft  = True
-  AssocRight == AssocRight = True
-  AssocNone  == AssocNone  = True
-  _          == _          = False
-
 {-
 instance Show Assoc where
   show AssocLeft  = "AssocLeft"

diff --git a/pointfree.cabal b/pointfree.cabal
@@ -32,7 +32,8 @@ Executable pointfree
   Build-depends: base >= 3 && < 4.7,
                  array >= 0.3 && < 0.5,
                  containers >= 0.3 && < 0.6,
-                 parsec >= 2 && < 3.2,
+                 -- probably the below could be more generous
+                 haskell-src-exts == 1.13.*,
                  mtl >= 2 && < 2.2
   Other-modules: Plugin.Pl.Common
                  Plugin.Pl.Parser