MixfixParser.hs revision 70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8
93fa7e4374de6e37328e752991a698bf03032c75Christian Maeder Author: Christian Maeder
93fa7e4374de6e37328e752991a698bf03032c75Christian Maeder Mixfix analysis of terms
d697755cce49a436e1170e8e158c19f79b0389b8Christian Maedermodule MixfixParser where
d697755cce49a436e1170e8e158c19f79b0389b8Christian Maederimport AS_Basic_CASL
d697755cce49a436e1170e8e158c19f79b0389b8Christian Maederimport GlobalAnnotations
e4eed2389ec1b1bfa03c662c71e8165e93df43c4Christian Maederimport FiniteMap
fd40e201b7277427113c89724d8a2389c18e9cbdChristian Maederimport Lexer (caslChar)
fd40e201b7277427113c89724d8a2389c18e9cbdChristian Maederimport ParsecPrim
d697755cce49a436e1170e8e158c19f79b0389b8Christian Maederimport qualified Char as C
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maederimport List(intersperse)
e4eed2389ec1b1bfa03c662c71e8165e93df43c4Christian Maeder-- Earley Algorithm
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder-- after matching one place literally all places must match literally
e4eed2389ec1b1bfa03c662c71e8165e93df43c4Christian Maederdata State = State { rule :: Id
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder , matchPlace :: Maybe Bool -- still open, true or false
e4eed2389ec1b1bfa03c662c71e8165e93df43c4Christian Maeder , dotPos :: [Token]
93fa7e4374de6e37328e752991a698bf03032c75Christian Maeder , rulePos :: Int
e4eed2389ec1b1bfa03c662c71e8165e93df43c4Christian Maeder } deriving (Eq, Ord)
e4eed2389ec1b1bfa03c662c71e8165e93df43c4Christian Maederprefix :: Id -> Bool
e4eed2389ec1b1bfa03c662c71e8165e93df43c4Christian Maederprefix (Id ts _ _) = if null ts then False else not $ isPlace $ head ts
93fa7e4374de6e37328e752991a698bf03032c75Christian MaedergetTokenList :: Id -> [Token]
93fa7e4374de6e37328e752991a698bf03032c75Christian MaedergetTokenList (Id ts cs _) =
93fa7e4374de6e37328e752991a698bf03032c75Christian Maeder let (pls, toks) = span isPlace (reverse ts)
93fa7e4374de6e37328e752991a698bf03032c75Christian Maeder cts = if null cs then [] else (Token "[" nullPos) :
93fa7e4374de6e37328e752991a698bf03032c75Christian Maeder concat (intersperse [Token "," nullPos]
93fa7e4374de6e37328e752991a698bf03032c75Christian Maeder (map getTokenList cs)) ++ [Token "]" nullPos]
93fa7e4374de6e37328e752991a698bf03032c75Christian Maeder in reverse toks ++ cts ++ reverse pls
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian MaederinitialState :: Set Id -> FiniteMap Int (Set State)
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian MaederinitialState is = let ms = filter (not . prefix) $ setToList is
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder states = map (\i -> State i Nothing (getTokenList i) 0) ms
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder in unitFM 0 (mkSet states)
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian MaederdontMatchPlace, mayMatchNT :: Maybe Bool -> Bool
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian MaederdontMatchPlace Nothing = False
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian MaederdontMatchPlace (Just x) = not x
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian MaedermayMatchNT Nothing = True
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian MaedermayMatchNT (Just x) = not x
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maederscan :: Token -> Int -> FiniteMap Int (Set State) -> FiniteMap Int (Set State)
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder addToFM m (i+1) (mkSet $
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder foldr (\ (State o b ts k) l ->
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder if null ts || head ts /= t || isPlace t && dontMatchPlace b then l
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder else (State o (if isPlace t then Just True else b)
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder (tail ts) k) : l) []
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder (setToList $ lookUp m i))
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian MaederlookUp :: (Ord key) => FiniteMap key (Set a) -> key -> Set a
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian MaederlookUp m i = lookupWithDefaultFM m emptySet i
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maedercomplete :: PrecedenceGraph -> FiniteMap Int (Set State) -> [State] -> [State]
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maedercomplete g m l =
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder l1 = filter (\ (State _ _ ts _) -> null ts) l
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder ll2 = map (\ (State _ _ _ k) -> setToList $ lookUp m k) l1
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder ll3 = map (filter (\ (State _ b ts _) -> not (null ts)
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder && isPlace (head ts) && mayMatchNT b)) ll2
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder ll4 = map (map (\ (State o _ ts k) -> State o (Just False) (tail ts) k)) ll3
70ca840c8a6cf3591d5f9aa9a3de6fae42d696e8Christian Maeder in concat ll4
93fa7e4374de6e37328e752991a698bf03032c75Christian Maeder-- ---------------------------------------------------------------
93fa7e4374de6e37328e752991a698bf03032c75Christian Maeder-- convert literals
93fa7e4374de6e37328e752991a698bf03032c75Christian Maeder-- ---------------------------------------------------------------
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder-- isChar :: Token -> Bool
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder-- isChar t = head (tokStr t) == '\''
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaederisString :: Token -> Bool
fd40e201b7277427113c89724d8a2389c18e9cbdChristian MaederisString t = head (tokStr t) == '\"'
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaederisNumber :: Token -> Bool
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaederisNumber t = let s = tokStr t in length s > 1 && C.isDigit (head s)
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaederisFloating :: Token -> Bool
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder-- precondition: isNumber
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaederisFloating t = any (\c -> c == '.' || c == 'E') (tokStr t)
fd40e201b7277427113c89724d8a2389c18e9cbdChristian Maedersplit :: GenParser Char () String -> String -> (String, String)
fd40e201b7277427113c89724d8a2389c18e9cbdChristian Maedersplit p s = let ph = do hd <- p;
fd40e201b7277427113c89724d8a2389c18e9cbdChristian Maeder tl <- getInput;
fd40e201b7277427113c89724d8a2389c18e9cbdChristian Maeder return (hd, tl)
fd40e201b7277427113c89724d8a2389c18e9cbdChristian Maeder in case parse ph "" s of
fd40e201b7277427113c89724d8a2389c18e9cbdChristian Maeder Left _ -> error"split"
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaedermakeStringTerm :: Id -> Id -> Token -> TERM
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaedermakeStringTerm c f tok =
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder makeStrTerm (line, colm + 1) str
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder (line, colm) = tokPos tok
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder str = init (tail (tokStr tok))
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder makeStrTerm p@(lin, col) l =
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder if null l then asAppl c [] p
7bdf8f2044ee1bb844ec460e7d96fbdee69feda4Christian Maeder else let (hd, tl) = split caslChar l
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder real = if hd == "'" then "'\\''" else "'" ++ hd ++ "'"
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder -- convert "'" to "\'" and lookup character '\''
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder in asAppl f [asAppl (Id [Token real p] [] []) [] p,
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder makeStrTerm (lin, col + length hd) tl] p
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaedermakeNumberTerm :: Id -> Token -> TERM
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaedermakeNumberTerm f t@(Token n p@(lin, col)) =
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder [] -> error "makeNumberTerm"
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder [_] -> asAppl (Id [t] [] []) [] p
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder hd:tl -> asAppl f [asAppl (Id [Token [hd] p] [] []) [] p,
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder makeNumberTerm f (Token tl (lin, col+1))] p
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaedermakeFraction :: Id -> Id -> Token -> TERM
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaedermakeFraction f d t@(Token s p@(lin, col)) =
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder let (n, r) = span (\c -> c /= '.') s
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder dotcol = col + length n
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder in if null r then makeNumberTerm f t
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder else asAppl d [makeNumberTerm f (Token n p),
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder makeNumberTerm f (Token (tail r) (lin, dotcol + 1))]
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder (lin, dotcol)
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaedermakeSignedNumber :: Id -> Token -> TERM
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaedermakeSignedNumber f t@(Token n p@(lin, col)) =
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder [] -> error "makeSignedNumber"
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder if hd == '-' || hd == '+' then
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder asAppl (Id [Token [hd] p] [] [])
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder [makeNumberTerm f (Token tl (lin, col+1))] p
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder else makeNumberTerm f t
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaedermakeFloatTerm :: Id -> Id -> Id -> Token -> TERM
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaedermakeFloatTerm f d e t@(Token s p@(lin, col)) =
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder let (m, r) = span (\c -> c /= 'E') s
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder ecol = col + length m
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder in if null r then makeFraction f d t
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder else asAppl e [makeFraction f d (Token m p),
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder makeSignedNumber f (Token (tail r) (lin, ecol + 1))]
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaederasAppl :: Id -> [TERM] -> Pos -> TERM
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaederasAppl f args p = let pos = if null args then [] else [p]
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder in Application (Op_name f) args pos
fd40e201b7277427113c89724d8a2389c18e9cbdChristian Maeder-- analyse Mixfix_token
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaederconvertMixfixToken:: LiteralAnnos -> Token -> Result TERM
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian MaederconvertMixfixToken ga t =
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder if isString t then
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder case string_lit ga of
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder Nothing -> err "string"
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder Just (c, f) -> erg $ makeStringTerm c f t
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder-- else if isChar t then erg $ asAppl (Id [t] [] []) [] (tokPos t)
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder else if isNumber t then
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder case number_lit ga of
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder Nothing -> err "number"
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder Just f -> if isFloating t then
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder case float_lit ga of
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder Nothing -> err "floating"
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder Just (d, e) -> erg $ makeFloatTerm f d e t
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder else erg $ makeNumberTerm f t
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder else erg $ Mixfix_token t
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder where err s = Result([Error ("missing %" ++ s ++ " annotation") (tokPos t)],
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder Just (Mixfix_token t))
e31c7e91ecb4b23aac070f64fa1b099c05aadd0dChristian Maeder erg r = Result([], Just r)