a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach

8267b99c0d7a187abe6f87ad50530dc08f5d1cdcAndy Gimblett{- |

e071fb22ea9923a2a4ff41184d80ca46b55ee932Till MossakowskiModule : $Header$

e85b224577b78d08ba5c39fe9dcc2e53995454a2Christian MaederCopyright : Christian Maeder and Uni Bremen 2003

97018cf5fa25b494adffd7e9b4e87320dae6bf47Christian MaederLicence : similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt

a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach

b4fbc96e05117839ca409f5f20f97b3ac872d1edTill MossakowskiMaintainer : hets@tzi.de

a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus RoggenbachStability : experimental

a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus RoggenbachPortability : portable

a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach

d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy Gimblett generic mixfix analysis

a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach

a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach-}

a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach

a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbachmodule Common.Earley (Rule

a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach -- * special tokens for special ids

90047eafd2de482c67bcd13103c6064e9b0cb254Andy Gimblett , varTok, exprTok, typeTok

eeaf0a8a1dc535d105904a2190f26c0835ecf429Andy Gimblett , applId, parenId, typeId, exprId, varId

d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy Gimblett , tupleId, unitId, unknownId, isUnknownId, unToken

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett , Knowns, protect, listRules, mixRule

eeaf0a8a1dc535d105904a2190f26c0835ecf429Andy Gimblett , getTokenPlaceList

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett , endPlace, begPlace

a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach -- * resolution chart

1538a6e8d77301d6de757616ffc69ee61f1482e4Andy Gimblett , Chart, mixDiags, ToExpr

a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach , initChart, nextChart, getResolved)

a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach where

eeaf0a8a1dc535d105904a2190f26c0835ecf429Andy Gimblett

8528886a04f14abe0ddf80f50c853cc25bc821cdAndy Gimblettimport Common.Id

a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbachimport Common.Result

792df0347edab377785d98c63e2be8e2ce0a8bdeChristian Maederimport Common.GlobalAnnotations

0ea916d1e6aea10fd7b84f802fb5148a79d8c20aAndy Gimblettimport Common.AS_Annotation

04ceed96d1528b939f2e592d0656290d81d1c045Andy Gimblettimport qualified Common.Lib.Set as Set

d9e78002fb0bf01a9b72d3d3415fdf9790bdfee8Andy Gimblettimport qualified Common.Lib.Map as Map

eeaf0a8a1dc535d105904a2190f26c0835ecf429Andy Gimblettimport Data.List

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblettimport Control.Exception (assert)

1538a6e8d77301d6de757616ffc69ee61f1482e4Andy Gimblett

c4b2418421546a337f83332fe0db04742dcd735dAndy Gimblett-- | reconstruct the token list of an 'Id'.

41486a487c9b065d4d9d1a8adf63c00925cd455bAndy Gimblett-- Replace top-level places with the input String

41486a487c9b065d4d9d1a8adf63c00925cd455bAndy GimblettgetTokenList :: String -> Id -> [Token]

e771539425f4a0abef9f94cf4b63690f3603f682Andy GimblettgetTokenList placeStr (Id ts cs ps) =

e771539425f4a0abef9f94cf4b63690f3603f682Andy Gimblett let convert = map (\ t -> if isPlace t then t {tokStr = placeStr} else t)

e771539425f4a0abef9f94cf4b63690f3603f682Andy Gimblett in if null cs then convert ts else

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett let (toks, pls) = splitMixToken ts in

e771539425f4a0abef9f94cf4b63690f3603f682Andy Gimblett convert toks ++ getCompoundTokenList cs ps ++ convert pls

e771539425f4a0abef9f94cf4b63690f3603f682Andy Gimblett

7caf9f99d426a25d56eb7473fea1f55ce4460762Andy Gimblett-- | update token positions.

7caf9f99d426a25d56eb7473fea1f55ce4460762Andy Gimblett-- return remaining positions

