MixAna.hs revision 23f8d286586ff38a9e73052b2c7c04c62c5c638f
ca010363454de207082dfaa4b753531ce2a34551Christian MaederModule : $Header$
ca010363454de207082dfaa4b753531ce2a34551Christian MaederCopyright : (c) Christian Maeder 2003
ca010363454de207082dfaa4b753531ce2a34551Christian MaederMaintainer : hets@tzi.de
ca010363454de207082dfaa4b753531ce2a34551Christian MaederStability : experimental
ca010363454de207082dfaa4b753531ce2a34551Christian MaederPortability : non-portable
ca010363454de207082dfaa4b753531ce2a34551Christian MaederMixfix analysis of terms, adapted from the CASL analysis
ca010363454de207082dfaa4b753531ce2a34551Christian Maederimport qualified Common.Lib.Map as Map
ca010363454de207082dfaa4b753531ce2a34551Christian Maederimport qualified Char as C
82e3fd7f1ab0014d6597fb7951c666e0e57121abChristian Maederimport Data.Maybe(mapMaybe)
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder-- Earley Algorithm
51c8e05cd5ba40a3264ed3e486b34bc45b7a060aChristian Maederdata PState = PState { ruleId :: Id -- the rule to match
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder , ruleScheme :: TypeScheme -- to make id unique
51c8e05cd5ba40a3264ed3e486b34bc45b7a060aChristian Maeder , ruleType :: Type -- type of Id
51c8e05cd5ba40a3264ed3e486b34bc45b7a060aChristian Maeder , posList :: [Pos] -- positions of Id tokens
51c8e05cd5ba40a3264ed3e486b34bc45b7a060aChristian Maeder , ruleArgs :: [Term] -- currently collected arguments
51c8e05cd5ba40a3264ed3e486b34bc45b7a060aChristian Maeder -- both in reverse order
51c8e05cd5ba40a3264ed3e486b34bc45b7a060aChristian Maeder , restRule :: [Token] -- part of the rule after the "dot"
51c8e05cd5ba40a3264ed3e486b34bc45b7a060aChristian Maeder , stateNo :: Int -- index into the ParseMap/input string
9379646a4fecb772e793a8875bb92723e854268cChristian Maederinstance Eq PState where
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder PState r1 s1 _ _ _ t1 p1 == PState r2 s2 _ _ _ t2 p2 =
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder (r1, s1, t1, p1) == (r2, s2, t2, p2)
9379646a4fecb772e793a8875bb92723e854268cChristian Maederinstance Show PState where
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder showsPrec _ (PState r _ _ _ _ d p) = showChar '{'
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder . showSepList (showString "") showTok first
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder . showChar '.'
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder . showSepList (showString "") showTok d
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder . shows p . showChar '}'
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder where first = take (length v - length d) v
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder v = getTokenList place r
9379646a4fecb772e793a8875bb92723e854268cChristian MaedertermStr :: String
9379646a4fecb772e793a8875bb92723e854268cChristian MaedertermStr = "(T)"
ca010363454de207082dfaa4b753531ce2a34551Christian MaedercommaTok, parenTok, termTok :: Token
ca010363454de207082dfaa4b753531ce2a34551Christian MaedercommaTok = mkSimpleId "," -- for list elements
9379646a4fecb772e793a8875bb92723e854268cChristian MaedertermTok = mkSimpleId termStr
ca010363454de207082dfaa4b753531ce2a34551Christian MaederparenTok = mkSimpleId "(..)"
ee0c5c1f995da3283814a2b7680e9f9876223900Christian MaedercolonTok, asTok, varTok, opTok, predTok, inTok, caseTok, litTok :: Token
ca010363454de207082dfaa4b753531ce2a34551Christian MaedercolonTok = mkSimpleId ":"
ca010363454de207082dfaa4b753531ce2a34551Christian MaederasTok = mkSimpleId "as"
ca010363454de207082dfaa4b753531ce2a34551Christian MaederinTok = mkSimpleId "in"
ee0c5c1f995da3283814a2b7680e9f9876223900Christian MaedercaseTok = mkSimpleId "case"
ca010363454de207082dfaa4b753531ce2a34551Christian MaedervarTok = mkSimpleId "(v)"
ca010363454de207082dfaa4b753531ce2a34551Christian MaederopTok = mkSimpleId "(o)"
ca010363454de207082dfaa4b753531ce2a34551Christian MaederpredTok = mkSimpleId "(p)"
ee0c5c1f995da3283814a2b7680e9f9876223900Christian MaederlitTok = mkSimpleId "\""
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian MaedermkRuleId :: [Token] -> Id
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian MaedermkRuleId toks = Id toks [] []
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian MaederapplId, parenId, colonId, asId, inId, varId, opId, litId :: Id
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian MaederapplId = mkRuleId [termTok, termTok]
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian MaederparenId = mkRuleId [parenTok]
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian MaedercolonId = mkRuleId [termTok, colonTok]
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian MaederasId = mkRuleId [termTok, asTok]
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian MaederinId = mkRuleId [termTok, inTok]
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian MaedervarId = mkRuleId [varTok]
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian MaederopId = mkRuleId [opTok]
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian MaederlitId = mkRuleId [litTok]
9379646a4fecb772e793a8875bb92723e854268cChristian MaedermkState :: Int -> (Id, OpInfo) -> State Int PState
9379646a4fecb772e793a8875bb92723e854268cChristian MaedermkState i (ide, info) =
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder do let sc = opType info
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder side = stripFinalPlaces ide
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder t <- freshInst sc
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder return $ PState side sc t [] [] (getTokenList termStr side) i
9379646a4fecb772e793a8875bb92723e854268cChristian MaedermkApplState :: Int -> (Id, OpInfo) -> State Int PState
9379646a4fecb772e793a8875bb92723e854268cChristian MaedermkApplState i (ide, info) =
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder do let sc = opType info
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder t <- freshInst sc
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder return $ PState ide sc t [] [] (getTokenList place ide) i
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder-- unique id (usually "[]" yields two tokens)
ca010363454de207082dfaa4b753531ce2a34551Christian MaederlistId = Id [mkSimpleId "[]"] [] []
9379646a4fecb772e793a8875bb92723e854268cChristian MaederlistStates :: GlobalAnnos -> Int -> State Int [PState]
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder-- no empty list (can be written down directly)
ca010363454de207082dfaa4b753531ce2a34551Christian MaederlistStates g i =
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder do ty <- freshType star
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder let listState toks = PState listId (simpleTypeScheme $
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder BracketType Squares [] [])
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder ty [] [] toks i
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder (b1, b2) = listBrackets g
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder return $ if null b1 || null b2 then []
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder else [ listState (b1 ++ [termTok] ++ b2)
ee0c5c1f995da3283814a2b7680e9f9876223900Christian Maeder , listState (b1 ++ [termTok, commaTok] ++ b2)]
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian MaedertupleStates :: Int -> State Int [PState]
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian MaedertupleStates i =
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder do ty <- freshType star
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder let tupleState toks = PState (Id [parenTok] [] [])
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder (simpleTypeScheme $
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder BracketType Parens [] [])
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder ty [] [] toks i
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder (b1, b2) = ([mkSimpleId "("], [mkSimpleId ")"])
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder return [ tupleState (b1 ++ b2)
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder , tupleState (b1 ++ [termTok] ++ b2)
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder , tupleState (b1 ++ [termTok, commaTok] ++ b2)]
ee0c5c1f995da3283814a2b7680e9f9876223900Christian Maeder-- these are the possible matches for the nonterminal (T)
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder-- the same states are used for the predictions
9379646a4fecb772e793a8875bb92723e854268cChristian MaederinitialState :: GlobalAnnos -> [(Id, OpInfo)] -> Int -> State Int [PState]
ca010363454de207082dfaa4b753531ce2a34551Christian MaederinitialState g ids i =
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder do ls <- listStates g i
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder ts <- tupleStates i
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder l1 <- mapM (mkState i) ids
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder l2 <- mapM (mkApplState i) $ filter (isMixfix . fst) ids
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder let ty = MixfixType []
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder sc = simpleTypeScheme ty
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder mkTokState r = PState r sc ty
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder [] [] (getTokenList place r) i
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder return (mkTokState parenId :
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder mkTokState colonId :
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder mkTokState asId :
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder mkTokState inId :
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder mkTokState varId :
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder mkTokState opId :
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder mkTokState litId :
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder mkTokState applId :
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder ls ++ ts ++ l1 ++ l2)
ca010363454de207082dfaa4b753531ce2a34551Christian MaederlookUp :: (Ord a, MonadPlus m) => Map.Map a (m b) -> a -> (m b)
ca010363454de207082dfaa4b753531ce2a34551Christian MaederlookUp ce k = Map.findWithDefault mzero k ce
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder-- match (and shift) a token (or partially finished term)
ca010363454de207082dfaa4b753531ce2a34551Christian Maederscan :: Term -> Int -> ParseMap -> ParseMap
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maederscan trm i cm =
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder let t = case trm of
ee0c5c1f995da3283814a2b7680e9f9876223900Christian Maeder TermToken x -> if isLitToken x then litTok else
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder m = parseMap cm
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder cm { parseMap = Map.insert (i+1) (
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder foldr (\ (PState o sc ty b a ts k) l ->
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder if null ts || head ts /= t then l
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder else let p = tokPos t : b in
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder if t == commaTok then
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder -- list elements separator
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder (PState o sc ty p a
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder (termTok : commaTok : tail ts) k)
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder : (PState o sc ty p a (termTok : tail ts) k) : l
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder else if t == parenTok || t == litTok then
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder (PState o sc ty b (trm : a) (tail ts) k) : l
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder else if t == varTok || t == opTok || t == predTok then
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder (PState o sc ty b [trm] (tail ts) k) : l
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder else if t == colonTok || t == asTok then
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder (PState o sc ty b [mkTerm $ head a] [] k) : l
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder else (PState o sc ty p a (tail ts) k) : l) []
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder (lookUp m i)) m }
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder where mkTerm t1 = case trm of
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder-- construct resulting term from PState
9379646a4fecb772e793a8875bb92723e854268cChristian MaederstateToAppl :: PState -> Term
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian MaederstateToAppl p =
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder let r = ruleId p
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder ar = reverse $ ruleArgs p
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder qs = reverse $ posList p
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder in if r == colonId
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder || r == litId
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder || r == parenId
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder || r == varId
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder else if r == applId then
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder ApplTerm (head ar) (head (tail ar)) qs
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder else foldr (\ (a, q) t -> ApplTerm t a [q])
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder (QualOp (InstOpId (ruleId p) [] []) (ruleScheme p) qs)
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder $ zip ar (posList p ++ repeat (if null qs then nullPos
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder else last qs))
9379646a4fecb772e793a8875bb92723e854268cChristian MaedertoAppl :: GlobalAnnos -> PState -> Term
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder if ruleId s == listId then
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder case list_lit $ literal_annos g of
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder Nothing -> error "toAppl"
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder Just (b, c, f) ->
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder let (b1, b2) = getListBrackets b
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder nb1 = length b1
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder nb2 = length b2
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder ra = reverse $ ruleArgs s
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder na = length ra
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder br = reverse $ posList s
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder nb = length br
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder mkList [] ps = asAppl c [] (head ps)
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder mkList (hd:tl) ps = asAppl f [hd, mkList tl (tail ps)] (head ps)
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder in if null ra then asAppl c []
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder (if null br then nullPos else head br)
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder else if nb + 1 == nb1 + nb2 + na then
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder let br1 = drop (nb1 - 1) br
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder in mkList ra br1
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder else error "toAppl"
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder else stateToAppl s
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian MaederasAppl :: Id -> [Term] -> Pos -> Term
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian MaederasAppl f args p = let pos = if null args then [] else [p]
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder in ApplTerm (QualOp (InstOpId f [] [])
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder (simpleTypeScheme $ MixfixType [])
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder []) (TupleTerm args []) pos
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder-- precedence graph stuff
ca010363454de207082dfaa4b753531ce2a34551Christian MaedercheckArg :: GlobalAnnos -> AssocEither -> Id -> Id -> Bool
ca010363454de207082dfaa4b753531ce2a34551Christian MaedercheckArg g dir op arg =
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder then isAssoc dir (assoc_annos g) op || not (isInfix op)
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder case precRel (prec_annos g) op arg of
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder Lower -> True
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder Higher -> False
dd38bafd384f5a5bc9634aad395505a0fd74395aChristian Maeder BothDirections -> False
dd38bafd384f5a5bc9634aad395505a0fd74395aChristian Maeder NoDirection -> not $ isInfix arg
ca010363454de207082dfaa4b753531ce2a34551Christian MaedercheckAnyArg :: GlobalAnnos -> Id -> Id -> Bool
ca010363454de207082dfaa4b753531ce2a34551Christian MaedercheckAnyArg g op arg =
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder case precRel (prec_annos g) op arg of
dd38bafd384f5a5bc9634aad395505a0fd74395aChristian Maeder BothDirections -> isInfix op && op == arg
ca010363454de207082dfaa4b753531ce2a34551Christian MaederisLeftArg, isRightArg :: Id -> Int -> Bool
ca010363454de207082dfaa4b753531ce2a34551Christian MaederisLeftArg (Id ts _ _) n = n + 1 == (length $ takeWhile isPlace ts)
ca010363454de207082dfaa4b753531ce2a34551Christian MaederisRightArg (Id ts _ _) n = n == (length $ filter isPlace ts) -
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder (length $ takeWhile isPlace (reverse ts))
9379646a4fecb772e793a8875bb92723e854268cChristian MaederfilterByPrec :: GlobalAnnos -> PState -> PState -> Bool
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian MaederfilterByPrec _ _ (PState _ _ _ _ _ [] _) = False
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian MaederfilterByPrec g (PState argIde _ _ _ _ _ _)
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder (PState opIde _ _ _ args (hd:_) _) =
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder if hd == termTok then
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder if opIde == listId || argIde == listId then True
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder else let n = length args in
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder if isLeftArg opIde n then
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder if isPostfix opIde && (isPrefix argIde
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder || isInfix argIde) then False
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder else checkArg g ALeft opIde argIde
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder else if isRightArg opIde n then
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder if isPrefix opIde && isInfix argIde then False
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder else checkArg g ARight opIde argIde
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder else checkAnyArg g opIde argIde
82e3fd7f1ab0014d6597fb7951c666e0e57121abChristian MaederexpandType :: TypeMap -> Type -> Type
82e3fd7f1ab0014d6597fb7951c666e0e57121abChristian MaederexpandType tm oldT =
82e3fd7f1ab0014d6597fb7951c666e0e57121abChristian Maeder TypeName _ _ _ -> fst $ expandAlias tm oldT
82e3fd7f1ab0014d6597fb7951c666e0e57121abChristian Maeder KindedType t _ _ -> t
82e3fd7f1ab0014d6597fb7951c666e0e57121abChristian Maeder LazyType t _ -> t
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian MaederaddArgState :: PState -> PState -> PState
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian MaederaddArgState arg op = op { ruleArgs = stateToAppl arg : ruleArgs op }
82e3fd7f1ab0014d6597fb7951c666e0e57121abChristian MaederfilterByType :: ParseMap -> PState -> PState -> Maybe PState
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian MaederfilterByType cm argState opState =
82e3fd7f1ab0014d6597fb7951c666e0e57121abChristian Maeder let tm = typeAliases cm in
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder if ruleId opState == applId && null (ruleArgs opState) then
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder Just (addArgState argState opState) { ruleType = ruleType argState }
82e3fd7f1ab0014d6597fb7951c666e0e57121abChristian Maeder case expandType tm $ ruleType opState of
82e3fd7f1ab0014d6597fb7951c666e0e57121abChristian Maeder FunType t1 _ t2 _ ->
82e3fd7f1ab0014d6597fb7951c666e0e57121abChristian Maeder case expandType tm t1 of
82e3fd7f1ab0014d6597fb7951c666e0e57121abChristian Maeder do s <- maybeResult $ unify tm argType
82e3fd7f1ab0014d6597fb7951c666e0e57121abChristian Maeder $ ruleType argState
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder return (addArgState argState opState)
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder {ruleType = subst s t2}
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder TypeName _ _ v -> if v == 0 then Nothing
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder else Just $ addArgState argState opState
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder-- when a grammar rule (mixfix Id) has been fully matched
9379646a4fecb772e793a8875bb92723e854268cChristian MaedercollectArg :: GlobalAnnos -> ParseMap -> PState -> [PState]
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder-- pre: finished rule
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian MaedercollectArg g m s@(PState _ _ _ _ _ _ k) =
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder map (\ p -> p { restRule = tail $ restRule p })
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder $ mapMaybe (filterByType m s)
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder $ filter (filterByPrec g s)
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder $ lookUp (parseMap m) k
9379646a4fecb772e793a8875bb92723e854268cChristian Maedercompl :: GlobalAnnos -> ParseMap -> [PState] -> [PState]
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder concat $ map (collectArg g m)
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder $ filter (\ (PState _ _ _ _ _ ts _) -> null ts) l
9379646a4fecb772e793a8875bb92723e854268cChristian MaedercomplRec :: GlobalAnnos -> ParseMap -> [PState] -> [PState]
ca010363454de207082dfaa4b753531ce2a34551Christian MaedercomplRec g m l = let l1 = compl g m l in
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder if null l1 then l else complRec g m l1 ++ l
ca010363454de207082dfaa4b753531ce2a34551Christian Maedercomplete :: GlobalAnnos -> Int -> ParseMap -> ParseMap
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maedercomplete g i cm =
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder let m = parseMap cm in
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder cm { parseMap = Map.insert i (complRec g cm $ lookUp m i) m }
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder-- predict which rules/ids might match for (the) nonterminal(s) (termTok)
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder-- provided the "dot" is followed by a nonterminal
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maederdata ParseMap = ParseMap { varCount :: Int
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder , typeAliases :: TypeMap
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder , parseMap :: Map.Map Int [PState]
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maederpredict :: GlobalAnnos -> [(Id, OpInfo)] -> Int -> ParseMap -> ParseMap
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maederpredict g is i cm =
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder let m = parseMap cm in
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder if i /= 0 && any (\ (PState _ _ _ _ _ ts _) -> not (null ts)
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder && head ts == termTok)
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder then let (ps, c2) = runState (initialState g is i)
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder (varCount cm)
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder in cm { varCount = c2
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder , parseMap = Map.insertWith (++) i ps m }
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maederdata Chart = Chart { chartCount :: Int
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder , chartDiags :: [Diagnosis]
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder , chartMap :: ParseMap }
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian MaederincrChartCount :: Chart -> Chart
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian MaederincrChartCount c = c { chartCount = chartCount c + 1 }
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian MaederaddChartDiags :: [Diagnosis] -> Chart -> Chart
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian MaederaddChartDiags ds c = c { chartDiags = ds ++ chartDiags c }
9379646a4fecb772e793a8875bb92723e854268cChristian MaedernextState :: GlobalAnnos -> [(Id, OpInfo)] -> Term -> Chart -> Chart
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian MaedernextState g is trm c@(Chart { chartCount = i }) =
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder let cm1 = predict g is i $ chartMap c
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder cm2 = complete g (i+1) $
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder scan trm i cm1
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder c2 = incrChartCount c
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder in if null (lookUp (parseMap cm2) (i+1)) && null (chartDiags c)
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder then addChartDiags [mkDiag Error "unexpected mixfix token" trm] c2
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder else c2 { chartMap = cm2 }
9379646a4fecb772e793a8875bb92723e854268cChristian MaederiterateStates :: GlobalAnnos -> [(Id, OpInfo)] -> [Term] -> Chart -> Chart
ca010363454de207082dfaa4b753531ce2a34551Christian MaederiterateStates g ops terms c =
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder let self = iterateStates g ops
ee0c5c1f995da3283814a2b7680e9f9876223900Christian Maeder _resolveTerm = resolve g ops
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder in if null terms then c
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder else case head terms of
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder MixfixTerm ts -> self (ts ++ tail terms) c
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder BracketTerm b ts ps -> self
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder (expandPos TermToken (getBrackets b) ts ps ++ tail terms) c
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder t -> self (tail terms) (nextState g ops t c)
ca010363454de207082dfaa4b753531ce2a34551Christian MaedergetAppls :: GlobalAnnos -> Int -> ParseMap -> [Term]
ca010363454de207082dfaa4b753531ce2a34551Christian MaedergetAppls g i m =
9379646a4fecb772e793a8875bb92723e854268cChristian Maeder map (toAppl g) $
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder filter (\ (PState _ _ _ _ _ ts k) -> null ts && k == 0) $
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder lookUp (parseMap m) i
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maederresolve :: GlobalAnnos -> [(Id, OpInfo)] -> ParseMap -> Term -> Result Term
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maederresolve g ops p trm =
6e6ba3ab90205840b9c0ea408befaed7d1d7b80bChristian Maeder let (ps, c2) = runState (initialState g ops 0) (varCount p)
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder Chart { chartCount = i, chartDiags = ds, chartMap = m } =
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder iterateStates g ops [trm]
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder Chart { chartCount = 0
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder , chartDiags = []
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder , chartMap = p { varCount = c2
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder , parseMap = Map.single 0 $ ps } }
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder ts = getAppls g i m
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder in if null ts then if null ds then
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder plain_error trm ("no resolution for term: "
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder ++ showPretty trm "")
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder else Result ds (Just trm)
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder else if null $ tail ts then Result ds (Just (head ts))
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder else Result (Diag Error ("ambiguous mixfix term\n\t" ++
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder (concatMap ( \ t -> showPretty t "\n\t" )
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder $ take 5 ts)) (nullPos) : ds) (Just trm)
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian MaederresolveTerm :: Term -> State Env (Result Term)
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian MaederresolveTerm t =
23f8d286586ff38a9e73052b2c7c04c62c5c638fChristian Maeder do tm <- gets typeMap
23f8d286586ff38a9e73052b2c7c04c62c5c638fChristian Maeder as <- gets assumps
23f8d286586ff38a9e73052b2c7c04c62c5c638fChristian Maeder c <- gets counter
23f8d286586ff38a9e73052b2c7c04c62c5c638fChristian Maeder ga <- gets globalAnnos
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder let ops = concatMap (\ (i, l) -> map ( \ e -> (i, e)) l)
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian Maeder return $ resolve ga ops (ParseMap c tm Map.empty) t