module FrontEnd.Infix (buildFixityMap, infixHsModule, FixityMap,size, infixStatement, restrictFixityMap) where
import Data.Binary
import Data.Monoid
import qualified Data.Map as Map
import FrontEnd.HsSyn
import Name.Name
import Support.MapBinaryInstance
import Util.HasSize
type FixityInfo = (Int, HsAssoc)
type SymbolMap = Map.Map Name FixityInfo
newtype FixityMap = FixityMap SymbolMap
deriving(Monoid,HasSize)
instance Binary FixityMap where
put (FixityMap ts) = putMap ts
get = fmap FixityMap getMap
restrictFixityMap :: (Name -> Bool) -> FixityMap -> FixityMap
restrictFixityMap f (FixityMap fm) = FixityMap (Map.filterWithKey (\k _ -> f k) fm)
syn_err_msg :: String
syn_err_msg = "Syntax error in input, run through a compiler to check.\n"
syn_err_bad_oparg op exp = syn_err_msg ++ "\tERROR: cannot apply " ++ show op
++ " to the expression: " ++ show exp
syn_err_precedence op exp = syn_err_msg ++ "\tERROR: the precedence of " ++ show op
++ " is incompatible with the precendence of it's argument: " ++ show exp
defaultFixity :: (Int, HsAssoc)
defaultFixity = (9, HsAssocLeft)
terminalFixity :: (Int, HsAssoc)
terminalFixity = (10, HsAssocLeft)
infixHsModule :: FixityMap -> HsModule -> HsModule
infixHsModule (FixityMap ism) m = hsModuleDecls_u f m where
f = map (processDecl ism)
infixStatement :: FixityMap -> HsStmt -> HsStmt
infixStatement (FixityMap ism) m = processStmt ism m
buildFixityMap :: [HsDecl] -> FixityMap
buildFixityMap ds = FixityMap (Map.fromList $ concatMap f ds) where
f (HsInfixDecl _ assoc strength names) = zip (map make_key names) $ repeat (strength,assoc)
f _ = []
make_key = fromValishHsName
lookupSM infixMap exp = case exp of
HsAsPat _ e -> lookupSM infixMap e
HsVar qname -> Map.findWithDefault defaultFixity (toName Val qname) infixMap
HsCon qname -> Map.findWithDefault defaultFixity (toName DataConstructor qname) infixMap
_ -> error $ "Operator (" ++ show exp ++ ") is invalid."
processDecl :: SymbolMap -> HsDecl -> HsDecl
processDecl infixMap decl = case decl of
HsClassDecl srcloc qualtype decls -> HsClassDecl srcloc qualtype $ proc_decls decls
HsInstDecl srcloc qualtype decls -> HsInstDecl srcloc qualtype $ proc_decls decls
HsFunBind matches -> HsFunBind $ map (processMatch infixMap) matches
HsPatBind srcloc pat rhs decls -> HsPatBind srcloc (procPat infixMap pat) (processRhs infixMap rhs) $ proc_decls decls
HsPragmaRules rs -> HsPragmaRules $ map proc_rule rs
_ -> decl
where
proc_decls decls = map (processDecl infixMap) decls
proc_rule prules@HsRule { hsRuleLeftExpr = e1, hsRuleRightExpr = e2} =
prules { hsRuleLeftExpr = fst $ processExp infixMap e1, hsRuleRightExpr = fst $ processExp infixMap e2 }
processMatch :: SymbolMap -> HsMatch -> HsMatch
processMatch infixMap (HsMatch srcloc qname pats rhs decls) =
HsMatch srcloc qname (map (procPat infixMap) pats) new_rhs new_decls
where
new_rhs = processRhs infixMap rhs
new_decls = map (processDecl infixMap) decls
processRhs :: SymbolMap -> HsRhs -> HsRhs
processRhs infixMap rhs = case rhs of
HsUnGuardedRhs exp -> HsUnGuardedRhs $ fst $ processExp infixMap exp
HsGuardedRhss rhss -> HsGuardedRhss $ map (processGRhs infixMap) rhss
processGRhs :: SymbolMap -> HsGuardedRhs -> HsGuardedRhs
processGRhs infixMap (HsGuardedRhs srcloc e1 e2) = HsGuardedRhs srcloc new_e1 new_e2
where
new_e1 = fst $ processExp infixMap e1
new_e2 = fst $ processExp infixMap e2
processAlt :: SymbolMap -> HsAlt -> HsAlt
processAlt infixMap (HsAlt srcloc pat g_alts decls) = HsAlt srcloc (procPat infixMap pat) new_g_alts new_decls
where
new_g_alts = processGAlts infixMap g_alts
new_decls = map (processDecl infixMap) decls
processGAlts :: SymbolMap -> HsRhs -> HsRhs
processGAlts infixMap g_alts = case g_alts of
HsUnGuardedRhs exp -> HsUnGuardedRhs $ fst $ processExp infixMap exp
HsGuardedRhss galts -> HsGuardedRhss $ map (processGAlt infixMap) galts
processGAlt :: SymbolMap -> HsGuardedRhs -> HsGuardedRhs
processGAlt infixMap (HsGuardedRhs srcloc e1 e2) = HsGuardedRhs srcloc new_e1 new_e2
where
new_e1 = fst $ processExp infixMap e1
new_e2 = fst $ processExp infixMap e2
processStmt :: SymbolMap -> HsStmt -> HsStmt
processStmt infixMap stmt = case stmt of
HsGenerator srcloc pat exp -> HsGenerator srcloc (procPat infixMap pat) $ fst $ processExp infixMap exp
HsQualifier exp -> HsQualifier $ fst $ processExp infixMap exp
HsLetStmt decls -> HsLetStmt $ map (processDecl infixMap) decls
processFUpdt :: SymbolMap -> HsFieldUpdate -> HsFieldUpdate
processFUpdt infixMap (HsFieldUpdate qname exp) = HsFieldUpdate qname new_exp
where
new_exp = fst $ processExp infixMap exp
procPat sm p = fst $ processPat sm p
processPat :: SymbolMap -> HsPat -> (HsPat, FixityInfo)
processPat infixMap exp = case exp of
HsPInfixApp l op r ->
case (compare l_power op_power) of
GT -> (HsPInfixApp new_l op new_r, op_fixity)
EQ -> case op_assoc of
HsAssocNone -> error_precedence op new_l
HsAssocRight -> case l_assoc of
HsAssocRight -> case new_l of
HsPInfixApp l' op' r' -> (HsPInfixApp l' op' (process_r' r'), l_fixity)
_ -> error_syntax op new_l
_ -> error_precedence op new_l
HsAssocLeft -> case l_assoc of
HsAssocLeft -> (HsPInfixApp new_l op new_r, op_fixity)
_ -> error_precedence op new_l
LT -> case new_l of
HsPInfixApp l' op' r' -> (HsPInfixApp l' op' (process_r' r'), l_fixity)
_ -> error_syntax op new_l
where
(new_l, l_fixity) = processPat infixMap l
l_power = fst l_fixity
l_assoc = snd l_fixity
op_fixity = Map.findWithDefault defaultFixity (toName DataConstructor op) infixMap
op_power = fst op_fixity
op_assoc = snd op_fixity
new_r = processExp' r
process_r' r' = processExp' $ HsPInfixApp r' op r
error_precedence err_op err_lower = error $ syn_err_precedence err_op err_lower
error_syntax err_op err_lower = error $ syn_err_bad_oparg err_op err_lower
x@HsPVar {} -> (x,terminalFixity)
x@HsPLit {} -> (x,terminalFixity)
x@HsPWildCard -> (x,terminalFixity)
HsPNeg p -> tf $ HsPNeg (pp p)
HsPIrrPat p -> tf $ HsPIrrPat (fmap pp p)
HsPBangPat p -> tf $ HsPBangPat (fmap pp p)
HsPApp n xs -> tf $ HsPApp n (map pp xs)
HsPTuple xs -> tf $ HsPTuple (map pp xs)
HsPUnboxedTuple xs -> tf $ HsPUnboxedTuple (map pp xs)
HsPList xs -> tf $ HsPList (map pp xs)
HsPParen xs -> tf $ HsPParen (pp xs)
HsPRec n xs -> tf $ HsPRec n [ HsPFieldPat n (pp p) | HsPFieldPat n p <- xs ]
HsPAsPat n p -> tf $ HsPAsPat n (pp p)
HsPTypeSig sl p qt -> tf $ HsPTypeSig sl (pp p) qt
where
processExp' = fst . (processPat infixMap)
pp = fst . (processPat infixMap)
tf x = (x,terminalFixity)
processExp :: SymbolMap -> HsExp -> (HsExp, FixityInfo)
processExp infixMap exp = case exp of
HsInfixApp l op r ->
case (compare l_power op_power) of
GT -> (HsInfixApp new_l op new_r, op_fixity)
EQ -> case op_assoc of
HsAssocNone -> error_precedence op new_l
HsAssocRight -> case l_assoc of
HsAssocRight -> case new_l of
HsInfixApp l' op' r' -> (HsInfixApp l' op' (process_r' r'), l_fixity)
_ -> error_syntax op new_l
_ -> error_precedence op new_l
HsAssocLeft -> case l_assoc of
HsAssocLeft -> (HsInfixApp new_l op new_r, op_fixity)
_ -> error_precedence op new_l
LT -> case new_l of
HsInfixApp l' op' r' -> (HsInfixApp l' op' (process_r' r'), l_fixity)
_ -> error_syntax op new_l
where
(new_l, l_fixity) = processExp infixMap l
l_power = fst l_fixity
l_assoc = snd l_fixity
op_fixity = lookupSM infixMap op
op_power = fst op_fixity
op_assoc = snd op_fixity
new_r = processExp' r
process_r' r' = processExp' $ HsInfixApp r' op r
error_precedence err_op err_lower = error $ syn_err_precedence err_op err_lower
error_syntax err_op err_lower = error $ syn_err_bad_oparg err_op err_lower
HsApp e1 e2 -> (HsApp (processExp' e1) (processExp' e2), terminalFixity)
HsNegApp e1 -> (HsNegApp (processExp' e1), terminalFixity)
HsLet decls e1 -> (HsLet (map (processDecl infixMap) decls) (processExp' e1), terminalFixity)
HsIf e1 e2 e3 -> (HsIf (processExp' e1) (processExp' e2) (processExp' e3), terminalFixity)
HsCase e1 alts -> (HsCase (processExp' e1) (map (processAlt infixMap) alts), terminalFixity)
HsDo stmts -> (HsDo (map (processStmt infixMap) stmts), terminalFixity)
HsTuple exps -> (HsTuple (map processExp' exps), terminalFixity)
HsUnboxedTuple exps -> (HsUnboxedTuple (map processExp' exps), terminalFixity)
HsList exps -> (HsList (map processExp' exps), terminalFixity)
HsParen e1 -> (HsParen (processExp' e1), terminalFixity)
HsEnumFrom e1 -> (HsEnumFrom (processExp' e1), terminalFixity)
HsEnumFromTo e1 e2 -> (HsEnumFromTo (processExp' e1) (processExp' e2), terminalFixity)
HsListComp e1 stmts ->
(HsListComp (processExp' e1) (map (processStmt infixMap) stmts), terminalFixity)
HsAsPat name e1 -> (HsAsPat name (processExp' e1), terminalFixity)
HsIrrPat e1 -> (HsIrrPat (fmap processExp' e1), terminalFixity)
HsBangPat e1 -> (HsBangPat (fmap processExp' e1), terminalFixity)
HsLeftSection e1 e2 -> (HsLeftSection e1 (processExp' e2), terminalFixity)
HsRightSection e1 e2 -> (HsRightSection (processExp' e1) e2, terminalFixity)
HsLambda srcloc pats e1 -> (HsLambda srcloc (map (procPat infixMap) pats) (processExp' e1), terminalFixity)
HsRecConstr qname f_updts -> (HsRecConstr qname (map (processFUpdt infixMap) f_updts), terminalFixity)
HsEnumFromThen e1 e2 -> (HsEnumFromThen (processExp' e1) (processExp' e2), terminalFixity)
HsRecUpdate e1 f_updts ->
(HsRecUpdate (processExp' e1) (map (processFUpdt infixMap) f_updts), terminalFixity)
HsEnumFromThenTo e1 e2 e3 ->
(HsEnumFromThenTo (processExp' e1) (processExp' e2) (processExp' e3), terminalFixity)
HsExpTypeSig srcloc e1 qtype -> (HsExpTypeSig srcloc (processExp' e1) qtype, terminalFixity)
_ -> (exp, terminalFixity)
where
processExp' = fst . (processExp infixMap)