7caf9f99d426a25d56eb7473fea1f55ce4460762Andy GimblettsetToksPos :: [Token] -> [Pos] -> ([Token], [Pos])

7caf9f99d426a25d56eb7473fea1f55ce4460762Andy GimblettsetToksPos (h:ts) (p:ps) =

7caf9f99d426a25d56eb7473fea1f55ce4460762Andy Gimblett let (rt, rp) = setToksPos ts ps

e771539425f4a0abef9f94cf4b63690f3603f682Andy Gimblett in (h {tokPos = p} : rt, rp)

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettsetToksPos ts ps = (ts, ps)

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett

e771539425f4a0abef9f94cf4b63690f3603f682Andy Gimblett-- | update positions in 'Id'.

41486a487c9b065d4d9d1a8adf63c00925cd455bAndy Gimblett-- return remaining positions

e771539425f4a0abef9f94cf4b63690f3603f682Andy GimblettsetPlainIdePos :: Id -> [Pos] -> (Id, [Pos])

e771539425f4a0abef9f94cf4b63690f3603f682Andy GimblettsetPlainIdePos (Id ts cs _) ps =

eeaf0a8a1dc535d105904a2190f26c0835ecf429Andy Gimblett if null cs then

eeaf0a8a1dc535d105904a2190f26c0835ecf429Andy Gimblett let (newTs, restPs) = setToksPos ts ps

e771539425f4a0abef9f94cf4b63690f3603f682Andy Gimblett in (Id newTs cs [], restPs)

61051521e4d82769a47f23aecb5fb477de47d534Andy Gimblett else let (toks, pls) = splitMixToken ts

eeaf0a8a1dc535d105904a2190f26c0835ecf429Andy Gimblett ttail l = if null l then l else tail l

eeaf0a8a1dc535d105904a2190f26c0835ecf429Andy Gimblett (front, ps2) = setToksPos toks ps

eeaf0a8a1dc535d105904a2190f26c0835ecf429Andy Gimblett (newCs, ps3, ps4) = foldl ( \ (prevCs, seps, restPs) a ->

d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy Gimblett let (c1, qs) = setPlainIdePos a restPs

eeaf0a8a1dc535d105904a2190f26c0835ecf429Andy Gimblett in (c1: prevCs, head qs : seps, ttail qs))

d9e78002fb0bf01a9b72d3d3415fdf9790bdfee8Andy Gimblett ([], [head ps2], ttail ps2) cs

eeaf0a8a1dc535d105904a2190f26c0835ecf429Andy Gimblett (newPls, ps7) = setToksPos pls ps4

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett in (Id (front ++ newPls) (reverse newCs) (reverse ps3), ps7)

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett

e8c03c10d7987b223a9f6bfd5c0c54da21da5b86Andy Gimblett-- | a special index type for more type safety

fbc0c2baf563fe5b664f0152674a8d3acecca58cAndy Gimblettnewtype Index = Index Int deriving (Eq, Ord, Show)

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett

e771539425f4a0abef9f94cf4b63690f3603f682Andy Gimblett-- deriving Num is also possible

e771539425f4a0abef9f94cf4b63690f3603f682Andy Gimblett-- but the following functions are sufficient

d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy Gimblett-- | the initial index

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettstartIndex :: Index

820947bd01ca952c3909eaa0366c6914c87cc1cbTill MossakowskistartIndex = Index 0

d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy Gimblett

d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy GimblettincrIndex :: Index -> Index

d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy GimblettincrIndex (Index i) = Index (i + 1)

fbc0c2baf563fe5b664f0152674a8d3acecca58cAndy Gimblett

90047eafd2de482c67bcd13103c6064e9b0cb254Andy Gimblettdata Item a = Item

e8c03c10d7987b223a9f6bfd5c0c54da21da5b86Andy Gimblett { rule :: Id -- the rule to match

d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy Gimblett , info :: Int -- additional precedence info for 'rule'

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett , lWeight :: Id -- weights for lower precedence pre- and postfixes

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett , rWeight :: Id -- given by the 'Id's itself

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett , posList :: [Pos] -- positions of Id tokens

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett , args :: [a] -- currently collected arguments

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett -- both in reverse order

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett , ambigArgs :: [[a]] -- field for ambiguities

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett , ambigs :: [[a]] -- field for ambiguities

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett , rest :: [Token] -- part of the rule after the "dot"

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett , index :: Index -- index into the Table/input string

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett }

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblettinstance Show (Item a) where

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett showsPrec _ p =

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett let d = rest p

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett v = getPlainTokenList (rule p)

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett first = take (length v - length d) v

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett showToks = showSepList id showTok

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett Index i = index p

a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach in showChar '['. showToks first

7caf9f99d426a25d56eb7473fea1f55ce4460762Andy Gimblett . showChar '.'

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett . showToks d

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett . showString ", "

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett . shows i . showChar ']'

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett-- | the non-terminal

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimbletttermStr :: String

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimbletttermStr = "(__)"

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett-- | builtin terminals

7caf9f99d426a25d56eb7473fea1f55ce4460762Andy GimblettcommaTok, termTok, oParenTok, cParenTok, placeTok :: Token

31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimblettcommaTok = mkSimpleId "," -- for list elements

d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy GimbletttermTok = mkSimpleId termStr

d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy GimblettplaceTok = mkSimpleId place

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettoParenTok = mkSimpleId "("

31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimblettcParenTok = mkSimpleId ")"

31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimblettlistTok :: Token

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettlistTok = mkSimpleId "[]" -- impossible token

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettprotectTok :: Token

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettprotectTok = mkSimpleId "()" -- impossible token

8528886a04f14abe0ddf80f50c853cc25bc821cdAndy Gimblett

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett-- | token for type annotations

31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimbletttypeTok :: Token

31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimbletttypeTok = mkSimpleId ":"

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett-- | token for a fixed (or recursively resolved) operator expression

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettexprTok :: Token

d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy GimblettexprTok = mkSimpleId "(op )"

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett-- | token for a fixed (or recursively resolved) argument expression

d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy GimblettvarTok :: Token

d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy GimblettvarTok = mkSimpleId "(var )"

7caf9f99d426a25d56eb7473fea1f55ce4460762Andy Gimblett-- | token for an unknown variable (within patterns)

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettunknownTok :: Token

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettunknownTok = mkSimpleId "(?)"

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett-- | the invisible application rule with two places

31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimblettapplId :: Id

31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimblettapplId = mkId [placeTok, placeTok]

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett-- | parenthesis around one place

31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimblettparenId :: Id

31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimblettparenId = mkId [oParenTok, placeTok, cParenTok]

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett-- | id for tuples with at least two arguments

31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimbletttupleId :: Id

31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimbletttupleId = mkId [oParenTok, placeTok, commaTok, placeTok, cParenTok]

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett-- | id for the emtpy tuple

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettunitId :: Id

31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimblettunitId = mkId [oParenTok, cParenTok]

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett-- | see 'typeTok'

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimbletttypeId :: Id

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimbletttypeId = mkId [placeTok, typeTok]

7caf9f99d426a25d56eb7473fea1f55ce4460762Andy Gimblett-- | see 'exprTok'

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettexprId :: Id

e8c03c10d7987b223a9f6bfd5c0c54da21da5b86Andy GimblettexprId = mkId [exprTok]

e8c03c10d7987b223a9f6bfd5c0c54da21da5b86Andy Gimblett-- | see 'varTok'

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettvarId :: Id

e8c03c10d7987b223a9f6bfd5c0c54da21da5b86Andy GimblettvarId = mkId [varTok]

e95030058b77cb83593c85aa4c506caf154f63b7Andy Gimblett-- | see 'unknownTok'

e95030058b77cb83593c85aa4c506caf154f63b7Andy GimblettunknownId :: Id

