2b873214c9ab511bbca437c036371ab664aedaceChristian Maeder

f66fcd981f556c238df7dd6dfa42123745e3b1d2Christian Maeder{- |

c63ebf815c8a874525cf18670ad74847f7fc7b26Christian MaederModule : $Header$

c092fcac4b8f5c524c22ca579189c4487c13edf7Christian MaederCopyright : Christian Maeder and Uni Bremen 2003

54ed6a6b1a6c7d27fadb39ec5b59d0806c81f7c8Christian MaederLicence : similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt

75a6279dbae159d018ef812185416cf6df386c10Till Mossakowski

3f69b6948966979163bdfe8331c38833d5d90ecdChristian MaederMaintainer : hets@tzi.de

75a6279dbae159d018ef812185416cf6df386c10Till MossakowskiStability : experimental

75a6279dbae159d018ef812185416cf6df386c10Till MossakowskiPortability : portable

f66fcd981f556c238df7dd6dfa42123745e3b1d2Christian Maeder

c092fcac4b8f5c524c22ca579189c4487c13edf7Christian Maeder generic mixfix analysis

dda5ab793f1615c1ba1dcaa97a4346b0878da6b1Christian Maeder

f66fcd981f556c238df7dd6dfa42123745e3b1d2Christian Maeder-}

f66fcd981f556c238df7dd6dfa42123745e3b1d2Christian Maeder

da955132262baab309a50fdffe228c9efe68251dCui Jianmodule Common.Earley (

dda5ab793f1615c1ba1dcaa97a4346b0878da6b1Christian Maeder -- * special tokens for special ids

dda5ab793f1615c1ba1dcaa97a4346b0878da6b1Christian Maeder varTok, exprTok, typeTok

f66fcd981f556c238df7dd6dfa42123745e3b1d2Christian Maeder , applId, parenId, typeId, exprId, varId

f66fcd981f556c238df7dd6dfa42123745e3b1d2Christian Maeder , tupleId, unitId, unknownId, isUnknownId, unToken

0799b5dc3f06d2640e66e9ab54b8b217348fd719Christian Maeder , Knowns, mkId, protect, listRules, mixRule

0799b5dc3f06d2640e66e9ab54b8b217348fd719Christian Maeder , getTokenPlaceList

52d922076b89f12234f721974e82531bc69a6f69Christian Maeder -- * resolution chart

52d922076b89f12234f721974e82531bc69a6f69Christian Maeder , Chart, mixDiags, ToExpr

43b4c41fbb07705c9df321221ab9cb9832460407Christian Maeder , initChart, nextChart, getResolved)

4c8d3c5a9e938633f6147b5a595b9b93bfca99e6Christian Maeder where

91eeff7b19b22d7e5c5d83fa6e357496e291c718Christian Maeder

fbc4f8708092d571a45cb483f37cc6b674da45a7Christian Maederimport Common.Id

fbc4f8708092d571a45cb483f37cc6b674da45a7Christian Maederimport Common.Result

fbc4f8708092d571a45cb483f37cc6b674da45a7Christian Maederimport Common.Precedence

31bc219bae758272d0f064281b8ce7740a4553e9Till Mossakowskiimport Common.GlobalAnnotations

b10d6cef708b7a659f2d3b367e8e0db0d03ae3f5Till Mossakowskiimport qualified Common.Lib.Set as Set

f77f29e84b3f6e791c82e61b13fbf76582bedd2fChristian Maederimport qualified Common.Lib.Map as Map

dda5ab793f1615c1ba1dcaa97a4346b0878da6b1Christian Maederimport Data.List

9175e29c044318498a40f323f189f9dfd50378efChristian Maeder-- import Control.Exception (assert)

f77f29e84b3f6e791c82e61b13fbf76582bedd2fChristian Maeder-- import Debug.Trace(trace)

f66fcd981f556c238df7dd6dfa42123745e3b1d2Christian Maeder

c0c2380bced8159ff0297ece14eba948bd236471Christian Maederassert :: Bool -> a -> a

