Skip to content
This repository
tree: 882a5d9332
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 155 lines (136 sloc) 5.543 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
module Lang.Php.Transf where

import Control.Applicative
import Lang.Php.Ast
import Lang.Php.Ast.Common
import Lang.Php.Ast.Stmt
import Lang.Php.Ast.StmtTypes
import LexPassUtil
import Numeric
import qualified Data.Intercal as IC

-- ignores single-statement if/etc blocks currently
-- (we _could_ convert them out of single-statement-ness on change)
modAllStmts :: (WS -> Stmt -> WS -> Transformed StmtList) ->
  StmtList -> Transformed StmtList
modAllStmts f = modIntercal $ \ wsPre s wsPost -> case f wsPre s wsPost of
  t@(Transformed {transfResult = Just _}) -> t
  (Transformed {infoLines = ls}) -> single <$> t' where
    t' = t {infoLines = ls ++ infoLines t}
    t = case s of
      StmtDoWhile (x@DoWhile {doWhileBlock = WSCap w1 (Right block) w2}) ->
        (\ a -> StmtDoWhile $ x {doWhileBlock = WSCap w1 (Right a) w2}) <$>
        doBlock block
      StmtFuncDef x ->
        (\ a -> StmtFuncDef $ x {funcBlock = a}) <$> doBlock (funcBlock x)
      StmtFor (x@(For {forBlock = Right block})) -> StmtFor .
        (\ a -> x {forBlock = Right a}) <$> doBlock block
      StmtForeach (x@Foreach {foreachBlock = Right block}) -> StmtForeach .
        (\ a -> x {foreachBlock = Right a}) <$> doBlock block
      StmtIf (If isColon ifAndIfelses theElse) -> StmtIf <$> liftA2
        (If isColon) (IC.mapA ifery pure ifAndIfelses) (elsery theElse)
        where
        ifery (x@(IfBlock {ifBlockBlock = Right block})) =
          (\ a -> x {ifBlockBlock = Right a}) <$> doBlock block
        ifery other = pure other
        elsery (Just (ws, Right block)) =
          (\ a -> Just (ws, Right a)) <$> doBlock block
        elsery other = pure other
      StmtSwitch x -> StmtSwitch . (\ a -> x {switchCases = a}) <$>
        modMap doCase (switchCases x)
      _ -> transfNothing
    doBlock (Block stmtList) = Block <$> modAllStmts f stmtList
    doCase x = (\ a -> x {caseStmtList = a}) <$> modAllStmts f (caseStmtList x)
    single x = IC.singleton wsPre x wsPost

modIfBlockExpr :: (WSCap2 Expr -> Transformed (WSCap2 Expr)) ->
  IfBlock -> Transformed IfBlock
modIfBlockExpr t (IfBlock expr block) = flip IfBlock block <$> t expr

modWSCap :: (a -> Transformed a) -> WSCap a -> Transformed (WSCap a)
modWSCap t (WSCap w1 a w2) = (\ b -> WSCap w1 b w2) <$> t a

modWSCap2 :: (a -> Transformed a) -> WSCap2 a -> Transformed (WSCap2 a)
modWSCap2 = modWSCap . modWSCap

lastIndent :: WS -> WS2
lastIndent [] = ([], [])
lastIndent ws = case wsTail of
  WS s ->
    (wsInit ++ wsTokLIfNotNull sMost, wsTokLIfNotNull sAfterLastLine)
    where
    (sMost, sAfterLastLine) = reversifyTup (span (/= '\n')) s
    wsTokLIfNotNull [] = []
    wsTokLIfNotNull x = [WS x]
  _ -> (ws, [])
  where
  (wsTail:wsInitRev) = reverse ws
  wsInit = reverse wsInitRev

lastLine :: WS -> WS
lastLine ws = case lastIndent ws of
  (_, [WS s]) -> [WS $ '\n':s]
  _ -> [WS "\n"]

onWSCap1 :: (WS -> WS) -> WSCap a -> WSCap a
onWSCap1 f (WSCap w1 a w2) = WSCap (f w1) a w2

onWSCap2 :: (WS -> WS) -> WSCap a -> WSCap a
onWSCap2 f (WSCap w1 a w2) = WSCap w1 a (f w2)

wsStartTransfer :: WS -> WS -> WS
wsStartTransfer a b = takeWhile wsElemIsWS a ++ dropWhile wsElemIsWS b

wsElemIsWS :: WSElem -> Bool
wsElemIsWS (WS _) = True
wsElemIsWS _ = False

strToUnits :: String -> (Bool, [String])
strToUnits ('"':rest) = (,) True . strDubToUnits $ init rest
  where
  strDubToUnits ('\\':c:rest) =
    if c `elem` "nrtv\"\\$"
      then ('\\':[c]) : strDubToUnits rest
      else
        if c == 'x'
          then
            let (ds, rest') = spanUpToN 2 isHexDigit rest in
            ('\\':c:ds) : strDubToUnits rest'
          else
            if isOctDigit c
              then
                let (ds, rest') = spanUpToN 2 isOctDigit rest in
                ('\\':c:ds) : strDubToUnits rest'
              else "\\" : [c] : strDubToUnits rest
  strDubToUnits (c:rest) = [c] : strDubToUnits rest
  strDubToUnits [] = []
strToUnits ('\'':rest) = (,) False . strSingToUnits $ init rest
  where
  strSingToUnits ('\\':'\\':rest) = "\\" : strSingToUnits rest
  strSingToUnits ('\\':'\'':rest) = "'" : strSingToUnits rest
  strSingToUnits (c:rest) = [c] : strSingToUnits rest
  strSingToUnits [] = []

spanUpToN :: Int -> (a -> Bool) -> [a] -> ([a], [a])
spanUpToN 0 _ a = ([], a)
spanUpToN _ f [] = ([], [])
spanUpToN n f a@(x:l) =
  if f x then first (x :) $ spanUpToN (n - 1) f l else ([], a)

strUnitsToStr :: (Bool, [String]) -> String
strUnitsToStr (isDub, s) = [q] ++ concat s ++ [q] where
  q = if isDub then '"' else '\''

-- i.e. "\lol" -> "\\lol"
normalizeStrUnit :: String -> String
normalizeStrUnit "\\" = "\\\\"
normalizeStrUnit ('\\':'X':rest) = normalizeStrUnit ('\\':'x':rest)
normalizeStrUnit ('\\':'x':rest) = "\\x" ++ map toUpper rest
normalizeStrUnit c = c

-- note: only works on normalized str units
regexUnits :: [String] -> (Int, ([[String]], [String]))
regexUnits (c:rest) = (i, regexUnitsDelim i rest) where
  i = phpOrd c
  regexUnitsDelim :: Int -> [String] -> ([[String]], [String])
  regexUnitsDelim delim (b@"\\\\":u:rest) =
    first ([b, u] :) $ regexUnitsDelim delim rest
  regexUnitsDelim delim (u:rest) =
    if phpOrd u == delim
      then ([], rest)
      else first ([u] :) $ regexUnitsDelim delim rest
  regexUnitsDelim _ [] = ([], [])

phpOrd :: String -> Int
phpOrd "\\t" = ord '\t'
phpOrd "\\n" = ord '\n'
phpOrd "\\v" = ord '\v'
phpOrd "\\r" = ord '\r'
phpOrd "\\$" = ord '$'
phpOrd "\\\\" = ord '\\'
phpOrd [c] = ord c
phpOrd ('\\':'x':rest) = fst . head $ readHex rest
phpOrd ('\\':rest) = fst . head $ readOct rest

Something went wrong with that request. Please try again.