e95030058b77cb83593c85aa4c506caf154f63b7Andy GimblettunknownId = mkId [unknownTok]

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy GimblettlistId :: (Id, Id) -> Id

e95030058b77cb83593c85aa4c506caf154f63b7Andy GimblettlistId (f,c) = Id [listTok] [f,c] []

e95030058b77cb83593c85aa4c506caf154f63b7Andy Gimblett

e8c03c10d7987b223a9f6bfd5c0c54da21da5b86Andy GimblettisListId :: Id -> Bool

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

7caf9f99d426a25d56eb7473fea1f55ce4460762Andy Gimblett && assert (length cs == 2) True

d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy Gimblett

8528886a04f14abe0ddf80f50c853cc25bc821cdAndy Gimblett-- | interpret placeholders as literal places

8528886a04f14abe0ddf80f50c853cc25bc821cdAndy Gimblettprotect :: Id -> Id

e8c03c10d7987b223a9f6bfd5c0c54da21da5b86Andy Gimblettprotect i = Id [protectTok] [i] []

e95030058b77cb83593c85aa4c506caf154f63b7Andy Gimblett

e95030058b77cb83593c85aa4c506caf154f63b7Andy GimblettunProtect :: Id -> Id

e95030058b77cb83593c85aa4c506caf154f63b7Andy GimblettunProtect (Id _ [i] _) = i

e95030058b77cb83593c85aa4c506caf154f63b7Andy GimblettunProtect _ = error "unProtect"

e95030058b77cb83593c85aa4c506caf154f63b7Andy Gimblett

e95030058b77cb83593c85aa4c506caf154f63b7Andy GimblettisProtected :: Id -> Bool

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

e95030058b77cb83593c85aa4c506caf154f63b7Andy Gimblett && isSingle cs

e95030058b77cb83593c85aa4c506caf154f63b7Andy Gimblett

e95030058b77cb83593c85aa4c506caf154f63b7Andy Gimblett-- | test if an 'unknownId' was matched

e95030058b77cb83593c85aa4c506caf154f63b7Andy GimblettisUnknownId :: Id -> Bool

e95030058b77cb83593c85aa4c506caf154f63b7Andy GimblettisUnknownId (Id ts _ _) = not (null ts) && head ts == unknownTok

e95030058b77cb83593c85aa4c506caf154f63b7Andy Gimblett

e95030058b77cb83593c85aa4c506caf154f63b7Andy Gimblett-- | get unknown token from an 'unknownId'

e95030058b77cb83593c85aa4c506caf154f63b7Andy GimblettunToken :: Id -> Token

e95030058b77cb83593c85aa4c506caf154f63b7Andy GimblettunToken (Id [_,t] _ _) = t

e8c03c10d7987b223a9f6bfd5c0c54da21da5b86Andy GimblettunToken _ = error "unToken"

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett

fbc0c2baf563fe5b664f0152674a8d3acecca58cAndy Gimbletttype Rule = (Id, Int, [Token])

9f6d67c9b0e2661e7967b435f17a27687929144fAndy Gimblett

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy GimblettmkItem :: Index -> Rule -> Item a

06dd4e7c29f33f6122a910719e3bd9062256e397Andy GimblettmkItem ind (ide, inf, toks) =

d9e78002fb0bf01a9b72d3d3415fdf9790bdfee8Andy Gimblett Item { rule = ide

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett , info = inf

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett , lWeight = ide

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett , rWeight = ide

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett , posList = []

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett , args = []

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett , ambigArgs = []

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett , ambigs = []

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett , rest = toks

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett , index = ind }

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett-- | extract tokens with the non-terminal for places

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy GimblettgetTokenPlaceList :: Id -> [Token]

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy GimblettgetTokenPlaceList = getTokenList termStr

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett-- | construct a rule for a mixfix

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy GimblettmixRule :: b -> Id -> (Id, b, [Token])

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy GimblettmixRule b i = (i, b, getTokenPlaceList i)

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett

