move weapons line away from hwconsts.h so that modifying it doesn't needlessly recompile everything, introduce a way to try documenting which weapons each number represents
module PascalParser whereimport Text.Parsecimport Text.Parsec.Charimport Text.Parsec.Tokenimport Text.Parsec.Languageimport Text.Parsec.Exprimport Text.Parsec.Primimport Text.Parsec.Combinatorimport Text.Parsec.Stringimport Control.Monadimport Data.Maybeimport Data.Charimport PascalBasicsimport PascalUnitSyntaxTreeknownTypes = ["shortstring", "ansistring", "char", "byte"]pascalUnit = do comments u <- choice [program, unit, systemUnit, redoUnit] comments return uiD = do i <- liftM (flip Identifier BTUnknown) (identifier pas) comments return iunit = do string "unit" >> comments name <- iD semi pas comments int <- interface impl <- implementation comments return $ Unit name int impl Nothing Nothingreference = buildExpressionParser table term <?> "reference" where term = comments >> choice [ parens pas (liftM RefExpression expression >>= postfixes) >>= postfixes , try $ typeCast >>= postfixes , char '@' >> liftM Address reference >>= postfixes , liftM SimpleReference iD >>= postfixes ] <?> "simple reference" table = [ ] postfixes r = many postfix >>= return . foldl (flip ($)) r postfix = choice [ parens pas (option [] parameters) >>= return . FunCall , char '^' >> return Dereference , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement , (char '.' >> notFollowedBy (char '.')) >> liftM (flip RecordField) reference ] typeCast = do t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes e <- parens pas expression comments return $ TypeCast (Identifier t BTUnknown) evarsDecl1 = varsParser sepEndBy1varsDecl = varsParser sepEndByvarsParser m endsWithSemi = do vs <- m (aVarDecl endsWithSemi) (semi pas) return vsaVarDecl endsWithSemi = do isVar <- liftM (== Just "var") $ if not endsWithSemi then optionMaybe $ choice [ try $ string "var" , try $ string "const" , try $ string "out" ] else return Nothing comments ids <- do i <- (commaSep1 pas) $ (try iD <?> "variable declaration") char ':' return i comments t <- typeDecl <?> "variable type declaration" comments init <- option Nothing $ do char '=' comments e <- initExpression comments return (Just e) return $ VarDeclaration isVar False (ids, t) initconstsDecl = do vs <- many1 (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i) comments return vs where aConstDecl = do comments i <- iD t <- optionMaybe $ do char ':' comments t <- typeDecl comments return t char '=' comments e <- initExpression comments return $ VarDeclaration False (isNothing t) ([i], fromMaybe (DeriveType e) t) (Just e)typeDecl = choice [ char '^' >> typeDecl >>= return . PointerTo , try (string "shortstring") >> return (String 255) , try (string "string") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255 , try (string "ansistring") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255 , arrayDecl , recordDecl , setDecl , functionType , sequenceDecl >>= return . Sequence , try iD >>= return . SimpleType , rangeDecl >>= return . RangeType ] <?> "type declaration" where arrayDecl = do try $ do optional $ (try $ string "packed") >> comments string "array" comments r <- option [] $ do char '[' r <- commaSep pas rangeDecl char ']' comments return r string "of" comments t <- typeDecl if null r then return $ ArrayDecl Nothing t else return $ foldr (\a b -> ArrayDecl (Just a) b) (ArrayDecl (Just $ head r) t) (tail r) recordDecl = do try $ do optional $ (try $ string "packed") >> comments string "record" comments vs <- varsDecl True union <- optionMaybe $ do string "case" comments iD comments string "of" comments many unionCase string "end" return $ RecordType vs union setDecl = do try $ string "set" >> space comments string "of" comments liftM Set typeDecl unionCase = do try $ commaSep pas $ (iD >> return ()) <|> (integer pas >> return ()) char ':' comments u <- parens pas $ varsDecl True char ';' comments return u sequenceDecl = (parens pas) $ (commaSep pas) (iD >>= \i -> optional (spaces >> char '=' >> spaces >> integer pas) >> return i) functionType = do fp <- try (string "function") <|> try (string "procedure") comments vs <- option [] $ parens pas $ varsDecl False comments ret <- if (fp == "function") then do char ':' comments ret <- typeDecl comments return ret else return VoidType optional $ try $ char ';' >> comments >> string "cdecl" comments return $ FunctionType ret vstypesDecl = many (aTypeDecl >>= \t -> comments >> return t) where aTypeDecl = do i <- try $ do i <- iD <?> "type declaration" comments char '=' return i comments t <- typeDecl comments semi pas comments return $ TypeDeclaration i trangeDecl = choice [ try $ rangeft , iD >>= return . Range ] <?> "range declaration" where rangeft = do e1 <- initExpression string ".." e2 <- initExpression return $ RangeFromTo e1 e2typeVarDeclaration isImpl = (liftM concat . many . choice) [ varSection, constSection, typeSection, funcDecl, operatorDecl ] where varSection = do try $ string "var" comments v <- varsDecl1 True <?> "variable declaration" comments return v constSection = do try $ string "const" comments c <- constsDecl <?> "const declaration" comments return c typeSection = do try $ string "type" comments t <- typesDecl <?> "type declaration" comments return t operatorDecl = do try $ string "operator" comments i <- manyTill anyChar space comments vs <- parens pas $ varsDecl False comments rid <- iD comments char ':' comments ret <- typeDecl comments return ret char ';' comments forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments) inline <- liftM (any (== "inline;")) $ many functionDecorator b <- if isImpl && (not forward) then liftM Just functionBody else return Nothing return $ [OperatorDeclaration i rid inline ret vs b] funcDecl = do fp <- try (string "function") <|> try (string "procedure") comments i <- iD vs <- option [] $ parens pas $ varsDecl False comments ret <- if (fp == "function") then do char ':' comments ret <- typeDecl comments return ret else return VoidType char ';' comments forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments) inline <- liftM (any (== "inline;")) $ many functionDecorator b <- if isImpl && (not forward) then liftM Just functionBody else return Nothing return $ [FunctionDeclaration i inline ret vs b] functionDecorator = do d <- choice [ try $ string "inline;" , try $ caseInsensitiveString "cdecl;" , try $ string "overload;" , try $ string "export;" , try $ string "varargs;" , try (string "external") >> comments >> iD >> optional (string "name" >> comments >> stringLiteral pas)>> string ";" ] comments return dprogram = do string "program" comments name <- iD (char ';') comments comments u <- uses comments tv <- typeVarDeclaration True comments p <- phrase comments char '.' comments return $ Program name (Implementation u (TypesAndVars tv)) pinterface = do string "interface" comments u <- uses comments tv <- typeVarDeclaration False comments return $ Interface u (TypesAndVars tv)implementation = do string "implementation" comments u <- uses comments tv <- typeVarDeclaration True string "end." comments return $ Implementation u (TypesAndVars tv)expression = do buildExpressionParser table term <?> "expression" where term = comments >> choice [ builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n BTUnknown)) , try (parens pas $ expression >>= \e -> notFollowedBy (comments >> char '.') >> return e) , brackets pas (commaSep pas iD) >>= return . SetExpression , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i , float pas >>= return . FloatLiteral . show , try $ integer pas >>= return . NumberLiteral . show , try (string "_S" >> stringLiteral pas) >>= return . StringLiteral , try (string "_P" >> stringLiteral pas) >>= return . PCharLiteral , stringLiteral pas >>= return . strOrChar , try (string "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c) , char '#' >> many digit >>= \c -> comments >> return (CharCode c) , char '$' >> many hexDigit >>= \h -> comments >> return (HexNumber h) --, char '-' >> expression >>= return . PrefixOp "-" , char '-' >> reference >>= return . PrefixOp "-" . Reference , (try $ string "not" >> notFollowedBy comments) >> unexpected "'not'" , try $ string "nil" >> return Null , reference >>= return . Reference ] <?> "simple expression" table = [ [ Prefix (try (string "not") >> return (PrefixOp "not")) , Prefix (try (char '-') >> return (PrefixOp "-"))] , [ Infix (char '*' >> return (BinOp "*")) AssocLeft , Infix (char '/' >> return (BinOp "/")) AssocLeft , Infix (try (string "div") >> return (BinOp "div")) AssocLeft , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft , Infix (try (string "in") >> return (BinOp "in")) AssocNone , Infix (try $ string "and" >> return (BinOp "and")) AssocLeft , Infix (try $ string "shl" >> return (BinOp "shl")) AssocLeft , Infix (try $ string "shr" >> return (BinOp "shr")) AssocLeft ] , [ Infix (char '+' >> return (BinOp "+")) AssocLeft , Infix (char '-' >> return (BinOp "-")) AssocLeft , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft ] , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone , Infix (char '<' >> return (BinOp "<")) AssocNone , Infix (char '>' >> return (BinOp ">")) AssocNone ] {-, [ Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone ] , [ Infix (try $ string "or" >> return (BinOp "or")) AssocLeft , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft ]-} , [ Infix (char '=' >> return (BinOp "=")) AssocNone ] ] strOrChar [a] = CharCode . show . ord $ a strOrChar a = StringLiteral aphrasesBlock = do try $ string "begin" comments p <- manyTill phrase (try $ string "end" >> notFollowedBy alphaNum) comments return $ Phrases pphrase = do o <- choice [ phrasesBlock , ifBlock , whileCycle , repeatCycle , switchCase , withBlock , forCycle , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> comments >> expression >>= return . Assignment r , builtInFunction expression >>= \(n, e) -> return $ BuiltInFunctionCall e (SimpleReference (Identifier n BTUnknown)) , procCall , char ';' >> comments >> return NOP ] optional $ char ';' comments return oifBlock = do try $ string "if" >> notFollowedBy (alphaNum <|> char '_') comments e <- expression comments string "then" comments o1 <- phrase comments o2 <- optionMaybe $ do try $ string "else" >> space comments o <- option NOP phrase comments return o return $ IfThenElse e o1 o2whileCycle = do try $ string "while" comments e <- expression comments string "do" comments o <- phrase return $ WhileCycle e owithBlock = do try $ string "with" >> space comments rs <- (commaSep1 pas) reference comments string "do" comments o <- phrase return $ foldr WithBlock o rsrepeatCycle = do try $ string "repeat" >> space comments o <- many phrase string "until" comments e <- expression comments return $ RepeatCycle e oforCycle = do try $ string "for" >> space comments i <- iD comments string ":=" comments e1 <- expression comments up <- liftM (== Just "to") $ optionMaybe $ choice [ try $ string "to" , try $ string "downto" ] --choice [string "to", string "downto"] comments e2 <- expression comments string "do" comments p <- phrase comments return $ ForCycle i e1 e2 p upswitchCase = do try $ string "case" comments e <- expression comments string "of" comments cs <- many1 aCase o2 <- optionMaybe $ do try $ string "else" >> notFollowedBy alphaNum comments o <- many phrase comments return o string "end" comments return $ SwitchCase e cs o2 where aCase = do e <- (commaSep pas) $ (liftM InitRange rangeDecl <|> initExpression) comments char ':' comments p <- phrase comments return (e, p)procCall = do r <- reference p <- option [] $ (parens pas) parameters return $ ProcCall r pparameters = (commaSep pas) expression <?> "parameters"functionBody = do tv <- typeVarDeclaration True comments p <- phrasesBlock char ';' comments return (TypesAndVars tv, p)uses = liftM Uses (option [] u) where u = do string "uses" comments u <- (iD >>= \i -> comments >> return i) `sepBy1` (char ',' >> comments) char ';' comments return uinitExpression = buildExpressionParser table term <?> "initialization expression" where term = comments >> choice [ liftM (uncurry BuiltInFunction) $ builtInFunction initExpression , try $ brackets pas (commaSep pas $ initExpression) >>= return . InitSet , try $ parens pas (commaSep pas $ initExpression) >>= \ia -> when (null $ tail ia) mzero >> return (InitArray ia) , try $ parens pas (sepEndBy recField (char ';' >> comments)) >>= return . InitRecord , parens pas initExpression , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . InitNumber . show) i , try $ float pas >>= return . InitFloat . show , try $ integer pas >>= return . InitNumber . show , stringLiteral pas >>= return . InitString , char '#' >> many digit >>= \c -> comments >> return (InitChar c) , char '$' >> many hexDigit >>= \h -> comments >> return (InitHexNumber h) , char '@' >> initExpression >>= \c -> comments >> return (InitAddress c) , try $ string "nil" >> return InitNull , itypeCast , iD >>= return . InitReference ] recField = do i <- iD spaces char ':' spaces e <- initExpression spaces return (i ,e) table = [ [ Prefix (char '-' >> return (InitPrefixOp "-")) ,Prefix (try (string "not") >> return (InitPrefixOp "not")) ] , [ Infix (char '*' >> return (InitBinOp "*")) AssocLeft , Infix (char '/' >> return (InitBinOp "/")) AssocLeft , Infix (try (string "div") >> return (InitBinOp "div")) AssocLeft , Infix (try (string "mod") >> return (InitBinOp "mod")) AssocLeft , Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft , Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone ] , [ Infix (char '+' >> return (InitBinOp "+")) AssocLeft , Infix (char '-' >> return (InitBinOp "-")) AssocLeft , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft ] , [ Infix (try (string "<>") >> return (InitBinOp "<>")) AssocNone , Infix (try (string "<=") >> return (InitBinOp "<=")) AssocNone , Infix (try (string ">=") >> return (InitBinOp ">=")) AssocNone , Infix (char '<' >> return (InitBinOp "<")) AssocNone , Infix (char '>' >> return (InitBinOp ">")) AssocNone , Infix (char '=' >> return (InitBinOp "=")) AssocNone ] {--, [ Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft ] , [ Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone ]--} --, [Prefix (try (string "not") >> return (InitPrefixOp "not"))] ] itypeCast = do t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes i <- parens pas initExpression comments return $ InitTypeCast (Identifier t BTUnknown) ibuiltInFunction e = do name <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) builtin spaces exprs <- option [] $ parens pas $ option [] $ commaSep1 pas $ e spaces return (name, exprs)systemUnit = do string "system;" comments string "type" comments t <- typesDecl string "var" v <- varsDecl True return $ System (t ++ v)redoUnit = do string "redo;" comments string "type" comments t <- typesDecl string "var" v <- varsDecl True return $ Redo (t ++ v)