MixParserState.hs revision 441b53bd9480b058a6a8be774a5b8a37881f4b8b
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder{- |
bb83db66bd9b3b4ce67be66419daf29886175276Andy GimblettModule : $Header$
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederCopyright : (c) Christian Maeder and Uni Bremen 2003
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder
98890889ffb2e8f6f722b00e265a211f13b5a861Corneliu-Claudiu ProdescuMaintainer : hets@tzi.de
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus RoggenbachStability : experimental
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederPortability : portable
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbachspecial parsing states for the mixfix analysis of terms
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach
bb83db66bd9b3b4ce67be66419daf29886175276Andy Gimblett-}
bb83db66bd9b3b4ce67be66419daf29886175276Andy Gimblett
78718c37b1a50086a27e0f031db4cf82bea934aeChristian Maedermodule HasCASL.MixParserState where
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbachimport HasCASL.As
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbachimport HasCASL.Le
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbachimport Common.AS_Annotation
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbachimport Common.GlobalAnnotations
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maederimport Common.GlobalAnnotationsFunctions
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maederimport Common.Result
5cc369fbceee1b13bd0f06e43620c46541d1d4f8Christian Maederimport Common.Id
dfc58f5ec6492d1a9b9babd9cdcdbb15baa6e657Christian Maederimport Common.PrettyPrint
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbachimport qualified Common.Lib.Map as Map
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maederimport qualified Common.Lib.Set as Set
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maederimport Common.Lib.State
842ae753ab848a8508c4832ab64296b929167a97Christian Maederimport Data.Maybe
1538a6e8d77301d6de757616ffc69ee61f1482e4Andy Gimblettimport HasCASL.Unify
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach-- avoid confusion with the variable counter Int
70a691ea12f53381209a3709cdd325df5fc0a0c8Christian Maedernewtype Index = Index Int deriving (Eq, Ord, Show)
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach
792df0347edab377785d98c63e2be8e2ce0a8bdeChristian Maeder-- deriving Num is also possible
2a5b885d9350ec6dd8bc4992ee91d2f68aa592f4Christian Maeder-- but the following functions are sufficient
0ea916d1e6aea10fd7b84f802fb5148a79d8c20aAndy GimblettstartIndex :: Index
04ceed96d1528b939f2e592d0656290d81d1c045Andy GimblettstartIndex = Index 0
d9e78002fb0bf01a9b72d3d3415fdf9790bdfee8Andy Gimblett
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly-- (also hiding (==) seems not possible)
9f93b2a8b552789cd939d599504d39732672dc84Christian MaederisStartIndex :: Index -> Bool
1538a6e8d77301d6de757616ffc69ee61f1482e4Andy GimblettisStartIndex = (== startIndex)
3b48e17c1da54ee669e70b626d9fbc32ce495b2cChristian Maeder
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'ReillyincrIndex :: Index -> Index
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'ReillyincrIndex (Index i) = Index (i + 1)
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder
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 Maeder }
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder
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 Maeder
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)
bcd914850de931848b86d7728192a149f9c0108bChristian Maeder
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian MaedertermStr :: String
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian MaedertermStr = "_"
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 ")"
bb83db66bd9b3b4ce67be66419daf29886175276Andy Gimblett
2f35e5f6757968746dbab385be21fcae52378a3fLiam O'ReillyopTok, inTok, caseTok :: Token
fbc0c2baf563fe5b664f0152674a8d3acecca58cAndy GimblettinTok = mkSimpleId "in"
31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimblettcaseTok = mkSimpleId "case"
e771539425f4a0abef9f94cf4b63690f3603f682Andy GimblettopTok = mkSimpleId "(o)"
e771539425f4a0abef9f94cf4b63690f3603f682Andy Gimblett
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]
d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett
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 }
d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett
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 case t1 of
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'Reilly
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
d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett
bb83db66bd9b3b4ce67be66419daf29886175276Andy GimblettlistToken :: Token
d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettlistToken = mkSimpleId "[]"
bb83db66bd9b3b4ce67be66419daf29886175276Andy GimblettlistId :: Id -> Id
4314e26a12954cb1c9be4dea10aa8103edac5bbbChristian Maeder-- unique id (usually "[]" yields two tokens)
e54c5af823b9775dd2c058185ea5bdf7593950faAndy GimblettlistId i = Id [listToken] [i] []
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly
d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy GimblettisListId :: Id -> Bool
d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy GimblettisListId (Id ts cs _) = not (null ts) && head ts == listToken && length cs == 1
d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett
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 ty toks
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 ) $ Set.toList lists
bb83db66bd9b3b4ce67be66419daf29886175276Andy Gimblett
d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett-- these are the possible matches for the nonterminal (T)
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder-- the same states are used for the predictions
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder
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 Maeder
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'Reilly
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'Reilly
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly
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
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'Reilly
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 $ Map.toList as
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 [unitId,
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly inId,
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly opId]
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly return (a:p:t:ls ++ l1 ++ l2 ++ l3)
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly
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 []) []
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 }]
d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy Gimblett
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder-- construct resulting term from PState
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly
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
e95030058b77cb83593c85aa4c506caf154f63b7Andy Gimblett || r == opId
bb83db66bd9b3b4ce67be66419daf29886175276Andy Gimblett then head ar
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 Maeder
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederexpandArgument :: Term -> [Term]
e8c03c10d7987b223a9f6bfd5c0c54da21da5b86Andy GimblettexpandArgument arg =
bb83db66bd9b3b4ce67be66419daf29886175276Andy Gimblett case arg of
fbc0c2baf563fe5b664f0152674a8d3acecca58cAndy Gimblett TupleTerm ts _ -> concatMap expandArgument ts
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder _ -> [arg]
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederaddFunArguments :: (Type, Term) -> [Term] -> Term
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederaddFunArguments (ty, trm) args =
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder if null args then trm else
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder case ty of
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"
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder
06a77f038c0e1740672274377901d37d0113226dLiam O'ReillygetArgument :: Type -> [Term] -> [Term]
816c50f9135a598dfdcfb2af8a80390bc42a9b24Liam O'ReillygetArgument ty args =
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly case ty of
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"
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy Gimblett else args
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder
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)
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy Gimblett
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
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder
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
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder-- precedence graph stuff
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder
816c50f9135a598dfdcfb2af8a80390bc42a9b24Liam O'ReillycheckArg :: GlobalAnnos -> AssocEither -> Id -> Id -> Bool
33bdce26495121cdbce30331ef90a1969126a840Liam O'ReillycheckArg g dir op arg =
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy Gimblett if arg == op
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder then isAssoc dir (assoc_annos g) op || not (isInfix op)
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder else
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 Maeder
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
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly _ -> True
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy Gimblett
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian MaederisLeftArg, isRightArg :: Id -> Int -> Bool
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian MaederisLeftArg (Id ts _ _) n = n + 1 == (length $ takeWhile isPlace ts)
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederisRightArg (Id ts _ _) n = n == (length $ filter isPlace ts) -
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly (length $ takeWhile isPlace (reverse ts))
816c50f9135a598dfdcfb2af8a80390bc42a9b24Liam O'Reilly
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
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder else False
5858e6262048894b0e933b547852f04aed009b58Andy Gimblett
5858e6262048894b0e933b547852f04aed009b58Andy GimblettexpandType :: TypeMap -> Type -> Type
842ae753ab848a8508c4832ab64296b929167a97Christian MaederexpandType tm oldT =
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder case oldT of
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly TypeName _ _ _ -> fst $ expandAlias tm oldT
816c50f9135a598dfdcfb2af8a80390bc42a9b24Liam O'Reilly KindedType t _ _ -> t
33bdce26495121cdbce30331ef90a1969126a840Liam O'Reilly LazyType t _ -> t
d04c328b10f17ec78001a94d694f7188ebd8c03cAndy Gimblett _ -> oldT
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder
fd4ad12563262ebe380d810df8f7755cfab5fb42Liam O'ReillyaddArgState :: a -> PState a -> PState a
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederaddArgState arg op = op { ruleArgs = arg : ruleArgs op }
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder
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
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder _ -> Nothing
816c50f9135a598dfdcfb2af8a80390bc42a9b24Liam O'Reilly
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
2f35e5f6757968746dbab385be21fcae52378a3fLiam O'Reilly case ms of
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder Nothing ->
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder case expandType tm t1 of
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder ProductType (t:ts) _ -> filterByArgument tm t
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder (ts++tl) t2 argState opState
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder _ -> Nothing
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}
a09bfcbcb0fba5663fca1968aa82daebf2e092c4Andy Gimblett
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 }
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder