aboutsummaryrefslogtreecommitdiff
path: root/src/Haskell
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haskell')
-rw-r--r--src/Haskell/Parser.hs182
-rw-r--r--src/Haskell/Parser/Def.hs100
-rw-r--r--src/Haskell/SimpleParser.hs135
3 files changed, 92 insertions, 325 deletions
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"]
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-22 15:46:38 +0100