da333ffa6336cf59a4071fcddad358c5eafd3e61Sonja Gröningassert b a = if b then a else error ("assert")

c0c2380bced8159ff0297ece14eba948bd236471Christian Maeder

6352f3c31da3043783a13be6594aacb2147378baRazvan Pascanu-- | reconstruct the token list of an 'Id'.

8ef91a173e69219fc2ebd45c76a35891c7785abdMarkus Gross-- Replace top-level places with the input String

fc1a590cd3ee36797c0a032ff41e07f8e2469341Christian MaedergetTokenList :: String -> Id -> [Token]

a2b04db3e156312a8596d8084f7f0f51acf8a96bChristian MaedergetTokenList placeStr (Id ts cs ps) =

0c885f1348fd58f7cb706472a3ff20b52dbef0a7Jonathan von Schroeder let convert = map (\ t -> if isPlace t then t {tokStr = placeStr} else t)

fc1a590cd3ee36797c0a032ff41e07f8e2469341Christian Maeder in if null cs then convert ts else

66a774f13272fde036481edd2298081ab3d04678Razvan Pascanu let (toks, pls) = splitMixToken ts in

834c2e71b8e390e5b05c8d02bb6eb22621125133Markus Gross convert toks ++ getCompoundTokenList cs ps ++ convert pls

d27b1887e61f1dc53d77c37f59dbf5019242a686Christian Maeder

d27b1887e61f1dc53d77c37f59dbf5019242a686Christian Maeder-- | update token positions.

d27b1887e61f1dc53d77c37f59dbf5019242a686Christian Maeder-- return remaining positions

6e52f1dfc0da4bc4a7701cf856641c9dce08fc7dChristian MaedersetToksPos :: [Token] -> [Pos] -> ([Token], [Pos])

923e25bb8c7cf9f2978c7844ad173704482cc3b0Martin KühlsetToksPos (h:ts) (p:ps) =

9f85afecbd79b3df5a0bb17bd28cd0b288dc3213Kristina Sojakova let (rt, rp) = setToksPos ts ps

63da71bfb4226f504944b293fb77177ebcaea7d4Ewaryst Schulz in (h {tokPos = p} : rt, rp)

e1ea9a046e9640148ca876dfe47e391559a9fdf3Christian MaedersetToksPos ts ps = (ts, ps)

14c89b2d830777bf4db2850f038c9f60acaca486Christian Maeder

57026bc09337d158b89775048a9bcc9c17d825caChristian Maeder-- | update positions in 'Id'.

57026bc09337d158b89775048a9bcc9c17d825caChristian Maeder-- return remaining positions

57026bc09337d158b89775048a9bcc9c17d825caChristian MaedersetPlainIdePos :: Id -> [Pos] -> (Id, [Pos])

9175e29c044318498a40f323f189f9dfd50378efChristian MaedersetPlainIdePos (Id ts cs _) ps =

e1ea9a046e9640148ca876dfe47e391559a9fdf3Christian Maeder if null cs then

923e25bb8c7cf9f2978c7844ad173704482cc3b0Martin Kühl let (newTs, restPs) = setToksPos ts ps

f66fcd981f556c238df7dd6dfa42123745e3b1d2Christian Maeder in (Id newTs cs [], restPs)

2b873214c9ab511bbca437c036371ab664aedaceChristian Maeder else let (toks, pls) = splitMixToken ts

52d922076b89f12234f721974e82531bc69a6f69Christian Maeder ttail l = if null l then l else tail l

fe495a0978e5aa70776103c37fb0eb2bd6abea69Eugen Kuksa (front, ps2) = setToksPos toks ps

d27b1887e61f1dc53d77c37f59dbf5019242a686Christian Maeder (newCs, ps3, ps4) = foldl ( \ (prevCs, seps, restPs) a ->

d27b1887e61f1dc53d77c37f59dbf5019242a686Christian Maeder let (c1, qs) = setPlainIdePos a restPs

d27b1887e61f1dc53d77c37f59dbf5019242a686Christian Maeder in (c1: prevCs, head qs : seps, ttail qs))

