From 8384a1f7c01009ed125efee8e617da2da1f4b774 Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Sun, 10 Mar 2019 18:53:43 +0100 Subject: Remove old parser --- src/Haskell/Parser.hs | 182 ++++++++++++++++++++++---------------------- src/Haskell/Parser/Def.hs | 100 ------------------------ src/Haskell/SimpleParser.hs | 135 -------------------------------- 3 files changed, 92 insertions(+), 325 deletions(-) delete mode 100644 src/Haskell/Parser/Def.hs delete mode 100644 src/Haskell/SimpleParser.hs (limited to 'src/Haskell') diff --git a/src/Haskell/Parser.hs b/src/Haskell/Parser.hs index e7b9535..dcee39e 100644 --- a/src/Haskell/Parser.hs +++ b/src/Haskell/Parser.hs @@ -1,133 +1,135 @@ module Haskell.Parser where import Control.Monad -import Control.Monad.Identity +import Data.Char import Haskell.AST -import Haskell.Parser.Def import Text.Parsec --- import Text.Parsec.IndentParsec.Combinator -import Text.Parsec.IndentParsec.Prim +import Text.Parsec.String -type Parser a = GenIndentParsecT HaskellLike String () Identity a - parseAST :: String -> String -> Either ParseError AST -parseAST fname source = runIdentity $ runGIPT pAST () fname source +parseAST fname source = parse pAST fname source pAST :: Parser AST pAST = do - whiteSpace - tops <- pToplevel `sepBy` someNewline + whitespace + tops <- many pToplevel eof return $ AST tops pToplevel :: Parser Toplevel -pToplevel = choice [TopClass <$> pClass - ,TopInst <$> pInst - ,TopData <$> pData - ,TopDecl <$> pDecl - ,TopDef <$> pDef] - -pData :: Parser Data -pData = do - reserved "data" - n <- typeident - vars <- many varident - ty <- choice [do reservedOp "=" - pConstr `sepBy` reservedOp "|" - ,return []] - return $ Data n vars ty - where - pConstr = liftM2 (,) typeident (many pType) - -pClass :: Parser Class -pClass = do - reserved "class" - n <- typeident - vars <- many varident - reserved "where" - decls <- bracesBlock (semiSepOrFoldedLines pDecl) - return $ Class n vars decls - -pInst :: Parser Inst -pInst = do - reserved "instance" - (n, ty) <- pType >>= \case - TyRef n [ty] -> return (n, ty) - _ -> fail "invalid instance head" - reserved "where" - decls <- bracesBlock (semiSepOrFoldedLines pDef) - return $ Inst n ty decls - -pDecl :: Parser Decl -pDecl = do - n <- try (varident <* reservedOp "::") - ty <- pType - return $ Decl n ty +pToplevel = TopDef <$> pDef pDef :: Parser Def pDef = do - n <- varident - args <- many varident - reservedOp "=" - body <- pExpr + n <- pVariable + args <- many pNameV + symbolO "=" + ex <- pExpr + symbolO ";" case args of - [] -> return $ Def n body - _ -> return $ Def n (Lam args body) - -pType :: Parser Type -pType = foldr1 TyFun <$> pSimpleType `sepBy` reservedOp "->" - where - pSimpleType :: Parser Type - pSimpleType = choice [do n <- typeident - args <- many pAtomicType - return (TyRef n args) - ,pAtomicType] - - pAtomicType :: Parser Type - pAtomicType = choice [typeident >>= \n -> return (TyRef n []) - ,TyVar <$> varident - ,parens (pType `sepBy` comma) >>= \case - [ty] -> return ty - tys -> return (TyTup tys)] + [] -> return $ Def n ex + _ -> return $ Def n (Lam args ex) pExpr :: Parser Expr pExpr = pLam <|> pCase <|> pApp where - pSimpleExpr = choice [Num <$> integer - ,Ref <$> (identifier <|> try (parens operator)) - ,parens pExpr] + pSimpleExpr = choice [Num <$> pNum + ,Ref <$> pVariable + ,parens (pExpr `sepBy` symbolO ",") >>= \case + [ex] -> return ex + exs -> return $ Tup exs] pLam = do - reservedOp "\\" - args <- many1 varident + symbolO "\\" + args <- many1 pNameV body <- pExpr return $ Lam args body - pApp = App <$> pSimpleExpr <*> many pSimpleExpr + pApp = many1 pSimpleExpr >>= \case + [] -> undefined + [e] -> return e + (e:es) -> return $ App e es pCase = do - reserved "case" + symbolW "case" e <- pExpr - reserved "of" - arms <- bracesBlock (semiSepOrFoldedLines pCaseArm) + symbolW "of" + arms <- braces (pCaseArm `sepBy` symbolO ";") return $ Case e arms pCaseArm = do pat <- pLargePat - reservedOp "->" + symbolO "->" ex <- pExpr return (pat, ex) pSimplePat :: Parser Pat -pSimplePat = choice [lexeme (string "_") >> return PatAny - ,PatVar <$> varident - ,typeident >>= \n -> return (PatCon n []) - ,parens pLargePat] +pSimplePat = choice [symbolW "_" >> return PatAny + ,PatVar <$> pNameV + ,pNameT >>= \n -> return (PatCon n []) + ,parens (pLargePat `sepBy` symbolO ",") >>= \case + [pat] -> return pat + pats -> return $ PatTup pats] pLargePat :: Parser Pat -pLargePat = choice [PatCon <$> typeident <*> many pSimplePat +pLargePat = choice [PatCon <$> pNameT <*> many pSimplePat ,pSimplePat] -someNewline :: Parser () -someNewline = many (oneOf " \t") >> char '\n' >> whiteSpace +pNum :: Parser Integer +pNum = (char '-' >> (negate <$> pPositive)) <|> pPositive + where pPositive = read <$> many1 digit + +pVariable :: Parser Name +pVariable = pName <|> try (parens pOperator) + +pName :: Parser Name +pName = notReserved $ liftM2 (:) (satisfy isAlpha) pNameRest + +pNameV :: Parser Name +pNameV = notReserved $ liftM2 (:) (satisfy isLower) pNameRest + +pNameT :: Parser Name +pNameT = notReserved $ liftM2 (:) (satisfy isUpper) pNameRest + +pNameRest :: Parser Name +pNameRest = many (satisfy $ \d -> isAlphaNum d || d == '_') <* aheadW + +notReserved :: Parser Name -> Parser Name +notReserved p = + try $ p >>= \n -> + if n `elem` reservedWords then unexpected "reserved word" else return n + +pOperator :: Parser String +pOperator = many1 (oneOf ":!#$%&*+./<=>?@\\^|-~") <* aheadO + +parens :: Parser a -> Parser a +parens = between (symbolBare "(") (symbolBare ")") + +braces :: Parser a -> Parser a +braces = between (symbolBare "{") (symbolBare "}") + +symbolW :: String -> Parser () +symbolW s = string s >> aheadW + +symbolO :: String -> Parser () +symbolO s = string s >> aheadO + +symbolBare :: String -> Parser () +symbolBare s = string s >> whitespace + +aheadW :: Parser () +aheadW = do + void (lookAhead (space <|> satisfy (\d -> not (isAlphaNum d) && d /= '_'))) <|> eof + whitespace + +aheadO :: Parser () +aheadO = do + void (lookAhead (space <|> alphaNum <|> oneOf ")};")) <|> eof + whitespace + +whitespace :: Parser () +whitespace = void $ many space + +reservedWords :: [String] +reservedWords = ["case", "of", "class", "instance", "where", "let", "in"] diff --git a/src/Haskell/Parser/Def.hs b/src/Haskell/Parser/Def.hs deleted file mode 100644 index 812140c..0000000 --- a/src/Haskell/Parser/Def.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# OPTIONS_GHC -Wno-missing-signatures #-} -module Haskell.Parser.Def where - -import Control.Monad.Identity -import Data.Char -import Text.Parsec --- import qualified Text.Parsec.Language as L -import qualified Text.Parsec.Token as T -import qualified Text.Parsec.IndentParsec.Token as IT -import qualified Text.Parsec.IndentParsec.Prim as IP - - --- LanguageDef things shamelessly stolen from Text.Parsec.Language. --- Reason for stealing is that these have more generic types. -haskellStyle = T.LanguageDef - { T.commentStart = "{-" - , T.commentEnd = "-}" - , T.commentLine = "--" - , T.nestedComments = True - , T.identStart = letter - , T.identLetter = alphaNum <|> oneOf "_'" - , T.opStart = T.opLetter haskellStyle - , T.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" - , T.reservedOpNames= [] - , T.reservedNames = [] - , T.caseSensitive = True - } - -haskell :: T.GenTokenParser String () (IP.IndentT IP.HaskellLike Identity) -haskell = T.makeTokenParser haskellDef - -haskellDef = haskell98Def - { T.identLetter = T.identLetter haskell98Def <|> char '#' - , T.reservedNames = T.reservedNames haskell98Def ++ - ["foreign","import","export","primitive" - ,"_ccall_","_casm_" - ,"forall" - ] - } - -haskell98Def = haskellStyle - { T.reservedOpNames= ["::","..","=","\\","|","<-","->","@","~","=>"] - , T.reservedNames = ["let","in","case","of","if","then","else", - "data","type", - "class","default","deriving","do","import", - "infix","infixl","infixr","instance","module", - "newtype","where", - "primitive" - -- "as","qualified","hiding" - ] - } - --- Bring the right combinators in scope. -mySemiSep = IT.semiSepOrFoldedLines haskell -myBraces = IT.bracesBlock haskell -identifier = IT.identifier haskell -operator = IT.operator haskell -reserved = IT.reserved haskell -reservedOp = IT.reservedOp haskell -charLiteral = IT.charLiteral haskell -stringLiteral = IT.stringLiteral haskell -natural = IT.natural haskell -integer = IT.integer haskell -float = IT.float haskell -naturalOrFloat = IT.naturalOrFloat haskell -decimal = IT.decimal haskell -hexadecimal = IT.hexadecimal haskell -octal = IT.octal haskell -symbol = IT.symbol haskell -lexeme = IT.lexeme haskell -whiteSpace = IT.whiteSpace haskell -semi = IT.semi haskell -comma = IT.comma haskell -colon = IT.colon haskell -dot = IT.dot haskell -parens = IT.parens haskell -parensBlock = IT.parensBlock haskell -braces = IT.braces haskell -bracesBlock = IT.bracesBlock haskell -angles = IT.angles haskell -anglesBlock = IT.anglesBlock haskell -brackets = IT.brackets haskell -bracketsBlock = IT.bracketsBlock haskell -semiSep = IT.semiSep haskell -semiSepOrFoldedLines = IT.semiSepOrFoldedLines haskell -semiSep1 = IT.semiSep1 haskell -semiSepOrFoldedLines1 = IT.semiSepOrFoldedLines1 haskell -commaSep = IT.commaSep haskell -commaSepOrFoldedLines = IT.commaSepOrFoldedLines haskell -commaSep1 = IT.commaSep1 haskell -commaSepOrFoldedLines1 = IT.commaSepOrFoldedLines1 haskell - --- Some more specific combinators. -identifierGuard pr = try $ do - s <- identifier - guard (not (null s) && pr s) - return s - -typeident = identifierGuard (isUpper . head) -varident = identifierGuard (isLower . head) diff --git a/src/Haskell/SimpleParser.hs b/src/Haskell/SimpleParser.hs deleted file mode 100644 index 841e41c..0000000 --- a/src/Haskell/SimpleParser.hs +++ /dev/null @@ -1,135 +0,0 @@ -module Haskell.SimpleParser where - -import Control.Monad -import Data.Char -import Haskell.AST -import Text.Parsec -import Text.Parsec.String - - -parseAST :: String -> String -> Either ParseError AST -parseAST fname source = parse pAST fname source - -pAST :: Parser AST -pAST = do - whitespace - tops <- many pToplevel - eof - return $ AST tops - -pToplevel :: Parser Toplevel -pToplevel = TopDef <$> pDef - -pDef :: Parser Def -pDef = do - n <- pVariable - args <- many pNameV - symbolO "=" - ex <- pExpr - symbolO ";" - case args of - [] -> return $ Def n ex - _ -> return $ Def n (Lam args ex) - -pExpr :: Parser Expr -pExpr = pLam <|> pCase <|> pApp - where - pSimpleExpr = choice [Num <$> pNum - ,Ref <$> pVariable - ,parens (pExpr `sepBy` symbolO ",") >>= \case - [ex] -> return ex - exs -> return $ Tup exs] - - pLam = do - symbolO "\\" - args <- many1 pNameV - body <- pExpr - return $ Lam args body - - pApp = many1 pSimpleExpr >>= \case - [] -> undefined - [e] -> return e - (e:es) -> return $ App e es - - pCase = do - symbolW "case" - e <- pExpr - symbolW "of" - arms <- braces (pCaseArm `sepBy` symbolO ";") - return $ Case e arms - - pCaseArm = do - pat <- pLargePat - symbolO "->" - ex <- pExpr - return (pat, ex) - -pSimplePat :: Parser Pat -pSimplePat = choice [symbolW "_" >> return PatAny - ,PatVar <$> pNameV - ,pNameT >>= \n -> return (PatCon n []) - ,parens (pLargePat `sepBy` symbolO ",") >>= \case - [pat] -> return pat - pats -> return $ PatTup pats] - -pLargePat :: Parser Pat -pLargePat = choice [PatCon <$> pNameT <*> many pSimplePat - ,pSimplePat] - -pNum :: Parser Integer -pNum = (char '-' >> (negate <$> pPositive)) <|> pPositive - where pPositive = read <$> many1 digit - -pVariable :: Parser Name -pVariable = pName <|> try (parens pOperator) - -pName :: Parser Name -pName = notReserved $ liftM2 (:) (satisfy isAlpha) pNameRest - -pNameV :: Parser Name -pNameV = notReserved $ liftM2 (:) (satisfy isLower) pNameRest - -pNameT :: Parser Name -pNameT = notReserved $ liftM2 (:) (satisfy isUpper) pNameRest - -pNameRest :: Parser Name -pNameRest = many (satisfy $ \d -> isAlphaNum d || d == '_') <* aheadW - -notReserved :: Parser Name -> Parser Name -notReserved p = - try $ p >>= \n -> - if n `elem` reservedWords then unexpected "reserved word" else return n - -pOperator :: Parser String -pOperator = many1 (oneOf ":!#$%&*+./<=>?@\\^|-~") <* aheadO - -parens :: Parser a -> Parser a -parens = between (symbolBare "(") (symbolBare ")") - -braces :: Parser a -> Parser a -braces = between (symbolBare "{") (symbolBare "}") - -symbolW :: String -> Parser () -symbolW s = string s >> aheadW - -symbolO :: String -> Parser () -symbolO s = string s >> aheadO - -symbolBare :: String -> Parser () -symbolBare s = string s >> whitespace - -aheadW :: Parser () -aheadW = do - void (lookAhead (space <|> satisfy (\d -> not (isAlphaNum d) && d /= '_'))) <|> eof - whitespace - -aheadO :: Parser () -aheadO = do - void (lookAhead (space <|> alphaNum <|> oneOf ")};")) <|> eof - whitespace - -whitespace :: Parser () -whitespace = void $ many space - -reservedWords :: [String] -reservedWords = ["case", "of", "class", "instance", "where", "let", "in"] -- cgit v1.2.3-70-g09d2