| Line No. | Rev | Author | Line |
|---|---|---|---|
| 1 | 1 | paulosilva | |
| 2 | {-# LANGUAGE FlexibleContexts #-} | ||
| 3 | {-# OPTIONS_GHC -Wall #-} | ||
| 4 | |||
| 5 | ------------------------------------------------------------------------------- | ||
| 6 | |||
| 7 | {- | | ||
| 8 | Module : Language.Module.Parser | ||
| 9 | Description : | ||
| 10 | Copyright : (c) Paulo Silva | ||
| 11 | License : LGPL | ||
| 12 | |||
| 13 | Maintainer : paufil@di.uminho.pt | ||
| 14 | Stability : experimental | ||
| 15 | Portability : portable | ||
| 16 | |||
| 17 | <description of the module> | ||
| 18 | -} | ||
| 19 | |||
| 20 | ------------------------------------------------------------------------------- | ||
| 21 | |||
| 22 | module Language.Module.Parser ( | ||
| 23 | parser | ||
| 24 | ) where | ||
| 25 | |||
| 26 | import Control.GalcError | ||
| 27 | import Control.Monad.Error | ||
| 28 | import Language.Law.Parser hiding (parser) | ||
| 29 | import Language.Law.SyntaxADT | ||
| 30 | import qualified Language.Law.SyntaxADT as L | ||
| 31 | import Language.Module.SyntaxADT | ||
| 32 | import Language.R.Parser hiding (parser) | ||
| 33 | import Language.R.SyntaxADT | ||
| 34 | import Text.ParserCombinators.Parsec | ||
| 35 | import Text.ParserCombinators.Parsec.Char | ||
| 36 | import Text.ParserCombinators.Parsec.Language | ||
| 37 | import qualified Text.ParserCombinators.Parsec.Token as P | ||
| 38 | |||
| 39 | ------------------------------------------------------------------------------- | ||
| 40 | |||
| 41 | type ModuleParser = Parser ModuleS | ||
| 42 | |||
| 43 | ------------------------------------------------------------------------------- | ||
| 44 | |||
| 45 | reservNames :: [String] | ||
| 46 | reservNames = ["module"] | ||
| 47 | |||
| 48 | ------------------------------------------------------------------------------- | ||
| 49 | |||
| 50 | lexer :: P.TokenParser st | ||
| 51 | lexer = P.makeTokenParser $ haskellStyle { P.reservedNames = reservNames } | ||
| 52 | |||
| 53 | ------------------------------------------------------------------------------- | ||
| 54 | |||
| 55 | reserved :: String -> CharParser st () | ||
| 56 | reserved = P.reserved lexer | ||
| 57 | |||
| 58 | whiteSpace :: CharParser st () | ||
| 59 | whiteSpace = P.whiteSpace lexer | ||
| 60 | |||
| 61 | {- | ||
| 62 | parens :: CharParser st Module -> CharParser st Module | ||
| 63 | parens = P.parens lexer | ||
| 64 | -} | ||
| 65 | |||
| 66 | identifier :: CharParser st String | ||
| 67 | identifier = P.identifier lexer | ||
| 68 | |||
| 69 | semi :: CharParser st String | ||
| 70 | semi = P.semi lexer | ||
| 71 | |||
| 72 | ------------------------------------------------------------------------------- | ||
| 73 | |||
| 74 | parser :: MonadError GalcError m => String -> m ModuleS | ||
| 75 | parser = either2error (ParsingError . show) . parse mainModuleParser "" | ||
| 76 | |||
| 77 | ------------------------------------------------------------------------------- | ||
| 78 | |||
| 79 | mainModuleParser :: ModuleParser | ||
| 80 | mainModuleParser = do | ||
| 81 | whiteSpace | ||
| 82 | m <- parseModule | ||
| 83 | eof | ||
| 84 | return m | ||
| 85 | |||
| 86 | ------------------------------------------------------------------------------- | ||
| 87 | |||
| 88 | data Union = L LawS | G S | D S | ||
| 89 | |||
| 90 | parseModule :: ModuleParser | ||
| 91 | parseModule = do | ||
| 92 | reserved "module" | ||
| 93 | ident <- identifier | ||
| 94 | lst <- ((do l <- parseLaw | ||
| 95 | return $ L l) | ||
| 96 | <|> | ||
| 97 | (do g <- parseGDef | ||
| 98 | return $ G g) | ||
| 99 | <|> | ||
| 100 | (do d <- parseDEF | ||
| 101 | return $ D d)) `sepEndBy` semi | ||
| 102 | let (lws,gcs',defs) = union2List lst | ||
| 103 | return $ ModuleS { nameS = ident, | ||
| 104 | lawsS = lws, | ||
| 105 | gcsS = gcs', | ||
| 106 | definitionsS = defs } | ||
| 107 | |||
| 108 | ------------------------------------------------------------------------------- | ||
| 109 | |||
| 110 | union2List :: [Union] -> ([LawS],[S],[S]) | ||
| 111 | union2List = foldl aux ([],[],[]) | ||
| 112 | where aux (law,gc,def) (L law') = (law':law, gc, def) | ||
| 113 | aux (law,gc,def) (G gc') = (law, gc':gc, def) | ||
| 114 | aux (law,gc,def) (D def') = (law, gc, def':def) | ||
| 115 | |||
| 116 | ------------------------------------------------------------------------------- | ||
| 117 |