52d922076b89f12234f721974e82531bc69a6f69Christian Maeder ([], [head ps2], ttail ps2) cs

8ef91a173e69219fc2ebd45c76a35891c7785abdMarkus Gross (newPls, ps7) = setToksPos pls ps4

8ef91a173e69219fc2ebd45c76a35891c7785abdMarkus Gross in (Id (front ++ newPls) (reverse newCs) (reverse ps3), ps7)

9175e29c044318498a40f323f189f9dfd50378efChristian Maeder

31bc219bae758272d0f064281b8ce7740a4553e9Till Mossakowski-- | a special index type for more type safety

31bc219bae758272d0f064281b8ce7740a4553e9Till Mossakowskinewtype Index = Index Int deriving (Eq, Ord, Show)

31bc219bae758272d0f064281b8ce7740a4553e9Till Mossakowski

31bc219bae758272d0f064281b8ce7740a4553e9Till Mossakowski-- deriving Num is also possible

a31430de8b0632d29f42634d6395e982bf31b14dChristian Maeder-- but the following functions are sufficient

a31430de8b0632d29f42634d6395e982bf31b14dChristian Maeder-- | the initial index

a31430de8b0632d29f42634d6395e982bf31b14dChristian MaederstartIndex :: Index

a31430de8b0632d29f42634d6395e982bf31b14dChristian MaederstartIndex = Index 0

a31430de8b0632d29f42634d6395e982bf31b14dChristian Maeder

a31430de8b0632d29f42634d6395e982bf31b14dChristian MaederincrIndex :: Index -> Index

a31430de8b0632d29f42634d6395e982bf31b14dChristian MaederincrIndex (Index i) = Index (i + 1)

a31430de8b0632d29f42634d6395e982bf31b14dChristian Maeder

a31430de8b0632d29f42634d6395e982bf31b14dChristian Maederdata Item a b = Item

a31430de8b0632d29f42634d6395e982bf31b14dChristian Maeder { rule :: Id -- the rule to match

a31430de8b0632d29f42634d6395e982bf31b14dChristian Maeder , info :: b -- additional info for 'rule'

a31430de8b0632d29f42634d6395e982bf31b14dChristian Maeder , posList :: [Pos] -- positions of Id tokens

9175e29c044318498a40f323f189f9dfd50378efChristian Maeder , args :: [a] -- currently collected arguments

9175e29c044318498a40f323f189f9dfd50378efChristian Maeder -- both in reverse order

9175e29c044318498a40f323f189f9dfd50378efChristian Maeder , ambigArgs :: [[a]] -- field for ambiguities

9175e29c044318498a40f323f189f9dfd50378efChristian Maeder , ambigs :: [[a]] -- field for ambiguities

9175e29c044318498a40f323f189f9dfd50378efChristian Maeder , rest :: [Token] -- part of the rule after the "dot"

9175e29c044318498a40f323f189f9dfd50378efChristian Maeder , index :: Index -- index into the Table/input string

ee1c7c5796832536932d7b06cbfb1ca13f9a0d7bMartin Kühl }

f63e7684d8db7503c22e5d8d499c94a9405f8f9eChristian Maeder

91eeff7b19b22d7e5c5d83fa6e357496e291c718Christian Maederinstance Show (Item a b) where

a3a7d8b3cdf05c8040c62dbcf9a15dc5042cd721Christian Maeder showsPrec _ p =

f63e7684d8db7503c22e5d8d499c94a9405f8f9eChristian Maeder let d = rest p

a3a7d8b3cdf05c8040c62dbcf9a15dc5042cd721Christian Maeder v = getPlainTokenList (rule p)

c0c2380bced8159ff0297ece14eba948bd236471Christian Maeder first = take (length v - length d) v

bdc103981a28a51938de98a956d8a3767f6cf43dAivaras Jakubauskas showToks = showSepList id showTok

