module Language.Haskell.Infix ( infixer
, insertTopInfixDecls
, InfixMap
, plusInfixMap
, Fixity (..)
, showInfixMap
, infixMapToList
, emptyInfixMap
) where
import Language.Haskell.Syntax
import Data.FiniteMap
data Fixity = Fixity { fixity_assoc :: HsAssoc,
fixity_prec :: Int }
deriving Show
type InfixMap = FiniteMap HsQName Fixity
plusInfixMap :: InfixMap -> InfixMap -> InfixMap
plusInfixMap = plusFM
emptyInfixMap :: InfixMap
emptyInfixMap = emptyFM
infixMapToList :: InfixMap -> [(HsQName, Fixity)]
infixMapToList = fmToList
showInfixMap :: InfixMap -> String
showInfixMap infixMap
= unlines $ map show mapList
where
mapList = infixMapToList infixMap
infixer :: InfixMap -> [HsDecl] -> [HsDecl]
infixer infixMap decls
= runInfix infixMap $ mapM infixDecl decls
defaultFixity :: Fixity
defaultFixity = Fixity { fixity_assoc = HsAssocLeft, fixity_prec = 9 }
data State = State { stateInfixMap :: InfixMap }
newtype Infix a = Infix (State -> (a, State))
instance Monad Infix where
return a
= Infix (\state -> (a, state))
Infix comp >>= fun
= Infix (\state ->
let (result, newState) = comp state
Infix comp' = fun result
in comp' newState)
runInfix :: InfixMap -> Infix a -> a
runInfix infixMap (Infix comp)
= result
where
(result, _newState) = comp (State {stateInfixMap = infixMap})
select :: (State -> a) -> Infix a
select selector = Infix (\state -> (selector state, state))
updateState :: (State -> State) -> Infix ()
updateState f = Infix (\state -> ((), f state))
getInfixMap :: Infix InfixMap
getInfixMap = select stateInfixMap
getFixityQOp :: HsQOp -> Infix Fixity
getFixityQOp op
= getFixityQName $ qNameFromQOp op
getFixityQName :: HsQName -> Infix Fixity
getFixityQName (Special HsCons)
= return $ Fixity {fixity_assoc = HsAssocRight, fixity_prec = 5}
getFixityQName name
= do infixMap <- getInfixMap
case lookupFM infixMap name of
Nothing -> return defaultFixity
Just fixity -> return fixity
updateInfixMap :: [HsDecl] -> Infix ()
updateInfixMap decls
= do oldInfixMap <- getInfixMap
let newInfixMap = insertLocalInfixDecls oldInfixMap decls
updateState (\state -> state {stateInfixMap = newInfixMap})
qNameFromQOp :: HsQOp -> HsQName
qNameFromQOp (HsQVarOp qName) = qName
qNameFromQOp (HsQConOp qName) = qName
nameFromOp :: HsOp -> HsName
nameFromOp (HsVarOp name) = name
nameFromOp (HsConOp name) = name
infixExp :: HsExp -> Infix HsExp
infixExp exp@(HsVar _) = return exp
infixExp exp@(HsCon _) = return exp
infixExp exp@(HsLit _) = return exp
infixExp exp@(HsInfixApp _ _ _)
= do infixList <- hsExpToInfixList exp
let eFix = opPrecParse HsInfixApp infixList
return eFix
infixExp (HsApp e1 e2)
= do e1Fix <- infixExp e1
e2Fix <- infixExp e2
return $ HsApp e1Fix e2Fix
infixExp (HsNegApp e)
= do eFix <- infixExp e
return $ HsNegApp eFix
infixExp (HsLambda sloc pats e)
= do patsFix <- mapM infixPat pats
eFix <- infixExp e
return $ HsLambda sloc patsFix eFix
infixExp (HsLet decls e)
= do updateInfixMap decls
eFix <- infixExp e
_ <- mapM infixDecl decls
return $ HsLet decls eFix
infixExp (HsIf e1 e2 e3)
= do e1Fix <- infixExp e1
e2Fix <- infixExp e2
e3Fix <- infixExp e3
return $ HsIf e1Fix e2Fix e3Fix
infixExp (HsCase e alts)
= do eFix <- infixExp e
altsFix <- mapM infixAlt alts
return $ HsCase eFix altsFix
infixExp (HsDo stmts)
= do stmtsFix <- mapM infixStmt stmts
return $ HsDo stmtsFix
infixExp (HsTuple exps)
= do expsFix <- mapM infixExp exps
return $ HsTuple expsFix
infixExp (HsList exps)
= do expsFix <- mapM infixExp exps
return $ HsList expsFix
infixExp (HsParen exp)
= do expFix <- infixExp exp
return $ HsParen expFix
infixExp (HsLeftSection e qop)
= do eFix <- infixExp e
return $ HsLeftSection eFix qop
infixExp (HsRightSection qop e)
= do eFix <- infixExp e
return $ HsRightSection qop eFix
infixExp (HsRecConstr qName fieldUpdates)
= do fixFieldUpdates <- mapM infixFieldUpdate fieldUpdates
return $ HsRecConstr qName fixFieldUpdates
infixExp (HsRecUpdate e fieldUpdates)
= do eFix <- infixExp e
fixFieldUpdates <- mapM infixFieldUpdate fieldUpdates
return $ HsRecUpdate eFix fixFieldUpdates
infixExp (HsEnumFrom e)
= do eFix <- infixExp e
return $ HsEnumFrom eFix
infixExp (HsEnumFromTo e1 e2)
= do e1Fix <- infixExp e1
e2Fix <- infixExp e2
return $ HsEnumFromTo e1Fix e2Fix
infixExp (HsEnumFromThen e1 e2)
= do e1Fix <- infixExp e1
e2Fix <- infixExp e2
return $ HsEnumFromThen e1Fix e2Fix
infixExp (HsEnumFromThenTo e1 e2 e3)
= do e1Fix <- infixExp e1
e2Fix <- infixExp e2
e3Fix <- infixExp e3
return $ HsEnumFromThenTo e1Fix e2Fix e3Fix
infixExp (HsListComp e stmts)
= do eFix <- infixExp e
stmtsFix <- mapM infixStmt stmts
return $ HsListComp eFix stmtsFix
infixExp (HsExpTypeSig sloc e qualType)
= do eFix <- infixExp e
return $ HsExpTypeSig sloc eFix qualType
infixExp (HsAsPat name e)
= do eFix <- infixExp e
return $ HsAsPat name eFix
infixExp HsWildCard = return HsWildCard
infixExp (HsIrrPat e)
= do eFix <- infixExp e
return $ HsIrrPat eFix
infixPat :: HsPat -> Infix HsPat
infixPat pat@(HsPVar _) = return pat
infixPat pat@(HsPLit _) = return pat
infixPat (HsPNeg pat)
= do pFix <- infixPat pat
return $ HsPNeg pFix
infixPat pat@(HsPInfixApp _ _ _)
= do infixList <- hsPatToInfixList pat
let pFix = opPrecParse HsPInfixApp infixList
return pFix
infixPat (HsPApp qName pats)
= do patsFix <- mapM infixPat pats
return $ HsPApp qName patsFix
infixPat (HsPTuple pats)
= do patsFix <- mapM infixPat pats
return $ HsPTuple patsFix
infixPat (HsPList pats)
= do patsFix <- mapM infixPat pats
return $ HsPList patsFix
infixPat (HsPParen pat)
= do pFix <- infixPat pat
return $ HsPParen pFix
infixPat (HsPRec qName patFields)
= do fieldsFix <- mapM infixPatField patFields
return $ HsPRec qName fieldsFix
infixPat (HsPAsPat name pat)
= do pFix <- infixPat pat
return $ HsPAsPat name pFix
infixPat HsPWildCard = return HsPWildCard
infixPat (HsPIrrPat pat)
= do pFix <- infixPat pat
return $ HsPIrrPat pFix
infixPatField :: HsPatField -> Infix HsPatField
infixPatField (HsPFieldPat qName pat)
= do pFix <- infixPat pat
return $ HsPFieldPat qName pFix
infixAlt :: HsAlt -> Infix HsAlt
infixAlt (HsAlt sloc pat guardedAlts decls)
= do pFix <- infixPat pat
fixAlts <- infixGuardedAlts guardedAlts
fixDecls <- mapM infixDecl decls
return $ HsAlt sloc pFix fixAlts fixDecls
infixGuardedAlts :: HsGuardedAlts -> Infix HsGuardedAlts
infixGuardedAlts (HsUnGuardedAlt e)
= do eFix <- infixExp e
return $ HsUnGuardedAlt eFix
infixGuardedAlts (HsGuardedAlts gAlts)
= do fixGAlts <- mapM infixGuardedAlt gAlts
return $ HsGuardedAlts fixGAlts
infixGuardedAlt :: HsGuardedAlt -> Infix HsGuardedAlt
infixGuardedAlt (HsGuardedAlt sloc e1 e2)
= do e1Fix <- infixExp e1
e2Fix <- infixExp e2
return $ HsGuardedAlt sloc e1Fix e2Fix
infixStmt :: HsStmt -> Infix HsStmt
infixStmt (HsGenerator sloc pat e)
= do pFix <- infixPat pat
eFix <- infixExp e
return $ HsGenerator sloc pFix eFix
infixStmt (HsQualifier e)
= do eFix <- infixExp e
return $ HsQualifier eFix
infixStmt (HsLetStmt decls)
= do updateInfixMap decls
declsFix <- mapM infixDecl decls
return $ HsLetStmt declsFix
infixFieldUpdate :: HsFieldUpdate -> Infix HsFieldUpdate
infixFieldUpdate (HsFieldUpdate qName e)
= do eFix <- infixExp e
return $ HsFieldUpdate qName eFix
infixDecl :: HsDecl -> Infix HsDecl
infixDecl (HsFunBind matches)
= do fixMatches <- mapM infixMatch matches
return $ HsFunBind fixMatches
infixDecl (HsPatBind sloc pat rhs decls)
= do pFix <- infixPat pat
updateInfixMap decls
fixRhs <- infixRhs rhs
fixDecls <- mapM infixDecl decls
return $ HsPatBind sloc pFix fixRhs fixDecls
infixDecl (HsClassDecl sloc cntxt className args decls)
= do declsFix <- mapM infixDecl decls
return $ HsClassDecl sloc cntxt className args declsFix
infixDecl (HsInstDecl sloc cntxt className args decls)
= do declsFix <- mapM infixDecl decls
return $ HsInstDecl sloc cntxt className args declsFix
infixDecl otherDecl = return otherDecl
infixMatch :: HsMatch -> Infix HsMatch
infixMatch (HsMatch sloc name pats rhs decls)
= do patsFix <- mapM infixPat pats
updateInfixMap decls
fixRhs <- infixRhs rhs
fixDecls <- mapM infixDecl decls
return $ HsMatch sloc name patsFix fixRhs fixDecls
infixRhs :: HsRhs -> Infix HsRhs
infixRhs (HsUnGuardedRhs e)
= do eFix <- infixExp e
return $ HsUnGuardedRhs eFix
infixRhs (HsGuardedRhss rhss)
= do rhssFix <- mapM infixGuardedRhs rhss
return $ HsGuardedRhss rhssFix
infixGuardedRhs :: HsGuardedRhs -> Infix HsGuardedRhs
infixGuardedRhs (HsGuardedRhs sloc e1 e2)
= do e1Fix <- infixExp e1
e2Fix <- infixExp e2
return $ HsGuardedRhs sloc e1Fix e2Fix
insertLocalInfixDecls :: InfixMap -> [HsDecl] -> InfixMap
insertLocalInfixDecls imap [] = imap
insertLocalInfixDecls imap (HsInfixDecl _ assoc prec ops : decls)
= insertLocalInfixDecls (insertLocalOps thisFixity ops imap) decls
where
thisFixity = Fixity { fixity_assoc = assoc, fixity_prec = prec }
insertLocalOps :: Fixity -> [HsOp] -> InfixMap -> InfixMap
insertLocalOps _fixity [] imap = imap
insertLocalOps fixity (op:ops) infixMap
= let opName = nameFromOp op
map1 = addToFM infixMap (UnQual opName) fixity
in insertLocalOps fixity ops map1
insertLocalInfixDecls imap (_ : decls)
= insertLocalInfixDecls imap decls
insertTopInfixDecls :: Module -> InfixMap -> [HsDecl] -> InfixMap
insertTopInfixDecls _ imap [] = imap
insertTopInfixDecls modName imap (HsInfixDecl _ assoc prec ops : decls)
= insertTopInfixDecls modName (insertTopOps modName thisFixity ops imap) decls
where
thisFixity :: Fixity
thisFixity = Fixity { fixity_assoc = assoc, fixity_prec = prec }
insertTopOps :: Module -> Fixity -> [HsOp] -> InfixMap -> InfixMap
insertTopOps _ _fixity [] imap = imap
insertTopOps modName fixity (op:ops) infixMap
= let opName = nameFromOp op
map1 = addToFM infixMap (UnQual opName) fixity
map2 = addToFM map1 (Qual modName $ opName) fixity
in insertTopOps modName fixity ops map2
insertTopInfixDecls modName imap (HsClassDecl _sloc _cntxt _name _args classDecls : decls)
= insertTopInfixDecls modName (insertTopInfixDecls modName imap classDecls) decls
insertTopInfixDecls modName imap (_ : decls)
= insertTopInfixDecls modName imap decls
data InfixExp op arg
= Op op Fixity | Arg arg
deriving Show
hsExpToInfixList :: HsExp -> Infix [InfixExp HsQOp HsExp]
hsExpToInfixList exp
= hsExpToInfixAcc exp []
where
hsExpToInfixAcc :: HsExp -> [InfixExp HsQOp HsExp] -> Infix [InfixExp HsQOp HsExp]
hsExpToInfixAcc (HsInfixApp e1 op e2) acc
= do fixity <- getFixityQOp op
e2Fix <- infixExp e2
hsExpToInfixAcc e1 (Op op fixity : Arg e2Fix : acc)
hsExpToInfixAcc exp acc
= do eFix <- infixExp exp
return $ Arg eFix : acc
hsPatToInfixList :: HsPat -> Infix [InfixExp HsQName HsPat]
hsPatToInfixList pat
= hsPatToInfixAcc pat []
where
hsPatToInfixAcc :: HsPat -> [InfixExp HsQName HsPat] -> Infix [InfixExp HsQName HsPat]
hsPatToInfixAcc (HsPInfixApp p1 op p2) acc
= do fixity <- getFixityQName op
p2Fix <- infixPat p2
hsPatToInfixAcc p1 (Op op fixity : Arg p2Fix : acc)
hsPatToInfixAcc pat acc
= do pFix <- infixPat pat
return $ Arg pFix : acc
opPrecParse :: (arg -> op -> arg -> arg) -> [InfixExp op arg] -> arg
opPrecParse combiner exps
= reparseInfix combiner exps [] []
where
reparseInfix :: (arg -> op -> arg -> arg)
-> [InfixExp op arg]
-> [(op, Fixity)]
-> [arg]
-> arg
reparseInfix _combiner [] [] [arg] = arg
reparseInfix combiner [] ((op,_fixity):opStack) (a1:a2:argStack)
= reparseInfix combiner [] opStack (combiner a2 op a1 : argStack)
reparseInfix combiner (Arg a : args) opStack argStack
= reparseInfix combiner args opStack (a : argStack)
reparseInfix combiner (Op thisOp thisFixity : rest) [] argStack
= reparseInfix combiner rest [(thisOp,thisFixity)] argStack
reparseInfix combiner (Op thisOp thisFixity : rest) (topOpStack:opStack) (topArg1:topArg2:argStack)
| thisPrec > topPrec
= reparseInfix combiner rest ((thisOp,thisFixity):topOpStack:opStack)
(topArg1:topArg2:argStack)
| thisPrec < topPrec
= reparseInfix combiner (Op thisOp thisFixity : rest) opStack
(combiner topArg2 topOp topArg1 : argStack)
| otherwise
= case (thisAssoc, topAssoc) of
(HsAssocLeft, HsAssocLeft)
-> reparseInfix combiner (Op thisOp thisFixity : rest) opStack
(combiner topArg2 topOp topArg1 : argStack)
(HsAssocRight, HsAssocRight)
-> reparseInfix combiner rest ((thisOp,thisFixity):topOpStack:opStack)
(topArg1:topArg2:argStack)
_ -> error "Syntax error"
where
(topOp, topFixity) = topOpStack
topAssoc = fixity_assoc topFixity
topPrec = fixity_prec topFixity
thisAssoc = fixity_assoc thisFixity
thisPrec = fixity_prec thisFixity
reparseInfix _ _ _ _ = error "Syntax error"