Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: b651f7103c
Fetching contributors…

Cannot retrieve contributors at this time

file 207 lines (180 sloc) 6.877 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 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
module LexPassUtil where

import Common
import Control.Applicative
import Control.Arrow
import Control.Monad.State
import Data.Binary
import Data.Data
import Data.Generics
import Data.String
import FUtil
import HSH
import Lang.Php.Ast
import Options
import System.Directory
import System.FilePath
import System.IO
import System.Process
import qualified Data.Intercal as IC

import Text.Parsec.Prim(Parsec)

--
-- transf framework
--

data Transf = Transf {
  transfName :: String,
  transfTypes :: [String],
  transfDoc :: String,
  transfArgs :: String, -- unused currently
  transfFunc :: [String] -> Options -> FilePath -> FilePath -> Int -> Int ->
    CanErrStrIO (Bool, [String])}

data Transformed a = Transformed {
  infoLines :: [String],
  transfResult :: Maybe a}
  deriving (Show)

instance Functor Transformed where
  fmap f t = t {transfResult = fmap f $ transfResult t}

instance Applicative Transformed where
  pure x = Transformed {infoLines = [], transfResult = Just x}
  -- needed? (sensible?) or should we just have Pointed / use own pure
  f <*> t = Transformed {
    infoLines = infoLines f ++ infoLines t,
    transfResult = transfResult f <*> transfResult t}

(-:-) :: String -> [String] -> (String, [String])
name -:- ftypes = (name, ftypes)

(-?-) :: (String, [String]) -> String -> (String, [String], String)
(name, ftypes) -?- doc = (name, ftypes, doc)

(-=-) :: (String, [String], String) -> ([String] -> Options -> FilePath ->
  FilePath -> Int -> Int -> CanErrStrIO (Bool, [String])) -> Transf
(name, ftypes, doc) -=- func = Transf {
  transfName = bareName,
  transfTypes = ftypes,
  transfDoc = doc,
  transfArgs = argInfo,
  transfFunc = func}
  where (bareName, argInfo) = break (== ' ') name

-- todo: something more graceful here?
argless :: (t -> t1 -> t2) -> [a] -> t -> t1 -> t2
argless f args dir subPath = if null args then f dir subPath
  else error "Expected no arguments."

lexPass :: (Binary a, Parse a, Unparse a) => (a -> Transformed a) ->
  Options -> FilePath -> FilePath -> Int -> Int -> CanErrStrIO (Bool, [String])
lexPass transf opts codeDir subPath total cur = do
  io . hPutStrLn stderr $ "Checking (" ++ show cur ++ "/" ++ show total ++
    ") " ++ subPath
  ast <- io $ parseAndCache (optCacheAsts opts) codeDir subPath
  case transf ast of
    Transformed {infoLines = infoLines, transfResult = Nothing} ->
      return (False, infoLines)
    Transformed {infoLines = infoLines, transfResult = Just ast'} -> io $ do
      hPutStrLn stderr "- Saving"
      writeFile (codeDir </> subPath) $ unparse ast'
      encodeFile (astPath codeDir subPath) ast'
      return (True, infoLines)

--
-- basic transf-building tools
--

transfNothing :: Transformed a
transfNothing = Transformed {infoLines = [], transfResult = Nothing}

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

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

wsSp :: [Tok]
wsSp = [wsTokOf " "]
-}

modIntercal :: (a -> b -> a -> Transformed (IC.Intercal a b)) ->
  IC.Intercal a b -> Transformed (IC.Intercal a b)
modIntercal f ical = case runState (IC.concatMapM f' ical) ([], False) of
  (res, (infoLines, True)) ->
    Transformed {infoLines = infoLines, transfResult = Just res}
  (_, (infoLines, False)) ->
    Transformed {infoLines = infoLines, transfResult = Nothing}
  where
  f' a1 b a2 = case f a1 b a2 of
    Transformed {infoLines = infoLines, transfResult = Just res} ->
      withState (\ (i, _) -> (i ++ infoLines, True)) $ return res
    Transformed {infoLines = infoLines, transfResult = Nothing} ->
      withState (first (++ infoLines)) . return .
      IC.Intercal a1 b $ IC.Interend a2

modMap :: (a -> Transformed a) -> [a] -> Transformed [a]
modMap f xs = case runState (mapM f' xs) ([], False) of
  (res, (infoLines, True)) ->
    Transformed {infoLines = infoLines, transfResult = Just res}
  (_, (infoLines, False)) ->
    Transformed {infoLines = infoLines, transfResult = Nothing}
  where
  f' x = case f x of
    Transformed {infoLines = infoLines, transfResult = Just res} ->
      withState (\ (i, _) -> (i ++ infoLines, True)) $ return res
    Transformed {infoLines = infoLines, transfResult = Nothing} ->
      withState (first (++ infoLines)) $ return x

transformerToState :: (a -> Transformed a) -> a -> State ([String], Bool) a
transformerToState f x = case f x of
  Transformed {infoLines = infoLines, transfResult = Just res} ->
    withState (\ (i, _) -> (i ++ infoLines, True)) $ return res
  Transformed {infoLines = infoLines, transfResult = Nothing} ->
    withState (first (++ infoLines)) $ return x

stateToTransformer :: (a -> State ([String], Bool) a) -> a -> Transformed a
stateToTransformer f x = case runState (f x) ([], False) of
  (res, (infoLines, True)) ->
    Transformed {infoLines = infoLines, transfResult = Just res}
  (_, (infoLines, False)) ->
    Transformed {infoLines = infoLines, transfResult = Nothing}

modAll :: (Typeable a, Data b) => (a -> Transformed a) -> b -> Transformed b
modAll f = stateToTransformer (everywhereM (mkM $ transformerToState f))

--
-- behind-the-scenes/lower-level stuff
-- (some of these might be removable after the 2.0 refactor)
--

astPath :: FilePath -> FilePath -> FilePath
astPath codeDir subPath = codeDir </> ".ast" </> subPath ++ ".ast"

transfModsFile :: Parsec s (Bool, b) ()
transfModsFile = updateState ((,) True . snd)

-- combine these into AnAst?
parseAndCache :: (Binary a, Parse a, Unparse a) =>
  Bool -> FilePath -> FilePath -> IO a
parseAndCache cacheAsts codeDir subPath = do
  let
    astFilename = astPath codeDir subPath
    regen = do
      hPutStrLn stderr "- Parsing"
      c <- readFile $ codeDir </> subPath
      case runParser parse () subPath c of
        Left err -> error $ show err
        Right ast -> do
          createDirectoryIfMissing True $ takeDirectory astFilename
          encodeFile astFilename ast
          return ast
  if cacheAsts
    then
      doesFileExist astFilename >>= \ r -> if r
        then do
          mtimeAst <- getModificationTime astFilename
          mtimeFile <- getModificationTime (codeDir </> subPath)
          if mtimeFile > mtimeAst
            then regen
            else decodeFile astFilename
        else regen
    else do
      hPutStrLn stderr "- Parsing (always)"
      c <- readFile $ codeDir </> subPath
      return $ case runParser parse () subPath c of
        Left err -> error $ show err
        Right ast -> ast

--
-- eof
--
Something went wrong with that request. Please try again.