7     Program Identificator Implementation FunctionBody

    11     Program Identifier Implementation

     8     | Unit Identificator Interface Implementation (Maybe Initialize) (Maybe Finalize)

    12     | Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize)

    13 data Implementation = Implementation Uses TypesAndVars Functions

    17 data Implementation = Implementation Uses TypesAndVars

    14     deriving Show

    18     deriving Show

    15 data Functions = Functions [Function]

    19 data Identifier = Identifier String

    16     deriving Show

    20     deriving Show

    17 data Function = Function String

    21 data TypesAndVars = TypesAndVars [TypeVarDeclaration]

    18     deriving Show

    22     deriving Show

    19 data Identificator = Identificator String

    23 data TypeVarDeclaration = TypeDeclaration TypeDecl

    20     deriving Show

    24     | ConstDeclaration String

    21 data FunctionBody = FunctionBody String

    25     | VarDeclaration String

    22     deriving Show

    26     | FunctionDeclaration Identifier Identifier (Maybe Phrase)

    23 data TypesAndVars = TypesAndVars String

    27     deriving Show

    24     deriving Show

    28 data TypeDecl = SimpleType Identifier

    25 data Initialize = Initialize Functions

    29     | RangeType Range

    26     deriving Show

    30     | ArrayDecl Range TypeDecl

    27 data Finalize = Finalize Functions

    31     deriving Show

    28     deriving Show

    32 data Range = Range Identifier    

    29 data Uses = Uses [Identificator]

    33     deriving Show

    30     deriving Show

    34 data Initialize = Initialize String

    31 

    35     deriving Show

    32 parsePascalUnit :: String -> Either ParseError PascalUnit

    36 data Finalize = Finalize String

    33 parsePascalUnit = parse pascalUnit "unit"

    37     deriving Show

    34     where

    38 data Uses = Uses [Identifier]

    35     comments = skipMany (comment >> spaces)

    39     deriving Show

    36     identificator = do

    40 data Phrase = ProcCall Identifier [Expression]

    41         | IfThenElse Expression Phrase (Maybe Phrase)

    42         | WhileCycle Expression Phrase

    43         | RepeatCycle Expression Phrase

    44         | ForCycle

    45         | Phrases [Phrase]

    46         | SwitchCase Expression [(Expression, Phrase)] (Maybe Phrase)

    47         | Assignment Identifier Expression

    48     deriving Show

    49 data Expression = Expression String

    50     | FunCall Identifier [Expression]

    51     | PrefixOp String Expression

    52     | BinOp String Expression Expression

    53     deriving Show

    54     

    55 

    56 pascalLanguageDef

    57     = emptyDef

    58     { commentStart   = "(*"

    59     , commentEnd     = "*)"

    60     , commentLine    = "//"

    61     , nestedComments = False

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

    63     , identLetter    = alphaNum <|> oneOf "_."

    64     , reservedNames  = [

    65             "begin", "end", "program", "unit", "interface"

    66             , "implementation", "and", "or", "xor", "shl"

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

    68             , "type", "var", "const", "out", "array"

    69             , "procedure", "function"

    70             ]

    71     , reservedOpNames= [] 

    72     , caseSensitive  = False   

    73     }

    74     

    75 pas = makeTokenParser pascalLanguageDef

    76     

    77 comments = do

    78     spaces

    79     skipMany $ do

    80         comment

    38         l <- letter <|> oneOf "_"

    82 

    39         ls <- many (alphaNum <|> oneOf "_")

    83 validIdChar = alphaNum <|> oneOf "_"    

    40         spaces

    84 

    41         return $ Identificator (l:ls)

    85 pascalUnit = do

    42 

    86     comments

    43     pascalUnit = do

    87     u <- choice [program, unit]

    44         spaces

    88     comments

    45         comments

    89     return u

    46         u <- choice [program, unit]

    90 

    47         comments

    91 comment = choice [

    48         spaces

    92         char '{' >> manyTill anyChar (try $ char '}')

    49         return u

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

    50 

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

    51     comment = choice [

    95         ]

    52             char '{' >> manyTill anyChar (try $ char '}')

    96 

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

    97 unit = do

    54             , string "//" >> manyTill anyChar (try newline)

    98     name <- liftM Identifier unitName

    55             ]

    99     comments

    56 

   100     int <- interface

    57     unit = do

   101     impl <- implementation

    58         name <- unitName

   102     comments

    59         spaces

   103     return $ Unit name int impl Nothing Nothing

    60         comments

   104     where

    61         int <- string "interface" >> interface

   105         unitName = between (string "unit" >> comments) (char ';') (identifier pas)

    62         manyTill anyChar (try $ string "implementation")

   106 

    63         spaces

   107 varsDecl = do

    64         comments

   108     v <- aVarDecl `sepBy1` (char ';' >> comments)

    65         impl <- implementation

   109     char ';'

    66         return $ Unit name int impl Nothing Nothing

   110     comments

    67         where

   111     return $ VarDeclaration $ show v

    68             unitName = between (string "unit") (char ';') identificator

   112     where

    69 

   113     aVarDecl = do

    70     interface = do

   114         ids <- (try (identifier pas) >>= \i -> comments >> return (Identifier i)) `sepBy1` (char ',' >> comments)

    71         spaces

   115         char ':'

    72         comments

   116         comments

    73         u <- uses

   117         t <- typeDecl

    74         return $ Interface u (TypesAndVars "")

   118         comments

    75 

   119         return (ids, t)

    76     program = do

   120         

    77         name <- programName

   121 typeDecl = choice [

    78         spaces

   122     arrayDecl

    79         comments

   123     , rangeDecl >>= return . RangeType

    80         impl <- implementation

   124     , identifier pas >>= return . SimpleType . Identifier

    81         return $ Program name impl (FunctionBody "")

   125     ] <?> "type declaration"

    82         where

   126     where

    83             programName = between (string "program") (char ';') identificator

   127     arrayDecl = do

    84 

   128         try $ string "array"

    85     implementation = do

   129         comments

    86         u <- uses

   130         char '['

    87         manyTill anyChar (try $ string "end.")

   131         r <- rangeDecl

    88         return $ Implementation u (TypesAndVars "") (Functions [])

   132         char ']'

    89 

   133         comments

    90     uses = liftM Uses (option [] u)

   134         string "of"

    91         where

   135         comments

    92             u = do

   136         t <- typeDecl

    93                 string "uses"

   137         return $ ArrayDecl r t

    94                 spaces

   138 

    95                 u <- (identificator >>= \i -> spaces >> return i) `sepBy1` (char ',' >> spaces)

   139 rangeDecl = choice [

    96                 char ';'

   140     identifier pas >>= return . Range . Identifier

    97                 spaces

   141     ] <?> "range declaration"

    98                 return u

   142 

   143 typeVarDeclaration isImpl = choice [

   144     varSection,

   145     funcDecl,

   146     procDecl

   147     ]

   148     where

   149     varSection = do

   150         try $ string "var"

   151         comments

   152         v <- varsDecl

   153         return v

   154             

   155     procDecl = do

   156         string "procedure"

   157         comments

   158         i <- liftM Identifier $ identifier pas

   159         optional $ do

   160             char '('

   161             varsDecl

   162             char ')'

   163         comments

   164         char ';'

   165         b <- if isImpl then

   166                 do

   167                 comments

   168                 typeVarDeclaration isImpl

   169                 comments

   170                 liftM Just functionBody

   171                 else

   172                 return Nothing

   173         comments

   174         return $ FunctionDeclaration i (Identifier "") b

   175         

   176     funcDecl = do

   177         string "function"

   178         comments

   179         char '('

   180         b <- manyTill anyChar (try $ char ')')

   181         char ')'

   182         comments

   183         char ':'

   184         ret <- identifier pas

   185         comments

   186         char ';'

   187         b <- if isImpl then

   188                 do

   189                 comments

   190                 typeVarDeclaration isImpl

   191                 comments

   192                 liftM Just functionBody

   193                 else

   194                 return Nothing

   195         return $ FunctionDeclaration (Identifier "function") (Identifier ret) Nothing

   196 

   197 program = do

   198     name <- liftM Identifier programName

   199     comments

   200     impl <- implementation

   201     comments

   202     return $ Program name impl

   203     where

   204         programName = between (string "program") (char ';') (identifier pas)

   205 

   206 interface = do

   207     string "interface"

   208     comments

   209     u <- uses

   210     comments

   211     tv <- many (typeVarDeclaration False)

   212     comments

   213     return $ Interface u (TypesAndVars tv)

   214 

   215 implementation = do

   216     string "implementation"

   217     comments

   218     u <- uses

   219     comments

   220     tv <- many (typeVarDeclaration True)

   221     string "end."

   222     comments

   223     return $ Implementation u (TypesAndVars tv)

   224 

   225 expression = buildExpressionParser table term <?> "expression"

   226     where

   227     term = comments >> choice [

   228         parens pas $ expression 

   229         , natural pas >>= return . Expression . show

   230         , funCall

   231         ] <?> "simple expression"

   232 

   233     table = [ 

   234           [Infix (string "^." >> return (BinOp "^.")) AssocLeft]

   235         , [Prefix (string "not" >> return (PrefixOp "not"))]

   236         , [  Infix (char '*' >> return (BinOp "*")) AssocLeft

   237            , Infix (char '/' >> return (BinOp "/")) AssocLeft

   238            ]

   239         , [  Infix (char '+' >> return (BinOp "+")) AssocLeft

   240            , Infix (char '-' >> return (BinOp "-")) AssocLeft

   241            ]

   242         , [  Infix (try (string "<>" )>> return (BinOp "<>")) AssocNone

   243            , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone

   244            , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone

   245            , Infix (char '<' >> return (BinOp "<")) AssocNone

   246            , Infix (char '>' >> return (BinOp ">")) AssocNone

   247            , Infix (char '=' >> return (BinOp "=")) AssocNone

   248            ]

   249         , [  Infix (try $ string "and" >> return (BinOp "and")) AssocNone

   250            , Infix (try $ string "or" >> return (BinOp "or")) AssocNone

   251            , Infix (try $ string "xor" >> return (BinOp "xor")) AssocNone

   252            ]

   253         ]

   254     

   255 phrasesBlock = do

   256     try $ string "begin"

   257     comments

   258     p <- manyTill phrase (try $ string "end")

   259     comments

   260     return $ Phrases p

   261     

   262 phrase = do

   263     o <- choice [

   264         phrasesBlock

   265         , ifBlock

   266         , whileCycle

   267         , switchCase

   268         , try $ identifier pas >>= \i -> string ":=" >> expression >>= return . Assignment (Identifier i)

   269         , procCall

   270         ]

   271     optional $ char ';'

   272     comments

   273     return o

   274 

   275 ifBlock = do

   276     try $ string "if"

   277     comments

   278     e <- expression

   279     comments

   280     string "then"

   281     comments

   282     o1 <- phrase

   283     comments

   284     o2 <- optionMaybe $ do

   285         try $ string "else"

   286         comments

   287         o <- phrase

   288         comments

   289         return o

   290     optional $ char ';'

   291     return $ IfThenElse e o1 o2

   292 

   293 whileCycle = do

   294     try $ string "while"

   295     comments

   296     e <- expression

   297     comments

   298     string "do"

   299     comments

   300     o <- phrase

   301     optional $ char ';'

   302     return $ WhileCycle e o

   303 

   304 switchCase = do

   305     try $ string "case"

   306     comments

   307     e <- expression

   308     comments

   309     string "of"

   310     comments

   311     cs <- many1 aCase

   312     o2 <- optionMaybe $ do

   313         try $ string "else"

   314         comments

   315         o <- phrase

   316         comments

   317         return o

   318     string "end"

   319     optional $ char ';'

   320     return $ SwitchCase e cs o2

   321     where

   322     aCase = do

   323         e <- expression

   324         comments

   325         char ':'

   326         comments

   327         p <- phrase

   328         comments

   329         return (e, p)

   330     

   331 procCall = do

   332     i <- liftM Identifier $ identifier pas

   333     p <- option [] $ (parens pas) parameters

   334     return $ ProcCall i p

   335 

   336 funCall = do

   337     i <- liftM Identifier $ identifier pas

   338     p <- option [] $ (parens pas) parameters

   339     return $ FunCall i p

   340 

   341 parameters = expression `sepBy` (char ',' >> comments)

   342         

   343 functionBody = do

   344     p <- phrasesBlock

   345     char ';'

   346     comments

   347     return p

   348 

   349 uses = liftM Uses (option [] u)

   350     where

   351         u = do

   352             string "uses"

   353             comments

   354             u <- (identifier pas >>= \i -> comments >> return (Identifier i)) `sepBy1` (char ',' >> comments)

   355             char ';'

   356             comments

   357             return u