c0c2380bced8159ff0297ece14eba948bd236471Christian Maeder Index i = index p

e1ea9a046e9640148ca876dfe47e391559a9fdf3Christian Maeder in showChar '['. showToks first

e1ea9a046e9640148ca876dfe47e391559a9fdf3Christian Maeder . showChar '.'

57026bc09337d158b89775048a9bcc9c17d825caChristian Maeder . showToks d

57026bc09337d158b89775048a9bcc9c17d825caChristian Maeder . showString ", "

22b772f8753f0cdb4508ba460356c238de2ee375Jonathan von Schroeder . shows i . showChar ']'

7bbfb15142ab4286dfc6fcde2fc94a5512297e41Jonathan von Schroeder

fa388aea9cef5f9734fec346159899a74432ce26Christian Maeder-- | the non-terminal

63719301448519453f66383f4e583d9fd5b89ecbChristian MaedertermStr :: String

a3a7d8b3cdf05c8040c62dbcf9a15dc5042cd721Christian MaedertermStr = "(__)"

0c885f1348fd58f7cb706472a3ff20b52dbef0a7Jonathan von Schroeder-- | builtin terminals

52d922076b89f12234f721974e82531bc69a6f69Christian MaedercommaTok, termTok, oParenTok, cParenTok, placeTok :: Token

52d922076b89f12234f721974e82531bc69a6f69Christian MaedercommaTok = mkSimpleId "," -- for list elements

923e25bb8c7cf9f2978c7844ad173704482cc3b0Martin KühltermTok = mkSimpleId termStr

9f85afecbd79b3df5a0bb17bd28cd0b288dc3213Kristina SojakovaplaceTok = mkSimpleId place

72079df98b3cb7cc1fd82a0a24984893dcd05ecaEwaryst SchulzoParenTok = mkSimpleId "("

a3a7d8b3cdf05c8040c62dbcf9a15dc5042cd721Christian MaedercParenTok = mkSimpleId ")"

fbc4f8708092d571a45cb483f37cc6b674da45a7Christian MaederlistTok :: Token

8a77240a809197c92c0736c431b4b88947a7bac1Christian MaederlistTok = mkSimpleId "[]" -- impossible token

8a77240a809197c92c0736c431b4b88947a7bac1Christian MaederprotectTok :: Token

1c4dfa148603d4fcf4cdd2ed66c8b6e1de0dd696Till MossakowskiprotectTok = mkSimpleId "()" -- impossible token

bb63f684c4f5f33ffcd1dcc02c58d6a703900fafJonathan von Schroeder

b0234f0a84fcd3587073fbc11d38759108997c3cChristian Maeder-- | token for type annotations

b0234f0a84fcd3587073fbc11d38759108997c3cChristian MaedertypeTok :: Token

8ef91a173e69219fc2ebd45c76a35891c7785abdMarkus GrosstypeTok = mkSimpleId ":"

8ef91a173e69219fc2ebd45c76a35891c7785abdMarkus Gross

d56ece59c372cb887355825901222b9f3377f7e6Thiemo Wiedemeyer-- | token for a fixed (or recursively resolved) operator expression

d56ece59c372cb887355825901222b9f3377f7e6Thiemo WiedemeyerexprTok :: Token

9175e29c044318498a40f323f189f9dfd50378efChristian MaederexprTok = mkSimpleId "(op )"

9175e29c044318498a40f323f189f9dfd50378efChristian Maeder-- | token for a fixed (or recursively resolved) argument expression

9175e29c044318498a40f323f189f9dfd50378efChristian MaedervarTok :: Token

f1dec6898638ba1131a9fadbc4d1544c93dfabb0Klaus LuettichvarTok = mkSimpleId "(var )"

9175e29c044318498a40f323f189f9dfd50378efChristian Maeder-- | token for an unknown variable (within patterns)

f77f29e84b3f6e791c82e61b13fbf76582bedd2fChristian MaederunknownTok :: Token

unknownTok = mkSimpleId "(?)"

-- | construct an 'Id' from a token list

