diff options
Diffstat (limited to 'src/Language/Fiddle/Parser.hs')
| -rw-r--r-- | src/Language/Fiddle/Parser.hs | 240 |
1 files changed, 112 insertions, 128 deletions
diff --git a/src/Language/Fiddle/Parser.hs b/src/Language/Fiddle/Parser.hs index 85ae65e..980925f 100644 --- a/src/Language/Fiddle/Parser.hs +++ b/src/Language/Fiddle/Parser.hs @@ -33,8 +33,8 @@ type Pa (a :: Stage -> (Type -> Type) -> Type -> Type) = P (a 'Stage1 F (Comment type PaS (a :: (Type -> Type) -> Type -> Type) = P (a F (Commented SourceSpan)) -comment :: P Comment -comment = +commentP :: P Comment +commentP = token $ \case (TokComment c) -> Just (NormalComment c) (TokDocComment c) -> Just (DocComment c) @@ -52,46 +52,46 @@ isComment (Token t _) = stripTrailingComments :: [Token s] -> [Token s] stripTrailingComments = reverse . dropWhile isComment . reverse -directed :: Pa t -> PaS (Directed t 'Stage1) -directed subparser = withMeta $ do - Directed <$> many directive <*> subparser +directedP :: Pa t -> PaS (Directed t 'Stage1) +directedP subparser = withMeta $ do + Directed <$> many directiveP <*> subparser -directive :: PaS Directive -directive = +directiveP :: PaS Directive +directiveP = withMeta $ - Directive <$> defer directiveBodyTokens directiveBody + Directive <$> defer directiveBodyTokens directiveBodyP -directiveBody :: PaS DirectiveBody -directiveBody = withMeta $ do - DirectiveBody <$> many (directiveElement <* (void (tok TokComma) <|> eof)) +directiveBodyP :: PaS DirectiveBody +directiveBodyP = withMeta $ do + DirectiveBody <$> many (directiveElementP <* (void (tok TokComma) <|> eof)) -directiveElement :: PaS DirectiveElement -directiveElement = withMeta $ do - identifier1 <- nextText +directiveElementP :: PaS DirectiveElement +directiveElementP = withMeta $ do + identifier1 <- nextTextP choice [ do tok TokColon let backend = identifier1 - key <- nextText + key <- nextTextP choice [ do tok TokEq - DirectiveElementKeyValue (Just backend) key <$> directiveExpression, + DirectiveElementKeyValue (Just backend) key <$> directiveExpressionP, do return (DirectiveElementKey (Just backend) key) ], do tok TokEq let key = identifier1 - DirectiveElementKeyValue Nothing key <$> directiveExpression, + DirectiveElementKeyValue Nothing key <$> directiveExpressionP, return $ DirectiveElementKey Nothing identifier1 ] -nextText :: PaS Identifier -nextText = withMeta $ Identifier <$> token textOf +nextTextP :: PaS Identifier +nextTextP = withMeta $ Identifier <$> token textOf -directiveExpression :: PaS DirectiveExpression -directiveExpression = withMeta $ do +directiveExpressionP :: PaS DirectiveExpression +directiveExpressionP = withMeta $ do choice [ do token $ \case @@ -103,80 +103,64 @@ directiveExpression = withMeta $ do fiddleUnit :: Pa FiddleUnit fiddleUnit = do withMeta - ( FiddleUnit <$> many1 (directed fiddleDecl <* tok TokSemi) + ( FiddleUnit <$> many1 (directedP fiddleDeclP <* tok TokSemi) ) - <* many comment + <* many commentP -stringToken :: P Text -stringToken = +stringTokenP :: P Text +stringTokenP = token ( \case (TokString str) -> Just str _ -> Nothing ) -importList :: PaS ImportList -importList = withMeta $ do +importListP :: PaS ImportList +importListP = withMeta $ do tok TokLParen ImportList <$> many (ident <* (tok TokComma <|> lookAhead (tok TokRParen))) <* tok TokRParen -importStatement :: PaS ImportStatement -importStatement = +importStatementP :: PaS ImportStatement +importStatementP = withMeta $ - ImportStatement <$> stringToken <*> optionMaybe importList + ImportStatement <$> stringTokenP <*> optionMaybe importListP -fiddleDecl :: Pa FiddleDecl -fiddleDecl = do +fiddleDeclP :: Pa FiddleDecl +fiddleDeclP = do withMeta $ do t <- tokenType <$> anyToken case t of - KWOption -> OptionDecl <$> nextText <*> nextText + KWOption -> OptionDecl <$> nextTextP <*> nextTextP KWPackage -> PackageDecl <$> name - <*> defer body packageBody + <*> defer body packageBodyP KWUsing -> UsingDecl <$> name - KWLocation -> LocationDecl <$> ident <*> (tok TokEq >> expression) - KWBits -> BitsDecl <$> ident <*> (tok TokColon >> bitType) - KWImport -> ImportDecl <$> importStatement + KWLocation -> LocationDecl <$> ident <*> (tok TokEq >> expressionP) + KWBits -> BitsDecl <$> ident <*> (tok TokColon >> bitTypeP) + KWImport -> ImportDecl <$> importStatementP KWType -> ObjTypeDecl <$> ident <*> ( do tok TokColon - bt <- bodyType - defer body (objTypeBody bt) + bt <- bodyTypeP + defer body (objTypeBodyP bt) ) KWInstance -> ObjectDecl <$> ident - <*> (tok KWAt *> expression) - <*> (tok TokColon *> objType) + <*> (tok KWAt *> expressionP) + <*> (tok TokColon *> objTypeP) _ -> fail $ printf "Unexpected token %s. Expected top-level declaration." (show t) --- choice --- [ tok KWOption >> OptionDecl <$> ident <*> ident, --- tok KWPackage >> PackageDecl --- <$> ident --- <*> defer body packageBody, --- tok KWLocation >> LocationDecl <$> ident <*> (tok TokEq >> expression), --- tok KWBits >> BitsDecl <$> ident <*> (tok TokColon >> bitType), --- tok KWObjtype --- >> ObjTypeDecl <$> ident <*> (tok TokColon >> defer body objTypeBody), --- tok KWObject --- >> ObjectDecl --- <$> ident --- <*> (tok KWAt *> expression) --- <*> (tok TokColon *> objType) --- ] - -objType :: Pa ObjType -objType = do - base <- withMeta baseObj +objTypeP :: Pa ObjType +objTypeP = do + base <- withMeta baseObjP recur' <- recur return $ recur' base where @@ -184,54 +168,54 @@ objType = do recur = ( do withMeta $ do - expr <- tok TokLBracket *> expression <* tok TokRBracket + expr <- tok TokLBracket *> expressionP <* tok TokRBracket recur' <- recur return (\met base -> recur' (ArrayObjType base expr met)) ) <|> return id - baseObj :: P (A -> ObjType Stage1 F A) - baseObj = + baseObjP :: P (A -> ObjType Stage1 F A) + baseObjP = (ReferencedObjType <$> name) <|> ( do - t <- bodyType - AnonymousObjType (Witness ()) <$> defer body (objTypeBody t) + t <- bodyTypeP + AnonymousObjType (Witness ()) <$> defer body (objTypeBodyP t) ) -exprInParen :: Pa Expression -exprInParen = tok TokLParen *> expression <* tok TokRParen +exprInParenP :: Pa Expression +exprInParenP = tok TokLParen *> expressionP <* tok TokRParen -objTypeBody :: BodyType F (Commented SourceSpan) -> Pa ObjTypeBody -objTypeBody bt = +objTypeBodyP :: BodyType F (Commented SourceSpan) -> Pa ObjTypeBody +objTypeBodyP bt = withMeta $ - ObjTypeBody bt <$> many (directed objTypeDecl <* tok TokSemi) + ObjTypeBody bt <$> many (directedP objTypeDeclP <* tok TokSemi) -objTypeDecl :: Pa ObjTypeDecl -objTypeDecl = +objTypeDeclP :: Pa ObjTypeDecl +objTypeDeclP = withMeta $ ( do tok KWAssertPos - AssertPosStatement (Witness ()) <$> exprInParen + AssertPosStatement (Witness ()) <$> exprInParenP ) <|> ( do tok KWReserved - ReservedDecl <$> exprInParen + ReservedDecl <$> exprInParenP ) <|> ( do - bt <- bodyType - TypeSubStructure <$> defer body (objTypeBody bt) <*> optionMaybe ident + bt <- bodyTypeP + TypeSubStructure <$> defer body (objTypeBodyP bt) <*> optionMaybe ident ) <|> ( do - mod <- optionMaybe modifier + mod <- optionMaybe modifierP tok KWReg RegisterDecl mod <$> optionMaybe ident - <*> exprInParen - <*> optionMaybe (tok TokColon *> registerBody) + <*> exprInParenP + <*> optionMaybe (tok TokColon *> registerBodyP) ) -modifier :: PaS Modifier -modifier = +modifierP :: PaS Modifier +modifierP = withMeta $ ModifierKeyword <$> choice @@ -240,87 +224,87 @@ modifier = tok KWWo >> return Wo ] -bitBodyType :: PaS BodyType -bitBodyType = +bitBodyTypeP :: PaS BodyType +bitBodyTypeP = withMeta $ (tok KWStruct >> return Struct) <|> (tok KWUnion >> return Union) -bodyType :: PaS BodyType -bodyType = +bodyTypeP :: PaS BodyType +bodyTypeP = withMeta $ (tok KWStruct >> return Struct) <|> (tok KWUnion >> return Union) -registerBody :: Pa RegisterBody -registerBody = withMeta $ RegisterBody <$> bitBodyType <*> defer body deferredRegisterBody +registerBodyP :: Pa RegisterBody +registerBodyP = withMeta $ RegisterBody <$> bitBodyTypeP <*> defer body deferredRegisterBodyP -deferredRegisterBody :: Pa DeferredRegisterBody -deferredRegisterBody = +deferredRegisterBodyP :: Pa DeferredRegisterBody +deferredRegisterBodyP = withMeta $ - DeferredRegisterBody <$> many (directed registerBitsDecl <* tok TokSemi) + DeferredRegisterBody <$> many (directedP registerBitsDeclP <* tok TokSemi) -registerBitsDecl :: Pa RegisterBitsDecl -registerBitsDecl = +registerBitsDeclP :: Pa RegisterBitsDecl +registerBitsDeclP = withMeta $ ( do - tok KWReserved >> ReservedBits <$> exprInParen + tok KWReserved >> ReservedBits <$> exprInParenP ) - <|> (BitsSubStructure <$> registerBody <*> optionMaybe ident) + <|> (BitsSubStructure <$> registerBodyP <*> optionMaybe ident) <|> ( DefinedBits - <$> optionMaybe modifier + <$> optionMaybe modifierP <*> ident - <*> (tok TokColon >> registerBitsTypeRef) + <*> (tok TokColon >> registerBitsTypeRefP) ) -registerBitsTypeRef :: Pa RegisterBitsTypeRef -registerBitsTypeRef = do +registerBitsTypeRefP :: Pa RegisterBitsTypeRef +registerBitsTypeRefP = do base <- baseTypeRef - recur' <- recur + recur' <- recurP return (recur' base) where - recur :: P (RegisterBitsTypeRef Stage1 F A -> RegisterBitsTypeRef Stage1 F A) - recur = + recurP :: P (RegisterBitsTypeRef Stage1 F A -> RegisterBitsTypeRef Stage1 F A) + recurP = ( do withMeta $ do - expr <- tok TokLBracket *> expression <* tok TokRBracket - recur' <- recur + expr <- tok TokLBracket *> expressionP <* tok TokRBracket + recur' <- recurP return (\met base -> recur' (RegisterBitsArray base expr met)) ) <|> return id baseTypeRef = withMeta $ - (RegisterBitsJustBits <$> exprInParen) - <|> (RegisterBitsAnonymousType (Witness ()) <$> anonymousBitsType) + (RegisterBitsJustBits <$> exprInParenP) + <|> (RegisterBitsAnonymousType (Witness ()) <$> anonymousBitsTypeP) <|> (RegisterBitsReference <$> name) -anonymousBitsType :: Pa AnonymousBitsType -anonymousBitsType = withMeta $ do +anonymousBitsTypeP :: Pa AnonymousBitsType +anonymousBitsTypeP = withMeta $ do tok KWEnum - AnonymousEnumBody <$> exprInParen <*> defer body enumBody + AnonymousEnumBody <$> exprInParenP <*> defer body enumBodyP -bitType :: Pa BitType -bitType = withMeta $ rawBits <|> enumType +bitTypeP :: Pa BitType +bitTypeP = withMeta $ rawBits <|> enumType where - rawBits = RawBits <$> (tok TokLParen *> expression <* tok TokRParen) + rawBits = RawBits <$> (tok TokLParen *> expressionP <* tok TokRParen) enumType = do tok KWEnum - expr <- exprInParen - EnumBitType expr <$> defer body enumBody + expr <- exprInParenP + EnumBitType expr <$> defer body enumBodyP -enumBody :: Pa EnumBody -enumBody = +enumBodyP :: Pa EnumBody +enumBodyP = withMeta $ - EnumBody <$> many (directed enumConstantDecl <* tok TokComma) + EnumBody <$> many (directedP enumConstantDeclP <* tok TokComma) -enumConstantDecl :: Pa EnumConstantDecl -enumConstantDecl = +enumConstantDeclP :: Pa EnumConstantDecl +enumConstantDeclP = withMeta $ - (tok KWReserved >> EnumConstantReserved <$> (tok TokEq >> expression)) - <|> (EnumConstantDecl <$> ident <*> (tok TokEq >> expression)) + (tok KWReserved >> EnumConstantReserved <$> (tok TokEq >> expressionP)) + <|> (EnumConstantDecl <$> ident <*> (tok TokEq >> expressionP)) -expression :: Pa Expression -expression = withMeta $ +expressionP :: Pa Expression +expressionP = withMeta $ token $ \case (TokLitNum num) -> Just (LitNum num) (TokIdent i) -> Just $ @@ -373,13 +357,13 @@ defer p0 pb = do (sourceName sourcePos) <$> p0 -packageBody :: Pa PackageBody -packageBody = +packageBodyP :: Pa PackageBody +packageBodyP = withMeta $ PackageBody <$> many - ( directed $ - fiddleDecl + ( directedP $ + fiddleDeclP <* ( tok TokSemi <|> fail "Expected ';'" ) ) @@ -409,7 +393,7 @@ name = withMeta $ do -- and after and sets the positions and adds it to the annotation. withMeta :: P (Commented SourceSpan -> b) -> P b withMeta p = do - comments <- many comment + comments <- many commentP start <- getPosition fn <- p end <- getPosition @@ -431,7 +415,7 @@ tokKeepComment t' = do tok :: T -> P (Token SourceSpan) tok t' = do - many comment + many commentP Text.Parsec.token (\(Token t _) -> show t) (\(Token _ (SourceSpan s1 _)) -> s1) |