06dd4e7c29f33f6122a910719e3bd9062256e397Andy GimblettasListAppl :: ToExpr a -> Id -> [a] -> [Pos] -> a

a731366827a80af216ce6bfd4aa6388260577791Andy GimblettasListAppl toExpr i ra br =

f5c948fd73698a64837609e1b60350126268beddAndy Gimblett if isListId i then

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett let Id _ [f, c] _ = i

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett mkList [] ps = toExpr c [] ps

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett mkList (hd:tl) ps = toExpr f [hd, mkList tl ps] ps

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett in mkList ra br

f5c948fd73698a64837609e1b60350126268beddAndy Gimblett else if i == typeId

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett || i == exprId

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett || i == parenId

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett || i == varId

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett then assert (isSingle ra) $ head ra

f5c948fd73698a64837609e1b60350126268beddAndy Gimblett else toExpr i ra br

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett-- | construct the list rules

06dd4e7c29f33f6122a910719e3bd9062256e397Andy GimblettlistRules :: b -> GlobalAnnos -> [(Id, b, [Token])]

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy GimblettlistRules inf g =

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett let lists = list_lit $ literal_annos g

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett listRule co toks = (listId co, inf, toks)

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett in concatMap ( \ (bs, (n, c)) ->

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett let (b1, b2, cs) = getListBrackets bs

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

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

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

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

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

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett ) $ Map.toList lists

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimbletttype Table a = Map.Map Index [Item a]

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett

06dd4e7c29f33f6122a910719e3bd9062256e397Andy GimblettlookUp :: Table a -> Index -> [Item a]

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy GimblettlookUp ce k = Map.findWithDefault [] k ce

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett

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

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimbletttype Knowns = Set.Set String

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett

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

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy GimblettscanItem :: (a -> a -> a) -> Knowns -> (a, Token) -> Item a

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett -> [Item a]

06dd4e7c29f33f6122a910719e3bd9062256e397Andy GimblettscanItem addType ks (trm, t) p =

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett let ts = rest p

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett as = args p

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett ide = rule p

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

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett in if null ts then [] else

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett let tt = tail ts

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett r = q { rest = tt }

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett in

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett if head ts == t then

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett if t == commaTok then

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett assert (not $ null tt) $

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett if head tt == termTok then

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett -- tuple or list elements separator

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

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett else [r]

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett else if t == exprTok || t == varTok then

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett [r { args = trm : args p }]

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett else if t == typeTok then

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett assert (null tt && isSingle as) $

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

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett else [r]

784f137bcf1ab23b3b87d5506e586e59c383ba96Andy Gimblett else if Set.isEmpty ks then []

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett else if isUnknownId ide

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

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett [r { rule = mkId [unknownTok, t]}]

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett else []

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblettscan :: (a -> a -> a) -> Knowns -> (a, Token) -> [Item a]

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett -> [Item a]

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblettscan f ks term = concatMap (scanItem f ks term)

06dd4e7c29f33f6122a910719e3bd9062256e397Andy Gimblett

06dd4e7c29f33f6122a910719e3bd9062256e397Andy GimblettmkAmbigs :: ToExpr a -> Item a -> [a]

784f137bcf1ab23b3b87d5506e586e59c383ba96Andy GimblettmkAmbigs toExpr p =

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett let l = args p in

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett map ( \ as -> fst $

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett mkExpr toExpr

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

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett } ) $ ambigArgs p

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy GimblettaddArg :: GlobalAnnos -> ToExpr a -> Item a -> Item a -> Item a

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy GimblettaddArg ga toExpr argItem p =

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett let (arg, q) = mkExpr toExpr argItem

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett ams = ambigs argItem

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett newAms = mkAmbigs toExpr argItem

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett in assert (not $ null $ rest p) $

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett p { rest = tail $ rest p

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett , lWeight = getLWeight ga argItem p

d9e78002fb0bf01a9b72d3d3415fdf9790bdfee8Andy Gimblett , rWeight = getRWeight ga argItem p

fbc0c2baf563fe5b664f0152674a8d3acecca58cAndy Gimblett , posList = q : posList p

fbc0c2baf563fe5b664f0152674a8d3acecca58cAndy Gimblett , args = arg : args p

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

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett ++ ambigs p }

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett

31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimblettgetLWeight :: GlobalAnnos -> Item a -> Item a -> Id

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy GimblettgetLWeight ga argItem opItem =

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett let op = rule opItem

a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett arg = lWeight argItem

d9e78002fb0bf01a9b72d3d3415fdf9790bdfee8Andy Gimblett num = length $ args opItem in

fbc0c2baf563fe5b664f0152674a8d3acecca58cAndy Gimblett if isLeftArg op num then

fbc0c2baf563fe5b664f0152674a8d3acecca58cAndy Gimblett if begPlace arg then

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett case precRel (prec_annos ga) op arg of

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett Higher -> arg

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett _ -> op

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett else op

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett else lWeight opItem

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett

a731366827a80af216ce6bfd4aa6388260577791Andy GimblettgetRWeight :: GlobalAnnos -> Item a -> Item a -> Id

a731366827a80af216ce6bfd4aa6388260577791Andy GimblettgetRWeight ga argItem opItem =

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett let op = rule opItem

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett arg = rWeight argItem

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett num = length $ args opItem in

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett if isRightArg op num then

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett if endPlace arg then

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett case precRel (prec_annos ga) op arg of

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett Higher -> arg

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett _ -> op

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett else op

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett else rWeight opItem

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett-- | shortcut for a function that constructs an expression

a731366827a80af216ce6bfd4aa6388260577791Andy Gimbletttype ToExpr a = Id -> [a] -> [Pos] -> a

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett

31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimblettmkExpr :: ToExpr a -> Item a -> (a, Pos)

a731366827a80af216ce6bfd4aa6388260577791Andy GimblettmkExpr toExpr itm =

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett let orig = rule itm

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett ps = posList itm

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett rs = reverse ps

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

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett if isProtected orig then

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett setPlainIdePos (unProtect orig) rs

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett else setPlainIdePos orig rs

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett as = reverse $ args itm

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett in (asListAppl toExpr ide as qs,

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett if null ps then nullPos else head ps)

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett

a731366827a80af216ce6bfd4aa6388260577791Andy Gimbletttype Filt = Int -> Int -> Maybe Bool

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblettreduce :: GlobalAnnos -> Table a -> [Id] -> Filt

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett -> ToExpr a -> Item a -> [Item a]

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblettreduce ga table rs filt toExpr itm =

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett map (addArg ga toExpr itm)

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

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett if null ts then False

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett else if head ts == termTok

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett then checkPrecs filt ga rs itm oi

a731366827a80af216ce6bfd4aa6388260577791Andy Gimblett else False )

31f039ffdb33d78cb31d24b71d3155b11a323975Andy Gimblett $ lookUp table $ index itm

d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett

-- | 'Id' starts with a 'place'

begPlace :: Id -> Bool

begPlace (Id toks _ _) = not (null toks) && isPlace (head toks)

-- | 'Id' ends with a 'place'

endPlace :: Id -> Bool

endPlace (Id toks _ _) = not (null toks) && isPlace (last toks)

-- | check if a left argument will be added.

-- (The 'Int' is the number of current arguments.)

isLeftArg :: Id -> Int -> Bool

isLeftArg op num = begPlace op && num == 0

-- | check if a right argument will be added.

isRightArg :: Id -> Int -> Bool

isRightArg op num = endPlace op && num + 1 == placeCount op

joinRIds, joinLIds :: Id -> Id -> Id