mkId :: [Token] -> Id

mkId toks = Id toks [] []

-- | the invisible application rule with two places

applId :: Id

applId = mkId [placeTok, placeTok]

-- | parenthesis around one place

parenId :: Id

parenId = mkId [oParenTok, placeTok, cParenTok]

-- | id for tuples with at least two arguments

tupleId :: Id

tupleId = mkId [oParenTok, placeTok, commaTok, placeTok, cParenTok]

-- | id for the emtpy tuple

unitId :: Id

unitId = mkId [oParenTok, cParenTok]

-- | see 'typeTok'

typeId :: Id

typeId = mkId [placeTok, typeTok]

-- | see 'exprTok'

exprId :: Id

exprId = mkId [exprTok]

-- | see 'varTok'

varId :: Id

varId = mkId [varTok]

-- | see 'unknownTok'

unknownId :: Id

unknownId = mkId [unknownTok]

listId :: (Id, Id) -> Id

listId (f,c) = Id [listTok] [f,c] []

isListId :: Id -> Bool

isListId (Id ts cs _) = not (null ts) && head ts == listTok

&& assert (length cs == 2) True

-- | interpret placeholders as literal places

protect :: Id -> Id

protect i = Id [protectTok] [i] []

unProtect :: Id -> Id

unProtect (Id _ [i] _) = i

unProtect _ = error "unProtect"

isProtected :: Id -> Bool

isProtected (Id ts cs _) = not (null ts) && head ts == protectTok

&& isSingle cs

-- | test if an 'unknownId' was matched

isUnknownId :: Id -> Bool

isUnknownId (Id ts _ _) = not (null ts) && head ts == unknownTok

-- | get unknown token from an 'unknownId'

unToken :: Id -> Token

unToken (Id [_,t] _ _) = t

unToken _ = error "unToken"

mkItem :: Index -> (Id, b, [Token]) -> Item a b

mkItem ind (ide, inf, toks) =

Item { rule = ide

, info = inf

, posList = []

, args = []

, ambigArgs = []

, ambigs = []

, rest = toks

, index = ind }

-- | extract tokens with the non-terminal for places

getTokenPlaceList :: Id -> [Token]

getTokenPlaceList = getTokenList termStr

-- | construct a rule for a mixfix

mixRule :: b -> Id -> (Id, b, [Token])

mixRule b i = (i, b, getTokenPlaceList i)

asListAppl :: ToExpr a b -> Id -> b -> [a] -> [Pos] -> a

asListAppl toExpr i b ra br =

if isListId i then

let Id _ [f, c] _ = i

mkList [] ps = toExpr c b [] ps

mkList (hd:tl) ps = toExpr f b [hd, mkList tl ps] ps

in mkList ra br

else if i == typeId

|| i == exprId

|| i == parenId

|| i == varId

then assert (isSingle ra) $ head ra

else toExpr (if isProtected i then unProtect i else i) b ra br

-- | construct the list rules

listRules :: b -> GlobalAnnos -> [(Id, b, [Token])]

listRules inf g =

let lists = list_lit $ literal_annos g

listRule co toks = (listId co, inf, toks)

in concatMap ( \ (bs, n, c) ->

let (b1, b2, cs) = getListBrackets bs

e = Id (b1 ++ b2) cs [] in

(if e == n then [] -- add b1 ++ b2 if its not yet included by n

else [listRule (c, n) $ getPlainTokenList e])

++ [listRule (c, n) (b1 ++ [termTok] ++ b2),

listRule (c, n) (b1 ++ [termTok, commaTok, termTok] ++ b2)]

) $ Set.toList lists

type Table a b = Map.Map Index [Item a b]

lookUp :: Table a b -> Index -> [Item a b]

lookUp ce k = Map.findWithDefault [] k ce

-- | a set of strings that do not match a 'unknownTok'

type Knowns = Set.Set String

-- | recognize next token (possible introduce new tuple variable)

scanItem :: (a -> a -> a) -> Knowns -> (a, Token) -> Item a b

