1 {-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}

     2 module PascalBasics where

     3 

     4 import Text.Parsec.Combinator

     5 import Text.Parsec.Char

     6 import Text.Parsec.Prim

     7 import Text.Parsec.Token

     8 import Text.Parsec.Language

     9 import Data.Char

    10 import Control.Monad

    11 import Data.Functor.Identity

    12 

    13 char' :: Char -> Parsec String u ()

    14 char' = void . char

    15 

    16 string' :: String -> Parsec String u ()

    17 string' = void . string

    18 

    19 builtin :: [String]

    20 builtin = ["succ", "pred", "low", "high", "ord", "inc", "dec", "exit", "break", "continue", "length", "copy"]

    21 

    22 pascalLanguageDef :: GenLanguageDef String u Identity

    23 pascalLanguageDef

    24     = emptyDef

    25     { commentStart   = "(*"

    26     , commentEnd     = "*)"

    27     , commentLine    = "//"

    28     , nestedComments = False

    29     , identStart     = letter <|> oneOf "_"

    30     , identLetter    = alphaNum <|> oneOf "_"

    31     , opLetter       = letter

    32     , reservedNames  = [

    33             "begin", "end", "program", "unit", "interface"

    34             , "implementation", "and", "or", "xor", "shl"

    35             , "shr", "while", "do", "repeat", "until", "case", "of"

    36             , "type", "var", "const", "out", "array", "packed"

    37             , "procedure", "function", "with", "for", "to"

    38             , "downto", "div", "mod", "record", "set", "nil"

    39             , "cdecl", "external", "if", "then", "else"

    40             ] -- ++ builtin

    41     , caseSensitive  = False

    42     }

    43 

    44 preprocessorSwitch :: Stream String Identity Char => Parsec String u String

    45 preprocessorSwitch = do

    46     try $ string' "{$"

    47     s <- manyTill (noneOf "\n") $ char '}'

    48     return s

    49 

    50 caseInsensitiveString :: Stream String Identity Char => String -> Parsec String u String

    51 caseInsensitiveString s = do

    52     mapM_ (\a -> satisfy (\b -> toUpper a == toUpper b)) s <?> s

    53     return s

    54 

    55 pas :: GenTokenParser String u Identity

    56 pas = patch $ makeTokenParser pascalLanguageDef

    57     where

    58     patch tp = tp {stringLiteral = stringL}

    59 

    60 comment :: Stream String Identity Char => Parsec String u String

    61 comment = choice [

    62         char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}')

    63         , (try $ string "(*") >> manyTill anyChar (try $ string "*)")

    64         , (try $ string "//") >> manyTill anyChar (try newline)

    65         ]

    66 

    67 comments :: Parsec String u ()

    68 comments = do

    69     spaces

    70     skipMany $ do

    71         void $ preprocessorSwitch <|> comment

    72         spaces

    73 

    74 stringL :: Parsec String u String

    75 stringL = do

    76     char' '\''

    77     s <- (many $ noneOf "'")

    78     char' '\''

    79     ss <- many $ do

    80         char' '\''

    81         s' <- (many $ noneOf "'")

    82         char' '\''

    83         return $ '\'' : s'

    84     comments

    85     return $ concat (s:ss)