4751N/ACopyright : Christian Maeder and Uni Bremen 2003
4751N/A -- * special tokens for special ids
4751N/A , applId, parenId, typeId, exprId, varId
4751N/A , tupleId, unitId, unknownId, isUnknownId, unToken
4751N/A , Knowns, protect, listRules, mixRule
4751N/A , initChart, nextChart, getResolved)
4751N/A-- | reconstruct the token list of an 'Id'.
4751N/A-- Replace top-level places with the input String
4751N/AgetTokenList :: String -> Id -> [Token]
4751N/AgetTokenList placeStr (Id ts cs ps) =
4751N/A let convert = map (\ t -> if isPlace t then t {tokStr = placeStr} else t)
4751N/A in if null cs then convert ts else
4751N/A let (toks, pls) = splitMixToken ts in
4751N/A convert toks ++ getCompoundTokenList cs ps ++ convert pls
4751N/A-- | update token positions.
4751N/A-- return remaining positions
4751N/AsetToksPos :: [Token] -> [Pos] -> ([Token], [Pos])
4751N/A let (rt, rp) = setToksPos ts ps
4751N/A in (h {tokPos = [p]} : rt, rp)
4751N/A-- | update positions in 'Id'.
4751N/A-- return remaining positions
4751N/AsetPlainIdePos :: Id -> [Pos] -> (Id, [Pos])
4751N/AsetPlainIdePos (Id ts cs _) ps =
4751N/A let (newTs, restPs) = setToksPos ts ps
4751N/A in (Id newTs cs [], restPs)
4751N/A else let (toks, pls) = splitMixToken ts
4751N/A (front, ps2) = setToksPos toks ps
4751N/A (newCs, ps3, ps4) = if null ps2 then error "setPlainIdePos2"
4751N/A else foldl ( \ (prevCs, seps, restPs) a ->
4751N/A let (c1, qs) = setPlainIdePos a restPs
4751N/A in if null qs then error "setPlainIdePos1"
4751N/A else (c1: prevCs, head qs : seps, tail qs))
4751N/A ([], [head ps2], tail ps2) cs
4751N/A (newPls, ps7) = setToksPos pls ps4
4751N/A in (Id (front ++ newPls) (reverse newCs) (reverse ps3), ps7)
4751N/A-- | a special index type for more type safety
4751N/Anewtype Index = Index Int deriving (Eq, Ord, Show)
4751N/A-- deriving Num is also possible
4751N/A-- but the following functions are sufficient
4751N/AincrIndex (Index i) = Index (i + 1)
4751N/A { rule :: Id -- the rule to match
4751N/A , info :: Int -- additional precedence info for 'rule'
4751N/A , lWeight :: Id -- weights for lower precedence pre- and postfixes
4751N/A , rWeight :: Id -- given by the 'Id's itself
4751N/A , posList :: [Pos] -- positions of Id tokens
4751N/A , args :: [a] -- currently collected arguments
4751N/A , ambigArgs :: [[a]] -- field for ambiguities
4751N/A , ambigs :: [[a]] -- field for ambiguities
4751N/A , rest :: [Token] -- part of the rule after the "dot"
4751N/Ainstance Show (Item a) where
4751N/A v = getPlainTokenList (rule p)
4751N/A first = take (length v - length d) v
4751N/A showToks = showSepList id showTok
4751N/A in showChar '['. showToks first
4751N/AcommaTok, termTok, oParenTok, cParenTok, placeTok :: Token
4751N/AcommaTok = mkSimpleId "," -- for list elements
4751N/AtermTok = mkSimpleId termStr
4751N/AlistTok = mkSimpleId "[]" -- impossible token
4751N/AprotectTok = mkSimpleId "()" -- impossible token
4751N/A-- | token for type annotations
4751N/A-- | token for a fixed (or recursively resolved) operator expression
4751N/AexprTok = mkSimpleId "(op )"
4751N/A-- | token for a fixed (or recursively resolved) argument expression
4751N/AvarTok = mkSimpleId "(var )"
4751N/A-- | token for an unknown variable (within patterns)
4751N/AunknownTok = mkSimpleId "(?)"
4751N/A-- | the invisible application rule with two places
4751N/AapplId = mkId [placeTok, placeTok]
4751N/A-- | parenthesis around one place
4751N/AparenId = mkId [oParenTok, placeTok, cParenTok]
4751N/A-- | id for tuples with at least two arguments
4751N/AtupleId = mkId [oParenTok, placeTok, commaTok, placeTok, cParenTok]
4751N/AunitId = mkId [oParenTok, cParenTok]
4751N/AtypeId = mkId [placeTok, typeTok]
4751N/AunknownId = mkId [unknownTok]
4751N/AlistId (f,c) = Id [listTok] [f,c] []
4751N/AisListId (Id ts cs _) = not (null ts) && head ts == listTok
4751N/A && assert (length cs == 2) True
4751N/A-- | interpret placeholders as literal places
4751N/Aprotect i = Id [protectTok] [i] []
4751N/AunProtect _ = error "unProtect"
4751N/AisProtected (Id ts cs _) = not (null ts) && head ts == protectTok
4751N/A-- | test if an 'unknownId' was matched
4751N/AisUnknownId (Id ts _ _) = not (null ts) && head ts == unknownTok
4751N/A-- | get unknown token from an 'unknownId'
4751N/Atype Rule = (Id, Int, [Token])
4751N/AmkItem :: Index -> Rule -> Item a
4751N/AmkItem ind (ide, inf, toks) =
4751N/A-- | extract tokens with the non-terminal for places
4751N/AgetTokenPlaceList :: Id -> [Token]
4751N/AgetTokenPlaceList = getTokenList termStr
4751N/A-- | construct a rule for a mixfix
4751N/AmixRule :: Int -> Id -> Rule
4751N/AmixRule b i = (i, b, getTokenPlaceList i)
4751N/AasListAppl :: ToExpr a -> Id -> [a] -> [Pos] -> a
4751N/A mkList [] ps = toExpr c [] ps
4751N/A mkList (hd:tl) ps = toExpr f [hd, mkList tl ps] ps
4751N/A then assert (isSingle ra) $ head ra
4751N/A-- | construct the list rules
4751N/AlistRules :: Int -> GlobalAnnos -> [Rule]
4751N/A let lists = list_lit $ literal_annos g
4751N/A listRule co toks = (listId co, inf, toks)
4751N/A in concatMap ( \ (bs, (n, c)) ->
4751N/A let (b1, b2, cs) = getListBrackets bs
4751N/A (if e == n then [] -- add b1 ++ b2 if its not yet included by n
4751N/A else [listRule (c, n) $ getPlainTokenList e])
4751N/A ++ [listRule (c, n) (b1 ++ [termTok] ++ b2),
4751N/A listRule (c, n) (b1 ++ [termTok, commaTok, termTok] ++ b2)]
4751N/AlookUp :: Table a -> Index -> [Item a]
4751N/A-- | a set of strings that do not match a 'unknownTok'
4751N/A-- | recognize next token (possible introduce new tuple variable)
4751N/AscanItem :: (a -> a -> a) -> Knowns -> (a, Token) -> Item a -> [Item a]
4751N/AscanItem addType ks (trm, t) p =
4751N/A q = p { posList = tokPos t ++ posList p }
4751N/A -- tuple or list elements separator
4751N/A [ r, q { rest = termTok : ts } ]
4751N/A else if t == exprTok || t == varTok then
4751N/A [r { args = trm : args p }]
4751N/A assert (null tt && isSingle as) $
4751N/A [q { rest = [], args = [addType trm $ head as] }]
4751N/A [r { rule = mkId [unknownTok, t]}]
4751N/Ascan :: (a -> a -> a) -> Knowns -> (a, Token) -> [Item a] -> [Item a]
4751N/Ascan f ks term = concatMap (scanItem f ks term)
4751N/AmkAmbigs :: ToExpr a -> Item a -> [a]
4751N/A p { args = take (length l - length as) l ++ as
4751N/AaddArg :: GlobalAnnos -> ToExpr a -> Item a -> Item a -> Item a
4751N/AaddArg ga toExpr argItem p =
4751N/A let (arg, q) = mkExpr toExpr argItem
4751N/A newAms = mkAmbigs toExpr argItem
4751N/A in assert (not $ null $ rest p) $
4751N/A , lWeight = getLWeight ga argItem p
4751N/A , rWeight = getRWeight ga argItem p
4751N/A , ambigs = (if null newAms then ams else newAms : ams)
4751N/AgetLWeight :: GlobalAnnos -> Item a -> Item a -> Id
4751N/AgetLWeight ga argItem opItem =
4751N/A num = length $ args opItem in
4751N/A case precRel (prec_annos ga) op arg of
4751N/AgetRWeight :: GlobalAnnos -> Item a -> Item a -> Id
4751N/AgetRWeight ga argItem opItem =
4751N/A num = length $ args opItem in
4751N/A case precRel (prec_annos ga) op arg of
4751N/A-- | shortcut for a function that constructs an expression
4751N/Atype ToExpr a = Id -> [a] -> [Pos] -> a
4751N/AmkExpr :: ToExpr a -> Item a -> (a, [Pos])
4751N/A (ide, qs) = if isListId orig then (orig, rs) else
4751N/A setPlainIdePos (unProtect orig) rs
4751N/A else setPlainIdePos orig rs
4751N/A in (asListAppl toExpr ide as qs, rs)
4751N/Atype Filt = Int -> Int -> Maybe Bool
4751N/Areduce :: GlobalAnnos -> Table a -> Filt -> ToExpr a -> Item a -> [Item a]
4751N/Areduce ga table filt toExpr itm =
4751N/A $ filter ( \ oi -> let ts = rest oi in
4751N/A then checkPrecs filt ga itm oi
4751N/A-- | 'Id' starts with a 'place'
4751N/AbegPlace (Id toks _ _) = not (null toks) && isPlace (head toks)
4751N/A-- | 'Id' ends with a 'place'
4751N/AendPlace (Id toks _ _) = not (null toks) && isPlace (last toks)
4751N/A-- | check if a left argument will be added.
4751N/A-- (The 'Int' is the number of current arguments.)
4751N/AisLeftArg :: Id -> Int -> Bool
4751N/AisLeftArg op num = begPlace op && num == 0
4751N/A-- | check if a right argument will be added.
4751N/AisRightArg :: Id -> Int -> Bool
4751N/AisRightArg op num = endPlace op && num + 1 == placeCount op
4751N/A-- | check precedences of an argument and a top-level operator.
4751N/A-- (The 'Int' is the number of current arguments of the operator.)
4751N/AcheckPrecs :: Filt -> GlobalAnnos -> Item a -> Item a -> Bool
4751N/AcheckPrecs filt ga argItem opItem =
4751N/A num = length $ args opItem in
4751N/A case filt argPrec opPrec of
4751N/A let rarg = rWeight argItem in
4751N/A case precRel precs op rarg of
4751N/A case (begPlace arg, endPlace op) of
4751N/A (True, True) -> if arg == op
4751N/A then not $ isAssoc ARight assocs op
4751N/A else if isRightArg op num then
4751N/A case filt argPrec opPrec of
4751N/A Nothing -> let larg = lWeight argItem in
4751N/A case precRel precs op larg of
4751N/A case (begPlace op, endPlace arg) of
4751N/A (True, True) -> if arg == op
4751N/A then not $ isAssoc ALeft assocs op
4751N/AreduceCompleted :: GlobalAnnos -> Table a -> Filt -> ToExpr a
4751N/AreduceCompleted ga table filt toExpr =
4751N/A foldr mergeItems [] . map (reduce ga table filt toExpr) .
4751N/ArecReduce :: GlobalAnnos -> Table a -> Filt -> ToExpr a -> [Item a] -> [Item a]
4751N/ArecReduce ga table filt toExpr items =
4751N/A let reduced = reduceCompleted ga table filt toExpr items
4751N/A in if null reduced then items
4751N/A else recReduce ga table filt toExpr reduced `mergeItems` items
4751N/Acomplete :: Filt -> ToExpr a -> GlobalAnnos -> Table a -> [Item a] -> [Item a]
4751N/Acomplete filt toExpr ga table items =
4751N/A let reducedItems = recReduce ga table filt toExpr $
4751N/A reduceCompleted ga table filt toExpr items
4751N/Apredict :: [Item a] -> [Item a] -> [Item a]
4751N/A if any ( \ p -> let ts = rest p in
4751N/A not (null ts) && head ts == termTok) items
4751N/AordItem :: Item a -> Item a -> Ordering
4751N/A compare (index i1, rest i1, rule i1)
4751N/A (index i2, rest i2, rule i2)
4751N/AambigItems :: Item a -> Item a -> Item a
4751N/AambigItems i1 i2 = let as = ambigArgs i1 ++ ambigArgs i2 in
4751N/A i1 { ambigArgs = if null as then
4751N/A [args i1, args i2] else as }
4751N/AmergeItems :: [Item a] -> [Item a] -> [Item a]
4751N/AmergeItems (i1:r1) (i2:r2) =
4751N/A LT -> i1 : mergeItems r1 (i2:r2)
4751N/A EQ -> ambigItems i1 i2 : mergeItems r1 r2
4751N/A GT -> i2 : mergeItems (i1:r1) r2
4751N/A-- | the whole state for mixfix resolution
4751N/Adata Chart a = Chart { prevTable :: Table a
4751N/A , solveDiags :: [Diagnosis] }
4751N/A-- | make one scan, complete, and predict step.
4751N/A-- The first function adds a type to the result.
4751N/A-- The second function filters based on argument and operator info.
4751N/A-- If filtering yields 'Nothing' further filtering by precedence is applied.
4751N/AnextChart :: (a -> a -> a) -> Filt -> ToExpr a
4751N/A -> GlobalAnnos -> Chart a -> (a, Token) -> Chart a
4751N/AnextChart addType filt toExpr ga st term@(_, tok) =
4751N/A scannedItems = scan addType (knowns st) term items
4751N/A in if null items then st else
4751N/A , currItems = predict (map (mkItem nextIdx) rs)
4751N/A $ complete filt toExpr ga nextTable
4751N/A $ sortBy ordItem scannedItems
4751N/A , solveDiags = (if null scannedItems then
4751N/A [Diag Error ("unexpected mixfix token: " ++ tokStr tok)
4751N/A else []) ++ solveDiags st }
4751N/A-- | add intermediate diagnostic messages
4751N/AmixDiags :: [Diagnosis] -> Chart a -> Chart a
4751N/AmixDiags ds st = st { solveDiags = ds ++ solveDiags st }
4751N/A-- | create the initial chart
4751N/AinitChart :: [Rule] -> Knowns -> Chart a
4751N/A , currItems = map (mkItem startIndex) ruleS
4751N/A-- | extract resolved result
4751N/AgetResolved :: (a -> ShowS) -> [Pos] -> ToExpr a -> Chart a -> Result a
4751N/AgetResolved pp p toExpr st =
4751N/A let items = filter ((currIndex st/=) . index) $ currItems st
4751N/A else let (finals, rest1) = partition ((startIndex==) . index) items
4751N/A (result, rest2) = partition (null . rest) finals
4751N/A let expected = if null rest2
4751N/A then filter (not . null . rest) rest1
4751N/A withpos = filter (not . null . posList) expected
4751N/A (q, errs) = if null withpos then (p, expected)
4751N/A ("expected further mixfix token: "
4751N/A $ map (tokStr . head . rest)
4751N/A else if null $ tail result then
4751N/A ambAs = mkAmbigs toExpr har
4751N/A res = Just $ fst $ mkExpr toExpr har
4751N/A else Result ((showAmbigs pp p $
4751N/A else Result ((map (showAmbigs pp p) $
4751N/A else Result ((showAmbigs pp p $
4751N/A map (fst . mkExpr toExpr) result) : ds) Nothing
4751N/AshowAmbigs :: (a -> ShowS) -> [Pos] -> [a] -> Diagnosis
4751N/A Diag Error ("ambiguous mixfix term\n " ++
4751N/A showSepList (showString "\n ") pp