| -- | |
| -- Module : Minigent.Syntax.Parser |
| -- Copyright : (c) Data61 2018-2019 |
| -- Commonwealth Science and Research Organisation (CSIRO) |
| -- ABN 41 687 119 230 |
| -- License : BSD3 |
| -- |
| -- This parser uses the @Earley@ library to make it based on a nice declarative grammar |
| -- specification without too much noise. |
| -- |
| -- The algorithm is cubic in the worst case but linear normally. We test for and avoid ambiguity, |
| -- even though the Earley algorithm can handle ambiguous grammars, so that the parser can have |
| -- good errors and fast performance. |
| -- |
| -- It can be imported unqualified or qualified, as there are very few exports. |
| {-# LANGUAGE RecursiveDo #-} |
| module Minigent.Syntax.Parser where |
| |
| import Text.Earley |
| import Control.Applicative |
| import Data.Maybe (isJust) |
| |
| import qualified Minigent.Syntax.Lexer as L |
| |
| import Minigent.Syntax |
| import Minigent.Syntax.Utils |
| import qualified Minigent.Syntax.Utils.Row as Row |
| |
| -- | The grammar for multiple top-level declarations. |
| toplevels :: Grammar r (Prod r String L.Token [RawTopLevel]) |
| toplevels = mdo |
| tl <- toplevel |
| tls <- rule $ many tl |
| return tls |
| |
| -- | The grammar for a single top-level declarations. |
| toplevel :: Grammar r (Prod r String L.Token RawTopLevel) |
| toplevel = mdo |
| |
| let fromLowerIdent (L.LowerIdent n) = Just n |
| fromLowerIdent _ = Nothing |
| fromNumeric (L.Numeric n) = Just n |
| fromNumeric _ = Nothing |
| |
| reservedTypeNames = ["U8","U16","U32", "U64", "Bool","Unit"] |
| |
| reservedValueNames = ["Unit","True","False"] |
| |
| fromUpperType (L.UpperIdent n) | n `notElem` reservedTypeNames |
| = Just n |
| fromUpperType _ = Nothing |
| fromUpperValue (L.UpperIdent n) | n `notElem` reservedValueNames |
| = Just n |
| fromUpperValue _ = Nothing |
| |
| primTy <- rule $ U8 <$ token (L.UpperIdent "U8") |
| <|> U16 <$ token (L.UpperIdent "U16") |
| <|> U32 <$ token (L.UpperIdent "U32") |
| <|> U64 <$ token (L.UpperIdent "U64") |
| <|> Bool <$ token (L.UpperIdent "Bool") |
| <|> Unit <$ token (L.UpperIdent "Unit") |
| <?> "primitive type" |
| |
| |
| typeVar <- rule $ terminal fromLowerIdent <?> "type variable" |
| var <- rule $ terminal fromLowerIdent <?> "variable" |
| fieldName <- rule $ terminal fromLowerIdent <?> "field name" |
| absTypeName <- rule $ terminal fromUpperType <?> "abstract type" |
| conName <- rule $ terminal fromUpperValue <?> "Constructor" |
| |
| takenTag <- rule $ isJust <$> optional (token (L.Keyword L.Take)) |
| <?> "optional taken tag" |
| |
| fieldEntry <- rule $ Entry <$> fieldName <* token L.Colon <*> ty <*> takenTag |
| <?> "field entry" |
| |
| fieldEntries <- rule $ (:) <$> fieldEntry <* token L.Comma <*> fieldEntries |
| <|> (:[]) <$> fieldEntry |
| <?> "field entries" |
| |
| conEntry <- rule $ Entry <$> conName <*> ty <*> takenTag |
| <?> "constructor entry" |
| |
| conEntries <- rule $ (:) <$> conEntry <* token L.Bar <*> conEntries |
| <|> (:[]) <$> conEntry |
| <?> "constructor entries" |
| |
| |
| sigil <- rule $ Unboxed <$ token L.Hash |
| <|> ReadOnly <$ token L.Bang |
| <|> pure Writable |
| <?> "sigil" |
| |
| |
| atomicTy <- rule $ PrimType <$> primTy |
| <|> TypeVar <$> typeVar |
| <|> TypeVarBang <$> typeVar <* token (L.Bang) |
| <|> Record <$> recTy |
| <* token (L.Open L.Brace) |
| <*> (Row.fromList <$> fieldEntries) |
| <* token (L.Close L.Brace) |
| <*> sigil |
| <|> Variant <$ token (L.Operator Less) |
| <*> (Row.fromList <$> conEntries ) |
| <* token (L.Operator Greater) |
| <|> AbsType <$> absTypeName |
| <*> sigil |
| <*> pure [] |
| <|> id <$ token (L.Open L.Paren) |
| <*> ty |
| <* token (L.Close L.Paren) |
| |
| ty' <- rule $ AbsType <$> absTypeName |
| <*> sigil |
| <*> some atomicTy |
| <|> atomicTy |
| |
| ty <- rule $ Function <$> ty' <* token (L.Arrow) <*> ty |
| <|> ty' |
| |
| |
| bool <- rule $ True <$ token (L.UpperIdent "True") |
| <|> False <$ token (L.UpperIdent "False") |
| <?> "boolean" |
| |
| number <- rule $ terminal fromNumeric <?> "number" |
| literal <- rule $ BoolV <$> bool |
| <|> IntV <$> number |
| <|> UnitV <$ token (L.UpperIdent "Unit") |
| <?> "literal" |
| |
| types <- rule $ (:) <$> ty <* token (L.Comma) <*> types |
| <|> (:[]) <$> ty |
| <|> pure [] |
| |
| fieldInitialiser <- rule $ (,) <$> fieldName <* token (L.Equals) <*> exp |
| <?> "field initialiser" |
| |
| fieldInitialisers <- rule $ (:) <$> fieldInitialiser <* token (L.Comma) <*> fieldInitialisers |
| <|> (:[]) <$> fieldInitialiser |
| |
| atomExp <- rule $ Literal <$> literal |
| <|> Var <$> var |
| <|> TypeApp <$> var |
| <* token (L.Open L.Square) |
| <*> types |
| <* token (L.Close L.Square) |
| <|> If <$ token (L.Keyword L.If) |
| <*> exp |
| <* token (L.Keyword L.Then) |
| <*> exp |
| <* token (L.Keyword L.Else) |
| <*> exp |
| <* token (L.Keyword L.End) |
| <|> Let <$ token (L.Keyword L.Let) |
| <*> var |
| <* token (L.Equals) |
| <*> exp |
| <* token (L.Keyword L.In) |
| <*> exp |
| <* token (L.Keyword L.End) |
| <|> LetBang <$ token (L.Keyword L.Let) |
| <* token (L.Bang) |
| <* token (L.Open L.Paren) |
| <*> many var |
| <* token (L.Close L.Paren) |
| <*> var |
| <* token (L.Equals) |
| <*> exp |
| <* token (L.Keyword L.In) |
| <*> exp |
| <* token (L.Keyword L.End) |
| <|> Struct <$ token (L.Open L.Brace) |
| <*> fieldInitialisers |
| <* token (L.Close L.Brace) |
| <|> Case <$ token (L.Keyword L.Case) |
| <*> exp |
| <* token (L.Keyword L.Of) |
| <*> conName |
| <*> var |
| <* token (L.Arrow) |
| <*> exp |
| <* token (L.Bar) |
| <*> var |
| <* token (L.Arrow) |
| <*> exp |
| <* token (L.Keyword L.End) |
| <|> Esac <$ token (L.Keyword L.Case) |
| <*> exp |
| <* token (L.Keyword L.Of) |
| <*> conName |
| <*> var |
| <* token (L.Arrow) |
| <*> exp |
| <* token (L.Keyword L.End) |
| <|> Take <$ token (L.Keyword L.Take) |
| <*> var |
| <* token (L.Open L.Brace) |
| <*> fieldName |
| <* token (L.Equals) |
| <*> var |
| <* token (L.Close L.Brace) |
| <* token (L.Equals) |
| <*> exp |
| <* token (L.Keyword L.In) |
| <*> exp |
| <* token (L.Keyword L.End) |
| <|> Put <$ token (L.Keyword L.Put) |
| <*> exp |
| <* token (L.Dot) |
| <*> fieldName |
| <* token (L.Colon) |
| <* token (L.Equals) |
| <*> exp |
| <* token (L.Keyword L.End) |
| <|> Member <$> atomExp <* token (L.Dot) <*> fieldName |
| <|> id <$ token (L.Open L.Paren) |
| <*> exp |
| <* token (L.Close L.Paren) |
| <?> "expression (atomic)" |
| |
| appExp <- rule $ Apply <$> appExp <*> atomExp |
| <|> Con <$> conName <*> atomExp |
| <|> PrimOp Not . pure <$ token (L.Operator Not) <*> atomExp |
| <|> atomExp |
| <?> "expression (appExp)" |
| |
| |
| let binOp e1 o e2 = PrimOp o [e1, e2] |
| fromOp set (L.Operator o) | o `elem` set = Just o |
| fromOp _ _ = Nothing |
| |
| |
| prodExp <- rule $ binOp <$> prodExp <*> terminal (fromOp prodOps) <*> appExp |
| <|> appExp |
| <?> "expression (prodExp)" |
| sumExp <- rule $ binOp <$> sumExp <*> terminal (fromOp sumOps) <*> prodExp |
| <|> prodExp |
| <?> "expression (sumExp)" |
| compExp <- rule $ binOp <$> sumExp <*> terminal (fromOp compOps) <*> sumExp |
| <|> sumExp |
| <?> "expression (compExp)" |
| boolExp <- rule $ binOp <$> boolExp <*> terminal (fromOp boolOps) <*> compExp |
| <|> compExp |
| <?> "expression (boolExp)" |
| exp <- rule $ Sig <$> exp <* token (L.Colon) <*> ty |
| <|> boolExp <?> "expression" |
| |
| typeVars <- rule $ (:) <$> typeVar <* token (L.Comma) <*> typeVars |
| <|> (:[]) <$> typeVar |
| <|> pure [] |
| |
| -- rec t |
| recTy <- rule $ Rec <$> (token (L.Keyword L.Rec) *> typeVar) |
| -- recursive parameter ommitted |
| <|> pure None |
| <?> "recursive type" |
| |
| constraint <- rule $ Share . TypeVar <$ token (L.UpperIdent "Share") <*> typeVar |
| <|> Drop . TypeVar <$ token (L.UpperIdent "Drop") <*> typeVar |
| <|> Escape . TypeVar <$ token (L.UpperIdent "Escape") <*> typeVar |
| |
| constraints <- rule $ (:) <$> constraint <* token (L.Comma) <*> constraints |
| <|> (:[]) <$> constraint |
| <|> pure [] |
| |
| polyType <- rule $ Forall <$ token (L.Open L.Square) |
| <*> typeVars |
| <* token (L.Close L.Square) |
| <*> constraints |
| <* token (L.Dot) |
| <*> ty |
| <|> Forall [] [] <$> ty |
| topLevel <- rule $ TypeSig <$> var |
| <* token (L.Colon) |
| <*> polyType |
| <* token (L.Semi) |
| <|> Equation <$> var |
| <*> var |
| <* token (L.Equals) |
| <*> exp |
| <* token (L.Semi) |
| return topLevel |
