MixParserState.hs revision 441b53bd9480b058a6a8be774a5b8a37881f4b8b
bb83db66bd9b3b4ce67be66419daf29886175276Andy GimblettModule : $Header$
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederCopyright : (c) Christian Maeder and Uni Bremen 2003
98890889ffb2e8f6f722b00e265a211f13b5a861Corneliu-Claudiu ProdescuMaintainer : hets@tzi.de
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus RoggenbachStability : experimental
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederPortability : portable
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbachspecial parsing states for the mixfix analysis of terms
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbachimport qualified Common.Lib.Map as Map
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maederimport qualified Common.Lib.Set as Set
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach-- avoid confusion with the variable counter Int
70a691ea12f53381209a3709cdd325df5fc0a0c8Christian Maedernewtype Index = Index Int deriving (Eq, Ord, Show)
792df0347edab377785d98c63e2be8e2ce0a8bdeChristian Maeder-- deriving Num is also possible
2a5b885d9350ec6dd8bc4992ee91d2f68aa592f4Christian Maeder-- but the following functions are sufficient
0ea916d1e6aea10fd7b84f802fb5148a79d8c20aAndy GimblettstartIndex :: Index
04ceed96d1528b939f2e592d0656290d81d1c045Andy GimblettstartIndex = Index 0
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly-- (also hiding (==) seems not possible)
9f93b2a8b552789cd939d599504d39732672dc84Christian MaederisStartIndex :: Index -> Bool
1538a6e8d77301d6de757616ffc69ee61f1482e4Andy GimblettisStartIndex = (== startIndex)
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'ReillyincrIndex :: Index -> Index
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'ReillyincrIndex (Index i) = Index (i + 1)
842ae753ab848a8508c4832ab64296b929167a97Christian Maederdata PState a = PState { ruleId :: Id -- the rule to match
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder , ruleScheme :: TypeScheme -- to make id unique
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder , ruleType :: Type -- type of Id
c4b2418421546a337f83332fe0db04742dcd735dAndy Gimblett , posList :: [Pos] -- positions of Id tokens
bcd914850de931848b86d7728192a149f9c0108bChristian Maeder , ruleArgs :: [a] -- currently collected arguments
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maeder -- both in reverse order
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder , restRule :: [Token] -- part of the rule after the "dot"
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder , stateNo :: Index -- index into the ParseMap/input string
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maederinstance Eq (PState a) where
e54c5af823b9775dd2c058185ea5bdf7593950faAndy Gimblett PState r1 s1 _ _ _ t1 p1 == PState r2 s2 _ _ _ t2 p2 =
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder (r1, s1, t1, p1) == (r2, s2, t2, p2)
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maederinstance Show (PState a) where
a78bb62cd6f0beb2dab862db865357fc9d3c25feChristian Maeder showsPrec _ p =
a78bb62cd6f0beb2dab862db865357fc9d3c25feChristian Maeder let d = restRule p
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maeder v = getPlainTokenList (ruleId p)
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maeder first = take (length v - length d) v
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maeder Index i = stateNo p
7e7d791d2f643ffd82843b78e424b6f9f68c24eeChristian Maeder in showChar '{'
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maeder . showSepList (showString "") showTok first
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maeder . showChar '.'
bcd914850de931848b86d7728192a149f9c0108bChristian Maeder . showSepList (showString "") showTok d
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maeder . shows i . showChar '}'
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maeder . showChar ':'
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maeder . showPretty (ruleType p)
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian MaedertermStr :: String
8db2221917c1bc569614f3481bcdb3b988facaedChristian MaedercommaTok, termTok, oParenTok, cParenTok, placeTok :: Token
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian MaedercommaTok = mkSimpleId "," -- for list elements
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian MaedertermTok = mkSimpleId termStr
e771539425f4a0abef9f94cf4b63690f3603f682Andy GimblettplaceTok = mkSimpleId place
bb83db66bd9b3b4ce67be66419daf29886175276Andy GimblettoParenTok = mkSimpleId "("
d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettcParenTok = mkSimpleId ")"
2f35e5f6757968746dbab385be21fcae52378a3fLiam O'ReillyopTok, inTok, caseTok :: Token
fbc0c2baf563fe5b664f0152674a8d3acecca58cAndy GimblettinTok = mkSimpleId "in"
31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimblettcaseTok = mkSimpleId "case"
e771539425f4a0abef9f94cf4b63690f3603f682Andy GimblettopTok = mkSimpleId "(o)"
d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy GimblettmkRuleId :: [Token] -> Id
842ae753ab848a8508c4832ab64296b929167a97Christian MaedermkRuleId toks = Id toks [] []
f4a5178450076ee54f3a9adb4f91e241aea3ba75Christian MaederapplId, parenId, inId, opId, tupleId, unitId :: Id
f4a5178450076ee54f3a9adb4f91e241aea3ba75Christian MaederapplId = mkRuleId [placeTok, placeTok]
90047eafd2de482c67bcd13103c6064e9b0cb254Andy GimblettparenId = mkRuleId [oParenTok, placeTok, cParenTok]
bb83db66bd9b3b4ce67be66419daf29886175276Andy GimbletttupleId = mkRuleId [oParenTok, placeTok, commaTok, cParenTok]
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederunitId = mkRuleId [oParenTok, cParenTok]
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederinId = mkRuleId [inTok]
d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettopId = mkRuleId [opTok]
4314e26a12954cb1c9be4dea10aa8103edac5bbbChristian MaedermkPState :: Index -> Id -> TypeScheme -> Type -> [Token] -> PState a
842ae753ab848a8508c4832ab64296b929167a97Christian MaedermkPState ind ide sc ty toks =
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder PState { ruleId = ide
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder , ruleScheme = sc
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder , ruleType = ty
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder , posList = []
2a5b885d9350ec6dd8bc4992ee91d2f68aa592f4Christian Maeder , ruleArgs = []
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder , restRule = toks
2a5b885d9350ec6dd8bc4992ee91d2f68aa592f4Christian Maeder , stateNo = ind }
bb83db66bd9b3b4ce67be66419daf29886175276Andy GimblettmkMixfixState :: Index -> (Id, OpInfo) -> State Int (PState a)
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus RoggenbachmkMixfixState i (ide, info) =
bb83db66bd9b3b4ce67be66419daf29886175276Andy Gimblett do let sc = opType info
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder t <- freshInst sc
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder let stripped = case t of
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder FunType t1 _ _ _ ->
dfc58f5ec6492d1a9b9babd9cdcdbb15baa6e657Christian Maeder ProductType _ _ -> ide
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'Reilly _ -> stripFinalPlaces ide
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'Reilly _ -> stripFinalPlaces ide
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'Reilly return $ mkPState i stripped sc t $ getTokenList termStr stripped
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'ReillymkPlainApplState :: Index -> (Id, OpInfo) -> State Int (PState a)
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'ReillymkPlainApplState i (ide, info) =
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder do let sc = opType info
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder t <- freshInst sc
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder return $ mkPState i ide sc t $ getPlainTokenList ide
bb83db66bd9b3b4ce67be66419daf29886175276Andy GimblettlistToken :: Token
d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettlistToken = mkSimpleId "[]"
bb83db66bd9b3b4ce67be66419daf29886175276Andy GimblettlistId :: Id -> Id
4314e26a12954cb1c9be4dea10aa8103edac5bbbChristian Maeder-- unique id (usually "[]" yields two tokens)
e54c5af823b9775dd2c058185ea5bdf7593950faAndy GimblettlistId i = Id [listToken] [i] []
d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy GimblettisListId :: Id -> Bool
d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy GimblettisListId (Id ts cs _) = not (null ts) && head ts == listToken && length cs == 1
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'ReillylistStates :: GlobalAnnos -> Index -> State Int [PState a]
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly-- no empty list (can be written down directly)
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'ReillylistStates g i =
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder do tvar <- freshVar
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly let ty = TypeName tvar star 1
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder lists = list_lit $ literal_annos g
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly listState co toks = mkPState i (listId co) (simpleTypeScheme $
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly BracketType Squares [] [])
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly in return $ concatMap ( \ (bs, n, c) ->
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly let (b1, b2, cs) = getListBrackets bs
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder e = Id (b1 ++ b2) cs [] in
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder (if e == n then [] -- add b1 ++ b2 if its not yet included by n
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly else [listState c $ getPlainTokenList e]) ++
f4a5178450076ee54f3a9adb4f91e241aea3ba75Christian Maeder [listState c (b1 ++ [termTok] ++ b2)
f4a5178450076ee54f3a9adb4f91e241aea3ba75Christian Maeder , listState c (b1 ++ [termTok, commaTok] ++ b2)]
d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett-- these are the possible matches for the nonterminal (T)
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder-- the same states are used for the predictions
0b8146e4f675518993a34eb2255ad7ddd7bf82a4Christian MaedermkTokState :: Index -> Id -> State Int (PState a)
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaedermkTokState i r =
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly do tvar <- freshVar
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly let ty = TypeName tvar star 1
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly sc = simpleTypeScheme ty
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly return $ mkPState i r sc ty $ getTokenList termStr r
4620f04678d4221ed3547f5bcab117d41ffd86f4Christian MaedermkApplTokState :: Index -> Id -> State Int (PState a)
2a5b885d9350ec6dd8bc4992ee91d2f68aa592f4Christian MaedermkApplTokState i r =
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'Reilly do tv1 <- freshVar
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly tv2 <- freshVar
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly let ty1 = TypeName tv1 star 1
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly ty2 = TypeName tv2 star 1
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly tappl = FunType ty1 PFunArr ty2 []
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly t2appl = FunType tappl PFunArr tappl []
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly sc = simpleTypeScheme t2appl
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly return $ mkPState i r sc t2appl $ getTokenList termStr r
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'ReillymkTupleTokState :: Index -> Id -> State Int (PState a)
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'ReillymkTupleTokState i r =
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly do tv1 <- freshVar
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly tv2 <- freshVar
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly let ty1 = TypeName tv1 star 1
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder ty2 = TypeName tv2 star 1
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder tuple = ProductType [ty1, ty2] []
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder tappl = FunType ty1 PFunArr (FunType ty2 PFunArr tuple []) []
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder sc = simpleTypeScheme tappl
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder return $ mkPState i r sc tappl $ getTokenList termStr r
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'ReillymkParenTokState :: Index -> Id -> State Int (PState a)
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'ReillymkParenTokState i r =
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly do tv1 <- freshVar
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly let ty1 = TypeName tv1 star 1
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly tappl = FunType ty1 PFunArr ty1 []
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'Reilly sc = simpleTypeScheme tappl
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly return $ mkPState i r sc tappl $ getTokenList termStr r
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'ReillyinitialState :: GlobalAnnos -> Assumps -> Index -> State Int [PState a]
bb83db66bd9b3b4ce67be66419daf29886175276Andy GimblettinitialState g as i =
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder do let ids = concatMap (\ (ide, l) -> map ( \ e -> (ide, e)) l)
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder ls <- listStates g i
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder l1 <- mapM (mkMixfixState i) ids
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder l2 <- mapM (mkPlainApplState i) $ filter (isMixfix . fst) ids
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder a <- mkApplTokState i applId
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly p <- mkParenTokState i parenId
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly t <- mkTupleTokState i tupleId
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly l3 <- mapM (mkTokState i)
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly return (a:p:t:ls ++ l1 ++ l2 ++ l3)
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly-- recognize next token (possible introduce new tuple variable)
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'ReillyscanState :: TypeMap -> (Type, a) -> Token -> PState a
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly -> State Int [PState a]
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'ReillyscanState tm (ty, trm) t p =
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder do let ts = restRule p
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder if null ts || head ts /= t then return []
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder else if t == commaTok then -- list and tuple elements separator
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder do tvar <- freshVar
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder let nextTy = TypeName tvar star 1
0b8146e4f675518993a34eb2255ad7ddd7bf82a4Christian Maeder newTy = case ruleType p of
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly FunType lastTy PFunArr (ProductType tys ps) _ ->
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder FunType lastTy PFunArr
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'Reilly (FunType nextTy PFunArr (ProductType (tys++[nextTy]) ps)
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder _ -> error "scanState"
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder return [ p { restRule = termTok : commaTok : tail ts
7e7d791d2f643ffd82843b78e424b6f9f68c24eeChristian Maeder , ruleType = newTy }
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder , p { restRule = termTok : tail ts }]
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder else return $
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder if t == opTok || t == inTok then
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder let mp = do q <- filterByType tm (ty,trm) p
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder return q { ruleType = ty, restRule = tail ts }
bcd914850de931848b86d7728192a149f9c0108bChristian Maeder in maybeToList mp
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'Reilly else [p { restRule = tail ts, posList = tokPos t : posList p }]
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder-- construct resulting term from PState
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'ReillystateToAppl :: PState Term -> Term
fd4ad12563262ebe380d810df8f7755cfab5fb42Liam O'ReillystateToAppl p =
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder let r = ruleId p
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder sc@(TypeScheme _ (_ :=> ty) _) = ruleScheme p
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder ar = reverse $ ruleArgs p
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder qs = reverse $ posList p
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder in if r == inId
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder || r == parenId
2f35e5f6757968746dbab385be21fcae52378a3fLiam O'Reilly else if r == applId then
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder ApplTerm (head ar) (head (tail ar)) qs
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder else if r == tupleId || r == unitId then TupleTerm ar qs
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder else addFunArguments (ty, QualOp (InstOpId r [] []) sc qs)
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder $ concatMap expandArgument ar
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederexpandArgument :: Term -> [Term]
e8c03c10d7987b223a9f6bfd5c0c54da21da5b86Andy GimblettexpandArgument arg =
fbc0c2baf563fe5b664f0152674a8d3acecca58cAndy Gimblett TupleTerm ts _ -> concatMap expandArgument ts
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederaddFunArguments :: (Type, Term) -> [Term] -> Term
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederaddFunArguments (ty, trm) args =
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder if null args then trm else
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder FunType t1 _ t2 _ ->
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly let arg: rest = getArgument t1 args in
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy Gimblett addFunArguments (t2, ApplTerm trm arg []) rest
06a77f038c0e1740672274377901d37d0113226dLiam O'Reilly _ -> error "addFunArguments"
06a77f038c0e1740672274377901d37d0113226dLiam O'ReillygetArgument :: Type -> [Term] -> [Term]
816c50f9135a598dfdcfb2af8a80390bc42a9b24Liam O'ReillygetArgument ty args =
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy Gimblett ProductType ts _ ->
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder let (trms, rest) = getArguments ts args in
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder TupleTerm trms [] : rest
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly _ -> if null args then error "getArgument"
842ae753ab848a8508c4832ab64296b929167a97Christian MaedergetArguments :: [Type] -> [Term] -> ([Term], [Term])
33bdce26495121cdbce30331ef90a1969126a840Liam O'ReillygetArguments [] args = ([], args)
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy GimblettgetArguments (t:rt) args =
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder let trm : restArgs = getArgument t args
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder (nextTrms, finalArgs) = getArguments rt restArgs
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly in (trm:nextTrms, finalArgs)
fd4ad12563262ebe380d810df8f7755cfab5fb42Liam O'ReillytoAppl :: GlobalAnnos -> PState Term -> Term
33bdce26495121cdbce30331ef90a1969126a840Liam O'ReillytoAppl g s = let i = ruleId s in
816c50f9135a598dfdcfb2af8a80390bc42a9b24Liam O'Reilly if isListId i then
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly let Id _ [f] _ = i
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy Gimblett ListCons b c = getLiteralType g f
fd4ad12563262ebe380d810df8f7755cfab5fb42Liam O'Reilly (b1, _, _) = getListBrackets b
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly cl = length $ getPlainTokenList b
816c50f9135a598dfdcfb2af8a80390bc42a9b24Liam O'Reilly nb1 = length b1
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly ra = reverse $ ruleArgs s
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy Gimblett na = length ra
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder br = reverse $ posList s
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder nb = length br
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder mkList [] ps = asAppl c [] (head ps)
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder mkList (hd:tl) ps = asAppl f [hd, mkList tl (tail ps)] (head ps)
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder in if null ra then asAppl c []
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder (if null br then nullPos else head br)
816c50f9135a598dfdcfb2af8a80390bc42a9b24Liam O'Reilly else if nb + 2 == cl + na then
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly let br1 = drop (nb1 - 1) br
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy Gimblett in mkList ra br1
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder else error "toAppl"
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder else stateToAppl s
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederasAppl :: Id -> [Term] -> Pos -> Term
816c50f9135a598dfdcfb2af8a80390bc42a9b24Liam O'ReillyasAppl f args p = let pos = if null args then [] else [p]
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly in ApplTerm (QualOp (InstOpId f [] [])
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy Gimblett (simpleTypeScheme $ MixfixType [])
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder []) (TupleTerm args []) pos
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder-- precedence graph stuff
816c50f9135a598dfdcfb2af8a80390bc42a9b24Liam O'ReillycheckArg :: GlobalAnnos -> AssocEither -> Id -> Id -> Bool
33bdce26495121cdbce30331ef90a1969126a840Liam O'ReillycheckArg g dir op arg =
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder then isAssoc dir (assoc_annos g) op || not (isInfix op)
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder case precRel (prec_annos g) op arg of
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder Lower -> True
816c50f9135a598dfdcfb2af8a80390bc42a9b24Liam O'Reilly Higher -> False
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly BothDirections -> False
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy Gimblett NoDirection -> not $ isInfix arg
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian MaedercheckAnyArg :: GlobalAnnos -> Id -> Id -> Bool
842ae753ab848a8508c4832ab64296b929167a97Christian MaedercheckAnyArg g op arg =
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder case precRel (prec_annos g) op arg of
816c50f9135a598dfdcfb2af8a80390bc42a9b24Liam O'Reilly BothDirections -> isInfix op && op == arg
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian MaederisLeftArg, isRightArg :: Id -> Int -> Bool
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian MaederisLeftArg (Id ts _ _) n = n + 1 == (length $ takeWhile isPlace ts)
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederisRightArg (Id ts _ _) n = n == (length $ filter isPlace ts) -
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly (length $ takeWhile isPlace (reverse ts))
33bdce26495121cdbce30331ef90a1969126a840Liam O'ReillyfilterByPrec :: GlobalAnnos -> Id -> PState a -> Bool
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy GimblettfilterByPrec g argIde
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder PState { ruleId = opIde, ruleArgs = args, restRule = ts } =
fd4ad12563262ebe380d810df8f7755cfab5fb42Liam O'Reilly if null ts then False else
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder if head ts == termTok then
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder if isListId opIde || isListId argIde || opIde == applId then True
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder else let n = length args in
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly if isLeftArg opIde n then
816c50f9135a598dfdcfb2af8a80390bc42a9b24Liam O'Reilly if isPostfix opIde && (isPrefix argIde
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly || isInfix argIde) then False
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy Gimblett else checkArg g ALeft opIde argIde
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder else if isRightArg opIde n then
fd4ad12563262ebe380d810df8f7755cfab5fb42Liam O'Reilly if isPrefix opIde && isInfix argIde then False
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly else checkArg g ARight opIde argIde
fd4ad12563262ebe380d810df8f7755cfab5fb42Liam O'Reilly else checkAnyArg g opIde argIde
5858e6262048894b0e933b547852f04aed009b58Andy GimblettexpandType :: TypeMap -> Type -> Type
842ae753ab848a8508c4832ab64296b929167a97Christian MaederexpandType tm oldT =
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly TypeName _ _ _ -> fst $ expandAlias tm oldT
816c50f9135a598dfdcfb2af8a80390bc42a9b24Liam O'Reilly KindedType t _ _ -> t
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly LazyType t _ -> t
fd4ad12563262ebe380d810df8f7755cfab5fb42Liam O'ReillyaddArgState :: a -> PState a -> PState a
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederaddArgState arg op = op { ruleArgs = arg : ruleArgs op }
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederfilterByType :: TypeMap -> (Type, a) -> PState a -> Maybe (PState a)
33bdce26495121cdbce30331ef90a1969126a840Liam O'ReillyfilterByType tm argState@(_, argTerm) opState =
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy Gimblett case expandType tm $ ruleType opState of
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder FunType t1 _ t2 _ ->
5a859092c242b0e37183a44c3c79479125b2920aChristian Maeder filterByArgument tm t1 [] t2 argState opState
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder TypeName _ _ v -> if v == 0 then Nothing
5a859092c242b0e37183a44c3c79479125b2920aChristian Maeder else Just $ addArgState argTerm opState
33bdce26495121cdbce30331ef90a1969126a840Liam O'ReillyfilterByArgument :: TypeMap -> Type -> [Type] -> Type -> (Type, a)
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy Gimblett -> PState a -> Maybe (PState a)
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian MaederfilterByArgument tm t1 tl t2 argState@(argType, argTerm) opState =
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder let ms = maybeResult $ unify tm t1 argType in
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder case expandType tm t1 of
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder ProductType (t:ts) _ -> filterByArgument tm t
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder (ts++tl) t2 argState opState
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly Just s -> let newType = subst s $ foldr
7cbbd12f559c5c700f521a52424b098db198f1b4Liam O'Reilly ( \ t ty -> FunType t PFunArr ty []) t2 tl
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly in return $ addArgState argTerm opState
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly {ruleType = newType}
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederfilterByResultType :: TypeMap -> Type -> PState a -> Maybe (PState a)
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederfilterByResultType tm ty p =
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder do let rt = ruleType p
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder s <- maybeResult $ unify tm ty rt
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder return p { ruleType = subst s rt }