-> [Item a b]

scanItem addType ks (trm, t) p =

let ts = rest p

as = args p

ide = rule p

q = p { posList = tokPos t : posList p }

in if null ts then [] else

let tt = tail ts

r = q { rest = tt }

in

if head ts == t then

if t == commaTok then

assert (not $ null tt) $

if head tt == termTok then

-- tuple or list elements separator

[ r, q { rest = termTok : ts } ]

else [r]

else if t == exprTok || t == varTok then

[r { args = trm : args p }]

else if t == typeTok then

assert (null tt && isSingle as) $

[q { rest = [], args = [addType trm $ head as] }]

else [r]

else if Set.isEmpty ks then []

else if isUnknownId ide

&& not (tokStr t `Set.member` ks) then

[r { rule = mkId [unknownTok, t]}]

else []

scan :: (a -> a -> a) -> Knowns -> (a, Token) -> [Item a b]

-> [Item a b]

scan f ks term = concatMap (scanItem f ks term)

mkAmbigs :: ToExpr a b -> Item a b -> [a]

mkAmbigs toExpr p =

let l = args p in

map ( \ as -> fst $

mkExpr toExpr

p { args = take (length l - length as) l ++ as

} ) $ ambigArgs p

addArg :: ToExpr a b -> Item a b -> Item a b -> Item a b

addArg toExpr argItem p =

let (arg, q) = mkExpr toExpr argItem

ams = ambigs argItem

newAms = mkAmbigs toExpr argItem

in assert (not $ null $ rest p) $

p { rest = tail $ rest p

, posList = q : posList p

, args = arg : args p

, ambigs = (if null newAms then ams else newAms : ams)

++ ambigs p }

-- | shortcut for a function that constructs an expression

type ToExpr a b = Id -> b -> [a] -> [Pos] -> a

mkExpr :: ToExpr a b -> Item a b -> (a, Pos)

mkExpr toExpr item =

let orig = rule item

ps = posList item

rs = reverse ps

(ide, qs) = if isListId orig then (orig, rs) else

setPlainIdePos orig rs

inf = info item

as = reverse $ args item

in (asListAppl toExpr ide inf as qs,

if null ps then nullPos else head ps)

reduce :: GlobalAnnos -> Table a b -> (b -> b -> Maybe Bool)

-> ToExpr a b -> Item a b -> [Item a b]

reduce ga table filt toExpr item =

let ide = rule item

inf = info item

in map (addArg toExpr item)

$ filter ( \ oi -> let ts = rest oi in

if null ts then False

else if head ts == termTok

then case filt inf $ info oi of

Nothing -> checkPrecs ga ide (rule oi)

$ length $ args oi

Just b -> b

else False )

$ lookUp table $ index item

reduceCompleted :: GlobalAnnos -> Table a b -> (b -> b -> Maybe Bool)

-> ToExpr a b -> [Item a b] -> [Item a b]

reduceCompleted ga table filt toExpr =

concatMap (reduce ga table filt toExpr) . filter (null . rest)

recReduce :: GlobalAnnos -> Table a b -> (b -> b -> Maybe Bool)

-> ToExpr a b -> [Item a b] -> [Item a b]

recReduce ga table filt toExpr items =

let reduced = reduceCompleted ga table filt toExpr items

in if null reduced then items

else recReduce ga table filt toExpr reduced ++ items

complete :: (b -> b -> Maybe Bool) -> ToExpr a b -> GlobalAnnos

-> Table a b -> [Item a b] -> [Item a b]

complete filt toExpr ga table items =

let reducedItems = recReduce ga table filt toExpr $

reduceCompleted ga table filt toExpr items

in reducedItems

++ items

predict :: [Item a b] -> [Item a b] -> [Item a b]

predict rs items =

if any ( \ p -> let ts = rest p in

not (null ts) && head ts == termTok) items

then rs ++ items

else items

equivItem :: Item a b -> Item a b -> Bool

equivItem i1 i2 = (index i1, rest i1, rule i1)

