lex-pass transformer: Fix paren concat

FixParenConcat.hs

module Transf.FixParenConcat where

import Lang.Php
import TransfUtil
import Text.ParserCombinators.Parsec.Expr
import qualified Data.Intercal as IC
import Debug.Trace

transfs :: [Transf]
transfs = [
  "fix-paren-concat" -:- ftype -?-
  "(a OP1 b) OP2 c => a OP1 b OP2 c"
  -=- argless (lexPass $ fixParenConcat)]

fixParenConcat :: Ast -> Transformed Ast
fixParenConcat =
    modAll $ \ cNode ->
	case cNode of
	  (ExprBinOp
	   op1
	   (ExprParen (WSCap {
			 wsCapPre = _
		       , wsCapMain = ExprBinOp op2 a b c
		       , wsCapPost = _
		       }))
	   d e) -> if allowTransform op2 op1 then
		       pure $ ExprBinOp op1 (ExprBinOp op2 a b c) d e
		   else
		       transfNothing
	  _ -> transfNothing

-- Allow the transformation of (a OP1 b) OP2 c to a OP1 b OP2 c if:
--  1) OP1 and OP2 are left-associative
--  2) OP1 has higher or the same precedence as OP2
--  3) If the result of OP1 and OP2 has the same "type"
allowTransform :: BinOp -> BinOp -> Bool
allowTransform b b' = isLA b && isLA b'
		      && prio b <= prio b'
		      && getType b == getType b'

prio :: BinOp -> Int
prio b = case elemIndex True (map (\lvl -> b `elem` lvl) opers) of
     Just l -> l

isLA :: BinOp -> Bool
isLA b = b `elem` concat opers

getType :: BinOp -> String
getType b = case elemIndex True (map (\(t, ops) -> b `elem` ops) typesTable) of
	      Just t -> fst $ typesTable !! t

opers :: [[BinOp]]
opers = [
 [BByable BMul, BByable BDiv, BByable BMod],
 [BByable BPlus, BByable BMinus, BByable BConcat],
 [BByable BShiftL, BByable BShiftR],
 [BByable BBitAnd],
 [BByable BXor],
 [BByable BBitOr],
 [BAnd],
 [BOr],
 [BAndWd],
 [BXorWd],
 [BOrWd]]

typesTable :: [(String, [BinOp])]
typesTable = [
 ("num", [BByable BBitOr, BByable BXor, BByable BBitAnd, BByable
	  BShiftL, BByable BShiftR, BByable BMinus, BByable BPlus,
	  BByable BMod, BByable BDiv, BByable BMul]),
 ("bool", [BXorWd, BAnd, BOr, BAndWd, BOrWd]),
 ("string", [BByable BConcat])]