hets/RelationalScheme/ParseRS.hs

	ParseRS.hs revision d98cfdc55591a9982c8ec759520b6a4c28bd9f55
{- |
Module      :  $Header$
Description :  abstract syntax for Relational Schemes
Copyright   :  Dominik Luecke, Uni Bremen 2008
License     :  similar to LGPL, see Hets/LICENSE.txt or LIZENZ.txt

Maintainer  :  luecke@informatik.uni-bremen.de
Stability   :  provisional
Portability :  portable

Parser for Relational Schemes
-}

module RelationalScheme.ParseRS where

import Common.AnnoState
import Common.Id
import Common.Lexer
import Common.AS_Annotation
import Control.Monad
import RelationalScheme.Keywords
import RelationalScheme.Sign
import RelationalScheme.AS
import qualified Data.Set as Set
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Error

foldRanges :: [Token] -> Range
foldRanges inR = foldl (\x y -> appRange x $ tokPos y) nullRange inR

-- ^ parse a simple word not in 'rskeywords'
rsVarId :: [String] -> AParser st Token
rsVarId ks =
     do
        tk <- pToken (reserved (ks++rsKeyWords) (scanAnyWords))
        addAnnos
        return tk

-- ^ Token parser that does not skip whitespaces
pTokenN :: CharParser st String -> CharParser st Token
pTokenN parser =
  bind (\ p s -> Token s (Range [p])) getPos (parser)

-- ^ parser for simple ids
rsSimpleId :: GenParser Char st Token
rsSimpleId = pTokenN (reserved rsKeyWords scanAnyWords)

parseRSScheme :: AParser st RSScheme
parseRSScheme =
    do
        spaces
        pos1 <- getPos
        tb <- parseRSTables
        rl <- parseRSRelationships
        pos2 <- getPos
        return $ RSScheme tb rl $ Range [pos1,pos2]

-- ^ Parser for set of relationships
parseRSRelationships :: AParser st RSRelationships
parseRSRelationships =
    do
        k <- asKey rsRelationships
        r <- many parseRSRel
        return $ RSRelationships r $ catPos [k]

-- ^ Parser for a single relationship
parseRSRel :: AParser st (Annoted RSRel)
parseRSRel =
    do
        la <- getAnnos
        l <- sepBy1 parseRSQualId commaT
        k <- asKey rsArrow
        r <- sepBy1 parseRSQualId commaT
        c <- parseRSRelTypes
        ra <- getAnnos
        return $ makeAnnoted la ra (RSRel l r c $ tokPos k)

-- ^ Parser for qualified Ids...
parseRSQualId :: AParser st RSQualId
parseRSQualId =
    do
        tn <- rsSimpleId
        string "."
        cn <- rsVarId []
        return $ RSQualId (simpleIdToId tn) (simpleIdToId cn) $ foldRanges [tn,cn]


-- ^ parser for collection of tables
parseRSTables :: AParser st RSTables
parseRSTables =
    do
        k <- asKey rsTables
        t <- many parseRSTable
        ot <- setConv t
        return $ RSTables
                    {
                        tables = ot
                    ,   rst_pos = tokPos k
                    }

setConv :: (Monad m) => [RSTable] -> m (Set.Set RSTable)
setConv t =
    let
        names = map t_name t
    in
      do
        foldM (\x y -> insertUnique y x) Set.empty names
        return $ foldl (\x y -> Set.insert y x) Set.empty t

insertUnique :: (Show a, Monad m, Ord a) => a -> Set.Set a -> m (Set.Set a)
insertUnique t s =
    case t `Set.notMember` s of
        True  -> return $ Set.insert t s
        False -> fail ("Duplicate definition of " ++ show t)

-- ^ parser for table
parseRSTable :: AParser st RSTable
parseRSTable =
    do
        la <- getAnnos
        tid <- rsVarId []
        oParenT
        cl <- sepBy1 parseRSColumn commaT
        cParenT
        ra <- getAnnos
        return $ RSTable
            {
                t_name  = simpleIdToId tid
            ,   columns = concat $ cl
            ,   t_pos   = tokPos tid
            ,   rsannos = la ++ ra
            ,   t_keys  = Set.fromList $ map c_name $ filter (\x -> c_key x == True) $ concat cl
            }

parseEntry :: AParser st (Token, Bool)
parseEntry =
    do
        iK <- look4Key
        iid <- rsVarId []
        return (iid, iK)

parseRSColumn :: AParser st [RSColumn]
parseRSColumn =
    do
        iid <- sepBy1 parseEntry commaT
        colonT
        dt <- parseRSDatatypes
        return $ map (\(x, y) -> RSColumn (simpleIdToId x) dt y $ foldRanges [x]) iid

look4Key :: AParser st Bool
look4Key =
    do
        asKey rsKey
        return True
    <|>
        return False

testParse ::GenParser tok (AnnoState ()) a
            -> [tok]
            -> Either Text.ParserCombinators.Parsec.Error.ParseError a
testParse par st = runParser par (emptyAnnos ()) "" st

longTest :: IO (Either ParseError RSScheme)
longTest = do x <- (readFile "RelationalScheme/test/rel.het"); return $ testParse parseRSScheme x

-- boring parser for rel types
parseRSRelTypes :: AParser st RSRelType
parseRSRelTypes =
    do
        asKey rs1to1
        return $ RSone_to_one
    <|>
    do
        asKey rs1tom
        return $ RSone_to_many
    <|>
    do
        asKey rsmto1
        return $ RSmany_to_one
     <|>
    do
        asKey rsmtom
        return $ RSmany_to_many

-- boring parser for data-types
parseRSDatatypes :: AParser st RSDatatype
parseRSDatatypes =
    do
        asKey rsBool
        return $ RSboolean
    <|>
    do
        asKey rsBin
        return $ RSbinary
    <|>
    do
        asKey rsDate
        return $ RSdate
     <|>
    do
        asKey rsDatetime
        return $ RSdatetime
     <|>
    do
        asKey rsDecimal
        return $ RSdecimal
     <|>
    do
        asKey rsFloat
        return $ RSfloat
      <|>
    do
        asKey rsInteger
        return $ RSinteger
     <|>
    do
        asKey rsString
        return $ RSstring
     <|>
    do
        asKey rsText
        return $ RStext
     <|>
    do
        asKey rsTime
        return $ RStime
      <|>
    do
        asKey rsTimestamp
        return $ RStimestamp

makeAnnoted :: [Annotation] -> [Annotation] -> a -> Annoted a
makeAnnoted l r sen = Annoted
                          {
                            item = sen
                          , l_annos = l
                          , r_annos = r
                          , opt_pos = nullRange
                          }