== (index i2, rest i2, rule i2)

ordItem :: Item a b -> Item a b -> Ordering

ordItem i1 i2 =

compare (index i1, rest i1, rule i1)

(index i2, rest i2, rule i2)

flatItems :: [Item a b] -> Item a b

flatItems (i:is) =

if null is

then i

else i { ambigArgs = map args (i:is) }

flatItems [] = error "flatItems: empty list"

packAmbigs :: [Item a b] -> [Item a b]

packAmbigs = map flatItems . groupBy equivItem

-- | the whole state for mixfix resolution

data Chart a b = Chart { prevTable :: Table a b

, currIndex :: Index

, currItems :: [Item a b]

, rules :: [(Id, b, [Token])]

, knowns :: Knowns

, solveDiags :: [Diagnosis] }

deriving Show

-- | make one scan, complete, and predict step.

-- The first function adds a type to the result.

-- The second function filters based on argument and operator info.

-- If filtering yields 'Nothing' further filtering by precedence is applied.

nextChart :: (a -> a -> a) -> (b -> b -> Maybe Bool) -> ToExpr a b

-> GlobalAnnos -> Chart a b -> (a, Token) -> Chart a b

nextChart addType filt toExpr ga st term@(_, tok) =

let table = prevTable st

idx = currIndex st

items = currItems st

scannedItems = scan addType (knowns st) term items

nextTable = Map.insert idx items table

nextIdx = incrIndex idx

in if null items then st else

st { prevTable = nextTable

, currIndex = nextIdx

, currItems = predict (map (mkItem nextIdx) $ rules st)

$ packAmbigs

$ sortBy ordItem

$ complete filt toExpr ga nextTable scannedItems

, solveDiags = (if null scannedItems then

[Diag Error ("unexpected mixfix token: " ++ tokStr tok)

$ tokPos tok]

else []) ++ solveDiags st }

-- | add intermediate diagnostic messages

mixDiags :: [Diagnosis] -> Chart a b -> Chart a b

mixDiags ds st = st { solveDiags = ds ++ solveDiags st }

-- | create the initial chart

initChart :: [(Id, b, [Token])] -> Knowns -> Chart a b

initChart ruleS knownS= Chart { prevTable = Map.empty

, currIndex = startIndex

, currItems = map (mkItem startIndex) ruleS

, rules = ruleS

, knowns = knownS

, solveDiags = [] }

-- | extract resolved result

getResolved :: (a -> ShowS) -> Pos -> ToExpr a b -> Chart a b

-> Result a

getResolved pp p toExpr st =

let items = filter ((currIndex st/=) . index) $ currItems st

ds = solveDiags st

in if null items

then Result ds Nothing

else let (finals, rest1) = partition ((startIndex==) . index) items

(result, rest2) = partition (null . rest) finals

in if null result then

let expected = if null rest2

then filter (not . null . rest) rest1

else rest2

withpos = assert (not $ null expected) $

filter (not . null . posList) expected

(pos, errs) = if null withpos then (p, expected)

else (last $ sort $ map

(head . posList) withpos

, withpos)

q = if pos == nullPos then p else pos

in Result (Diag Error

("expected further mixfix token: "

++ show (take 5 $ nub

$ map (tokStr . head . rest)

errs)) q : ds) Nothing

else if null $ tail result then

let har = head result

ams = ambigs har

ambAs = mkAmbigs toExpr har

res = Just $ fst $ mkExpr toExpr har

in

if null ams then

if null ambAs then

Result ds res

else Result ((showAmbigs pp p $

take 5 ambAs) : ds) res

else Result ((map (showAmbigs pp p) $

take 5 ams) ++ ds) res

else Result ((showAmbigs pp p $

map (fst . mkExpr toExpr) result) : ds) Nothing

showAmbigs :: (a -> ShowS) -> Pos -> [a] -> Diagnosis

showAmbigs pp p as =

Diag Error ("ambiguous mixfix term\n\t" ++

showSepList (showString "\n\t") pp

(take 5 as) "") p