5784N/ACopyright : Christian Maeder and Uni Bremen 2003-2005
5784N/A -- * special tokens for special ids
5784N/A , varTok, exprTok, typeTok, placeTok
5784N/A , applId, parenId, typeId, exprId, varId
5784N/A , protect, listRules, mixRule
5784N/A , Chart, mixDiags, ToExpr, rules, addRules
5784N/A , initChart, nextChart, getResolved
5784N/A , joinPlace, isLeftArg, isRightArg)
5784N/A-- | drop as many elements as are in the first list
5784N/AdropPrefix :: [a] -> [b] -> [b]
5784N/AdropPrefix (_ : xs) (_ : ys) = dropPrefix xs ys
5784N/A-- | take the difference of the two input lists take (length l2 - length l1) l2
5784N/AtakeDiff :: [a] -> [b] -> [b]
5784N/AtakeDiff l1 l2 = zipWith const l2 $ dropPrefix l1 l2
5784N/A-- | reconstruct the token list of an 'Id'.
5784N/A-- Replace top-level places with the input String
5784N/AgetTokenList :: String -> Id -> [Token]
5784N/AgetTokenList placeStr (Id ts cs ps) =
5784N/A let convert = map (\ t -> if isPlace t then t {tokStr = placeStr} else t)
5784N/A in if null cs then convert ts else
5784N/A let (toks, pls) = splitMixToken ts in
5784N/A convert toks ++ getCompoundTokenList cs ps ++ convert pls
5784N/A-- | update token positions.
5784N/A-- return remaining positions
5784N/AsetToksPos :: [Token] -> Range -> ([Token], Range)
5784N/AsetToksPos (h:ts) (Range (p:ps)) =
5784N/A let (rt, rp) = setToksPos ts (Range ps)
5784N/A in (h {tokPos = Range [p]} : rt, rp)
5784N/A-- | update positions in 'Id'.
5784N/A-- return remaining positions
5784N/AsetPlainIdePos :: Id -> Range -> (Id, Range)
5784N/AsetPlainIdePos (Id ts cs _) ps =
5784N/A let (newTs, restPs) = setToksPos ts ps
5784N/A in (Id newTs cs nullRange, restPs)
5784N/A else let (toks, pls) = splitMixToken ts
5784N/A (front, ps2) = setToksPos toks ps
5784N/A if isNullRange ps2 then error "setPlainIdePos2"
5784N/A else foldl ( \ (prevCs, seps, restPs) a ->
5784N/A let (c1, qs) = setPlainIdePos a restPs
5784N/A in if isNullRange qs then error "setPlainIdePos1"
5784N/A Range (head qsPL : rangeToList seps),
5784N/A ([], Range [head ps2PL], Range (tail ps2PL)) cs
5784N/A (newPls, ps7) = setToksPos pls ps4
5784N/A in (Id (front ++ newPls) (reverse newCs) (reverseRange ps3), ps7)
5784N/A-- | a special index type for more type safety
5784N/Anewtype Index = Index Int deriving (Eq, Ord)
5784N/A-- deriving Num is also possible
5784N/A-- but the following functions are sufficient
5784N/AincrIndex (Index i) = Index (i + 1)
5784N/A { rule :: Id -- the rule to match
5784N/A , info :: Int -- additional precedence info for 'rule'
5784N/A , lWeight :: Id -- weights for lower precedence pre- and postfixes
5784N/A , rWeight :: Id -- given by the 'Id's itself
5784N/A , posList :: Range -- positions of Id tokens
5784N/A , args :: [a] -- currently collected arguments
5784N/A , ambigArgs :: [[a]] -- field for ambiguities
5784N/A , ambigs :: [[a]] -- field for ambiguities
5784N/A , rest :: [Token] -- part of the rule after the "dot"
5784N/AcommaTok, termTok, oParenTok, cParenTok, placeTok :: Token
5784N/AcommaTok = mkSimpleId "," -- for list elements
5784N/AtermTok = mkSimpleId termStr
5784N/AlistTok = mkSimpleId "[]" -- impossible token
5784N/AprotectTok = mkSimpleId "()" -- impossible token
5784N/A-- | token for type annotations
5784N/A-- | token for a fixed (or recursively resolved) operator expression
5784N/AexprTok = mkSimpleId "(op )"
5784N/A-- | token for a fixed (or recursively resolved) argument expression
5784N/AvarTok = mkSimpleId "(var )"
5784N/A-- | the invisible application rule with two places
5784N/AapplId = mkId [placeTok, placeTok]
5784N/A-- | parenthesis around one place
5784N/AparenId = mkId [oParenTok, placeTok, cParenTok]
5784N/A-- | id for tuples with at least two arguments
5784N/AtupleId = mkId [oParenTok, placeTok, commaTok, placeTok, cParenTok]
5784N/AunitId = mkId [oParenTok, cParenTok]
5784N/AtypeId = mkId [placeTok, typeTok]
5784N/AlistId (f,c) = Id [listTok] [f,c] nullRange
5784N/AisListId (Id ts _ _) = not (null ts) && head ts == listTok
5784N/A-- | interpret placeholders as literal places
5784N/Aprotect i = Id [protectTok] [i] nullRange
5784N/AunProtect _ = error "unProtect"
5784N/AisProtected (Id ts _ _) = not (null ts) && head ts == protectTok
5784N/Atype Rule = (Id, Int, [Token])
5784N/AmkItem :: Index -> Rule -> Item a
5784N/AmkItem ind (ide, inf, toks) =
5784N/A-- | extract tokens with the non-terminal for places
5784N/AgetTokenPlaceList :: Id -> [Token]
5784N/AgetTokenPlaceList = getTokenList termStr
5784N/A-- | construct a rule for a mixfix
5784N/AmixRule :: Int -> Id -> Rule
5784N/AmixRule b i = (i, b, getTokenPlaceList i)
5784N/AasListAppl :: ToExpr a -> Id -> [a] -> Range -> a
5784N/A mkList [] ps = toExpr c [] ps
5784N/A mkList (hd:tl) ps = toExpr f [hd, mkList tl ps] ps
5784N/A-- | construct the list rules
5784N/AlistRules :: Int -> GlobalAnnos -> [Rule]
5784N/A let lists = list_lit $ literal_annos g
5784N/A listRule co toks = (listId co, inf, toks)
5784N/A in concatMap ( \ (bs, (n, c)) ->
5784N/A let (b1, b2, cs) = getListBrackets bs
5784N/A e = Id (b1 ++ b2) cs nullRange in
5784N/A (if e == n then [] -- add b1 ++ b2 if its not yet included by n
5784N/A else [listRule (c, n) $ getPlainTokenList e])
5784N/A ++ [listRule (c, n) (b1 ++ [termTok] ++ b2),
5784N/A listRule (c, n) (b1 ++ [termTok, commaTok, termTok] ++ b2)]
5784N/AlookUp :: Table a -> Index -> [Item a]
5784N/A-- | recognize next token (possible introduce new tuple variable)
5784N/AscanItem :: (a -> a -> a) -> (a, Token) -> Item a -> [Item a]
5784N/A p@Item{ rest = ts, args = pArgs, posList = pRange } =
5784N/A let q = p { posList = appRange (tokPos t) pRange }
5784N/A hd : tt -> let r = q { rest = tt } in
5784N/A if hd == t || t == exprTok && hd == varTok then
5784N/A -- tuple or list elements separator
5784N/A [ r, q { rest = termTok : ts } ]
5784N/A else if t == exprTok || t == varTok then
5784N/A ([], [arg]) -> [q { rest = [], args = [addType trm arg] }]
5784N/A _ -> error "scanItem: typeTok"
5784N/Ascan :: (a -> a -> a) -> (a, Token) -> [Item a] -> [Item a]
5784N/Ascan f term = concatMap (scanItem f term)
5784N/AmkAmbigs :: ToExpr a -> Item a -> [a]
5784N/AmkAmbigs toExpr p@Item{ args = l, ambigArgs = aArgs } =
5784N/A p { args = takeDiff aas l ++ aas
5784N/AaddArg :: GlobalAnnos -> ToExpr a -> Item a -> Item a -> Item a
5784N/AaddArg ga toExpr argItem@Item { ambigs = ams } p@Item{ args = pArgs,
5784N/A rule = op, posList = pRange, ambigs = pAmbs, rest = pRest} =
5784N/A let (arg, ps) = mkExpr toExpr argItem
5784N/A newAms = mkAmbigs toExpr argItem
5784N/A , posList = ps `appRange` pRange
5784N/A , ambigs = (if null newAms then ams else newAms : ams)
5784N/A in if isLeftArg op pArgs then
5784N/A q { lWeight = getNewWeight ALeft ga argItem op }
5784N/A else if isRightArg op pArgs then
5784N/A q { rWeight = getNewWeight ARight ga argItem op }
5784N/A-- | shortcut for a function that constructs an expression
5784N/Atype ToExpr a = Id -> [a] -> Range -> a
5784N/AmkExpr :: ToExpr a -> Item a -> (a, Range)
5784N/AmkExpr toExpr Item { rule = orig, posList = ps, args = iArgs } =
5784N/A (ide, qs) = if isListId orig then (orig, rs) else
5784N/A setPlainIdePos (unProtect orig) rs
5784N/A else setPlainIdePos orig rs
5784N/A in (asListAppl toExpr ide (reverse iArgs) qs, rs)
5784N/Areduce :: GlobalAnnos -> Table a -> ToExpr a -> Item a -> [Item a]
5784N/Areduce ga table toExpr itm =
5784N/A $ filter (checkPrecs ga itm)
5784N/A-- | 'Id' starts with a 'place'
5784N/AbegPlace (Id toks _ _) = not (null toks) && isPlace (head toks)
5784N/A-- | 'Id' ends with a 'place'
5784N/AendPlace (Id toks _ _) = not (null toks) && isPlace (last toks)
5784N/A-- | check if a left argument will be added.
5784N/A-- (The 'Int' is the number of current arguments.)
5784N/AisLeftArg :: Id -> [a] -> Bool
5784N/AisLeftArg op nArgs = null nArgs && begPlace op
5784N/A-- | check if a right argument will be added.
5784N/AisRightArg :: Id -> [a] -> Bool
5784N/AisRightArg op@(Id toks _ _) nArgs = endPlace op &&
5784N/A (isSingle $ dropPrefix nArgs $ filter isPlace toks)
5784N/AgetWeight :: AssocEither -> Item a -> Id
5784N/AgetWeight side = case side of
5784N/AjoinPlace :: AssocEither -> Id -> Bool
5784N/AjoinPlace side = case side of
5784N/AgetNewWeight :: AssocEither -> GlobalAnnos -> Item a -> Id -> Id
5784N/AgetNewWeight side ga argItem op =
5784N/A let arg = getWeight side argItem
5784N/A in if joinPlace side arg then
5784N/A case precRel (prec_annos ga) op arg of
5784N/AcheckArg :: AssocEither -> GlobalAnnos -> Item a -> Item a -> Bool
5784N/AcheckArg side ga argItem@Item{ rule = arg, info = argPrec }
5784N/A Item{ rule = op, info = opPrec } =
5784N/A weight = getWeight side argItem
5784N/A in if argPrec <= 0 then False
5784N/A else case compare argPrec opPrec of
5784N/A EQ -> if joinPlace side arg then
5784N/A case precRel precs op weight of
5784N/A case (isInfix arg, joinPlace side op) of
5784N/A (True, True) -> if arg == op
5784N/A then not $ isAssoc side assocs op
5784N/A-- | check precedences of an argument and a top-level operator.
5784N/A-- (The 'Int' is the number of current arguments of the operator.)
5784N/AcheckPrecs :: GlobalAnnos -> Item a -> Item a -> Bool
5784N/AcheckPrecs ga argItem opItem@Item{ rule = op, args = oArgs } =
5784N/A if isLeftArg op oArgs then checkArg ARight ga argItem opItem
5784N/A else if isRightArg op oArgs then checkArg ALeft ga argItem opItem
5784N/AreduceCompleted :: GlobalAnnos -> Table a -> ToExpr a -> [Item a] -> [Item a]
5784N/AreduceCompleted ga table toExpr =
5784N/A foldr mergeItems [] . map (reduce ga table toExpr) .
5784N/ArecReduce :: GlobalAnnos -> Table a -> ToExpr a -> [Item a] -> [Item a]
5784N/ArecReduce ga table toExpr items =
5784N/A let reduced = reduceCompleted ga table toExpr items
5784N/A in if null reduced then items
5784N/A else recReduce ga table toExpr reduced `mergeItems` items
5784N/Acomplete :: ToExpr a -> GlobalAnnos -> Table a -> [Item a] -> [Item a]
5784N/Acomplete toExpr ga table items =
5784N/A let reducedItems = recReduce ga table toExpr $
5784N/A reduceCompleted ga table toExpr items
5784N/AdoPredict :: [Item a] -> ([Item a], [Item a])
5784N/AdoPredict items = partition ( \ Item{ rest = ts } ->
5784N/A not (null ts) && head ts == termTok) items
5784N/AordItem :: Item a -> Item a -> Ordering
5784N/AordItem Item{ index = i1, rest = r1, rule = n1 }
5784N/A Item{ index = i2, rest = r2, rule = n2 } =
5784N/A compare (i1, r1, n1) (i2, r2, n2)
5784N/AambigItems :: Item a -> Item a -> Item a
5784N/AambigItems i1@Item{ ambigArgs = ams1, args = as1 }
5784N/A Item{ ambigArgs = ams2, args = as2 } =
5784N/A i1 { ambigArgs = case ams1 ++ ams2 of
5784N/AmergeItems :: [Item a] -> [Item a] -> [Item a]
5784N/AmergeItems (i1:r1) (i2:r2) =
5784N/A LT -> i1 : mergeItems r1 (i2:r2)
5784N/A EQ -> ambigItems i1 i2 : mergeItems r1 r2
5784N/A GT -> i2 : mergeItems (i1:r1) r2
5784N/A-- | the whole state for mixfix resolution
5784N/Adata Chart a = Chart { prevTable :: Table a
5784N/A , currItems :: ([Item a], [Item a])
5784N/A , rules :: ([Rule], [Rule])
5784N/A , addRules :: Token -> [Rule]
5784N/A , solveDiags :: [Diagnosis] }
5784N/A-- | make one scan, complete, and predict step.
5784N/A-- The first function adds a type to the result.
5784N/A-- The second function filters based on argument and operator info.
5784N/A-- If filtering yields 'Nothing' further filtering by precedence is applied.
5784N/AnextChart :: (a -> a -> a) -> ToExpr a -> GlobalAnnos
5784N/A -> Chart a -> (a, Token) -> Chart a
5784N/AnextChart addType toExpr ga st term@(_, tok) =
5784N/A (cItems, sItems) = currItems st
5784N/A (cRules, sRules) = rules st
5784N/A pItems = if null cItems && idx /= startIndex then sItems else
5784N/A map (mkItem idx) (addRules st tok ++ sRules) ++ sItems
5784N/A scannedItems = scan addType term pItems
5784N/A nextTable = if null cItems && idx /= startIndex then table
5784N/A completedItems = complete toExpr ga nextTable
5784N/A $ sortBy ordItem $ scannedItems
5784N/A in if null pItems then st else
5784N/A , currItems = doPredict completedItems
5784N/A , solveDiags = (if null scannedItems then
5784N/A [Diag Error ("unexpected mixfix token: " ++ tokStr tok)
5784N/A else []) ++ solveDiags st }
5784N/A-- | add intermediate diagnostic messages
5784N/AmixDiags :: [Diagnosis] -> Chart a -> Chart a
5784N/AmixDiags ds st = st { solveDiags = ds ++ solveDiags st }
5784N/Atype Rules = ([Rule], [Rule]) -- postfix and prefix rules
5784N/ApartitionRules :: [Rule] -> Rules
5784N/ApartitionRules = partition ( \ (_, _, t : _) -> t == termTok)
5784N/A-- | create the initial chart
5784N/AinitChart :: (Token -> [Rule]) -> Rules -> Chart a
5784N/A-- | extract resolved result
5784N/AgetResolved :: (a -> ShowS) -> Range -> ToExpr a -> Chart a -> Result a
5784N/AgetResolved pp p toExpr st =
5784N/A let items = snd $ currItems st
5784N/A _ -> let (finals, rest1) = partition ((startIndex==) . index) items
5784N/A (result, rest2) = partition (null . rest) finals
5784N/A [] -> let expected = if null rest2
5784N/A then filter (not . null . rest) rest1
5784N/A withpos = filter (not . isNullRange . posList)
5784N/A (q, errs) = if null withpos then (p, expected)
5784N/A ("expected further mixfix token: "
5784N/A $ map (tokStr . head . rest)
5784N/A [har] -> case ambigs har of
5784N/A [] -> case mkAmbigs toExpr har of
5784N/A [] -> Result ds $ Just $ fst $ mkExpr toExpr har
5784N/A ambAs -> Result ((showAmbigs pp p $
5784N/A take 5 ambAs) : ds) Nothing
5784N/A ams -> Result ((map (showAmbigs pp p) $
5784N/A _ -> Result ((showAmbigs pp p $
5784N/A map (fst . mkExpr toExpr) result) : ds) Nothing
5784N/AshowAmbigs :: (a -> ShowS) -> Range -> [a] -> Diagnosis
5784N/A Diag Error ("ambiguous mixfix term\n " ++
5784N/A showSepList (showString "\n ") pp