joinRIds (Id ts1 _ _) (Id ts2 cs ps) = Id (init ts1 ++ ts2) cs ps

joinLIds (Id ts1 _ _) (Id ts2 cs ps) = Id (ts1 ++ tail ts2) cs ps

-- | check precedences of an argument and a top-level operator.

-- (The 'Int' is the number of current arguments of the operator.)

checkPrecs :: Filt -> GlobalAnnos

-> [Id] -> Item a -> Item a -> Bool

checkPrecs filt ga rs argItem opItem =

let op = rule opItem

opPrec = info opItem

arg = rule argItem

argPrec = info argItem

precs = prec_annos ga

assocs = assoc_annos ga

num = length $ args opItem in

if isLeftArg op num then

if isNonCompound arg && joinLIds arg op `elem` rs then False else

case filt argPrec opPrec of

Just b -> b

Nothing ->

let rarg = rWeight argItem in

if endPlace arg then

case precRel precs op rarg of

Lower -> True

Higher -> False

BothDirections -> False

NoDirection ->

case (begPlace arg, endPlace op) of

(True, True) -> if arg == op

then not $ isAssoc ARight assocs op

else True

(False, True) -> True

(_, False) -> False

else True

else if isRightArg op num then

if isNonCompound op && joinRIds op arg `elem` rs then False else

case filt argPrec opPrec of

Just b -> b

Nothing -> let larg = lWeight argItem in

if begPlace arg then

case precRel precs op larg of

Lower -> True

Higher -> False

BothDirections -> False

NoDirection ->

case (begPlace op, endPlace arg) of

(True, True) -> if arg == op

then not $ isAssoc ALeft assocs op

else True

(False, True) -> False

(_, False) -> True

else True

else True

reduceCompleted :: GlobalAnnos -> Table a -> [Id]

-> Filt -> ToExpr a

-> [Item a] -> [Item a]

reduceCompleted ga table rs filt toExpr =

foldr mergeItems [] . map (reduce ga table rs filt toExpr) .

filter (null . rest)

recReduce :: GlobalAnnos -> Table a -> [Id] -> Filt

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

recReduce ga table rs filt toExpr items =

let reduced = reduceCompleted ga table rs filt toExpr items

in if null reduced then items

else recReduce ga table rs filt toExpr reduced `mergeItems` items

complete :: Filt -> ToExpr a -> GlobalAnnos

-> Table a -> [Id] -> [Item a] -> [Item a]

complete filt toExpr ga table rs items =

let reducedItems = recReduce ga table rs filt toExpr $

reduceCompleted ga table rs filt toExpr items

in reducedItems

++ items

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

predict rs items =

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

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

then rs ++ items

else items

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

ordItem i1 i2 =

compare (index i1, rest i1, rule i1)

(index i2, rest i2, rule i2)

ambigItems :: Item a -> Item a -> Item a

ambigItems i1 i2 = let as = ambigArgs i1 ++ ambigArgs i2 in

i1 { ambigArgs = if null as then

[args i1, args i2] else as }

mergeItems :: [Item a] -> [Item a] -> [Item a]

mergeItems [] i2 = i2

mergeItems i1 [] = i1

mergeItems (i1:r1) (i2:r2) =

case ordItem i1 i2 of

LT -> i1 : mergeItems r1 (i2:r2)

EQ -> ambigItems i1 i2 : mergeItems r1 r2

GT -> i2 : mergeItems (i1:r1) r2

-- | the whole state for mixfix resolution

data Chart a = Chart { prevTable :: Table a

, currIndex :: Index

, currItems :: [Item a]

, rules :: [Rule]

, 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) -> Filt -> ToExpr a

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

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

let table = prevTable st

idx = currIndex st

items = currItems st

rs = rules 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) rs)

$ complete filt toExpr ga nextTable (map ( \ (i, _, _) -> i) rs)

$ sortBy ordItem 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 -> Chart a

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

-- | create the initial chart

initChart :: [Rule] -> Knowns -> Chart a

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 -> Chart a -> 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 = 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