a1730cd6af
Removed dependency on MissingH, instead depending on the split library. After laying groundwork for this since 2015, it was mostly straightforward. Added Utility.Tuple and Utility.Split. Eyeballed System.Path.WildMatch while implementing the same thing. Since MissingH's progress meter display was being used, I re-implemented my own. Bonus: Now progress is displayed for transfers of files of unknown size. This commit was sponsored by Shane-o on Patreon.
738 lines
22 KiB
Haskell
738 lines
22 KiB
Haskell
{- Expands template haskell splices
|
|
-
|
|
- You should probably just use http://hackage.haskell.org/package/zeroth
|
|
- instead. I wish I had known about it before writing this.
|
|
-
|
|
- First, the code must be built with a ghc that supports TH,
|
|
- and the splices dumped to a log. For example:
|
|
- cabal build --ghc-options=-ddump-splices 2>&1 | tee log
|
|
-
|
|
- Along with the log, a headers file may also be provided, containing
|
|
- additional imports needed by the template haskell code.
|
|
-
|
|
- This program will parse the log, and expand all splices therein,
|
|
- writing files to the specified destdir (which can be "." to modify
|
|
- the source tree directly). They can then be built a second
|
|
- time, with a ghc that does not support TH.
|
|
-
|
|
- Note that template haskell code may refer to symbols that are not
|
|
- exported by the library that defines the TH code. In this case,
|
|
- the library has to be modifed to export those symbols.
|
|
-
|
|
- There can also be other problems with the generated code; it may
|
|
- need modifications to compile.
|
|
-
|
|
-
|
|
- Copyright 2013 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Main where
|
|
|
|
import Text.Parsec
|
|
import Text.Parsec.String
|
|
import Control.Applicative ((<$>))
|
|
import Data.Either
|
|
import Data.List hiding (find)
|
|
import Data.Char
|
|
import System.Environment
|
|
import System.FilePath
|
|
import System.IO
|
|
import Control.Monad
|
|
import Prelude hiding (log)
|
|
|
|
import Utility.Monad
|
|
import Utility.Misc
|
|
import Utility.Exception hiding (try)
|
|
import Utility.Path
|
|
import Utility.FileSystemEncoding
|
|
import Utility.Directory
|
|
import Utility.Split
|
|
|
|
data Coord = Coord
|
|
{ coordLine :: Int
|
|
, coordColumn :: Int
|
|
}
|
|
deriving (Read, Show)
|
|
|
|
offsetCoord :: Coord -> Coord -> Coord
|
|
offsetCoord a b = Coord
|
|
(coordLine a - coordLine b)
|
|
(coordColumn a - coordColumn b)
|
|
|
|
data SpliceType = SpliceExpression | SpliceDeclaration
|
|
deriving (Read, Show, Eq)
|
|
|
|
data Splice = Splice
|
|
{ splicedFile :: FilePath
|
|
, spliceStart :: Coord
|
|
, spliceEnd :: Coord
|
|
, splicedExpression :: String
|
|
, splicedCode :: String
|
|
, spliceType :: SpliceType
|
|
}
|
|
deriving (Read, Show)
|
|
|
|
isExpressionSplice :: Splice -> Bool
|
|
isExpressionSplice s = spliceType s == SpliceExpression
|
|
|
|
number :: Parser Int
|
|
number = read <$> many1 digit
|
|
|
|
{- A pair of Coords is written in one of three ways:
|
|
- "95:21-73", "1:1", or "(92,25)-(94,2)"
|
|
-}
|
|
coordsParser :: Parser (Coord, Coord)
|
|
coordsParser = (try singleline <|> try weird <|> multiline) <?> "Coords"
|
|
where
|
|
singleline = do
|
|
line <- number
|
|
void $ char ':'
|
|
startcol <- number
|
|
void $ char '-'
|
|
endcol <- number
|
|
return $ (Coord line startcol, Coord line endcol)
|
|
|
|
weird = do
|
|
line <- number
|
|
void $ char ':'
|
|
col <- number
|
|
return $ (Coord line col, Coord line col)
|
|
|
|
multiline = do
|
|
start <- fromparens
|
|
void $ char '-'
|
|
end <- fromparens
|
|
return $ (start, end)
|
|
|
|
fromparens = between (char '(') (char ')') $ do
|
|
line <- number
|
|
void $ char ','
|
|
col <- number
|
|
return $ Coord line col
|
|
|
|
indent :: Parser String
|
|
indent = many1 $ char ' '
|
|
|
|
restOfLine :: Parser String
|
|
restOfLine = newline `after` many (noneOf "\n")
|
|
|
|
indentedLine :: Parser String
|
|
indentedLine = indent >> restOfLine
|
|
|
|
spliceParser :: Parser Splice
|
|
spliceParser = do
|
|
file <- many1 (noneOf ":\n")
|
|
void $ char ':'
|
|
(start, end) <- coordsParser
|
|
void $ string ": Splicing "
|
|
splicetype <- tosplicetype
|
|
<$> (string "expression" <|> string "declarations")
|
|
void newline
|
|
|
|
getthline <- expressionextractor
|
|
expression <- unlines <$> many1 getthline
|
|
|
|
void indent
|
|
void $ string "======>"
|
|
void newline
|
|
|
|
getcodeline <- expressionextractor
|
|
realcoords <- try (Right <$> getrealcoords file) <|> (Left <$> getcodeline)
|
|
codelines <- many getcodeline
|
|
return $ case realcoords of
|
|
Left firstcodeline ->
|
|
Splice file start end expression
|
|
(unlines $ firstcodeline:codelines)
|
|
splicetype
|
|
Right (realstart, realend) ->
|
|
Splice file realstart realend expression
|
|
(unlines codelines)
|
|
splicetype
|
|
where
|
|
tosplicetype "declarations" = SpliceDeclaration
|
|
tosplicetype "expression" = SpliceExpression
|
|
tosplicetype s = error $ "unknown splice type: " ++ s
|
|
|
|
{- All lines of the indented expression start with the same
|
|
- indent, which is stripped. Any other indentation is preserved. -}
|
|
expressionextractor = do
|
|
i <- lookAhead indent
|
|
return $ try $ do
|
|
void $ string i
|
|
restOfLine
|
|
|
|
{- When splicing declarations, GHC will output a splice
|
|
- at 1:1, and then inside the splice code block,
|
|
- the first line will give the actual coordinates of the
|
|
- line that was spliced. -}
|
|
getrealcoords file = do
|
|
void indent
|
|
void $ string file
|
|
void $ char ':'
|
|
char '\n' `after` coordsParser
|
|
|
|
{- Extracts the splices, ignoring the rest of the compiler output. -}
|
|
splicesExtractor :: Parser [Splice]
|
|
splicesExtractor = rights <$> many extract
|
|
where
|
|
extract = try (Right <$> spliceParser) <|> (Left <$> compilerJunkLine)
|
|
compilerJunkLine = restOfLine
|
|
|
|
{- Modifies the source file, expanding the splices, which all must
|
|
- have the same splicedFile. Writes the new file to the destdir.
|
|
-
|
|
- Each splice's Coords refer to the original position in the file,
|
|
- and not to its position after any previous splices may have inserted
|
|
- or removed lines.
|
|
-
|
|
- To deal with this complication, the file is broken into logical lines
|
|
- (which can contain any String, including a multiline or empty string).
|
|
- Each splice is assumed to be on its own block of lines; two
|
|
- splices on the same line is not currently supported.
|
|
- This means that a splice can modify the logical lines within its block
|
|
- as it likes, without interfering with the Coords of other splices.
|
|
-
|
|
- As well as expanding splices, this can add a block of imports to the
|
|
- file. These are put right before the first line in the file that
|
|
- starts with "import "
|
|
-}
|
|
applySplices :: FilePath -> Maybe String -> [Splice] -> IO ()
|
|
applySplices _ _ [] = noop
|
|
applySplices destdir imports splices@(first:_) = do
|
|
let f = splicedFile first
|
|
let dest = (destdir </> f)
|
|
lls <- map (++ "\n") . lines <$> readFileStrict f
|
|
createDirectoryIfMissing True (parentDir dest)
|
|
let newcontent = concat $ addimports $ expand lls splices
|
|
oldcontent <- catchMaybeIO $ readFileStrict dest
|
|
when (oldcontent /= Just newcontent) $ do
|
|
putStrLn $ "splicing " ++ f
|
|
withFile dest WriteMode $ \h -> do
|
|
hPutStr h newcontent
|
|
hClose h
|
|
where
|
|
expand lls [] = lls
|
|
expand lls (s:rest)
|
|
| isExpressionSplice s = expand (expandExpressionSplice s lls) rest
|
|
| otherwise = expand (expandDeclarationSplice s lls) rest
|
|
|
|
addimports lls = case imports of
|
|
Nothing -> lls
|
|
Just v ->
|
|
let (start, end) = break ("import " `isPrefixOf`) lls
|
|
in if null end
|
|
then start
|
|
else concat
|
|
[ start
|
|
, [v]
|
|
, end
|
|
]
|
|
|
|
{- Declaration splices are expanded to replace their whole line. -}
|
|
expandDeclarationSplice :: Splice -> [String] -> [String]
|
|
expandDeclarationSplice s lls = concat [before, [splice], end]
|
|
where
|
|
cs = spliceStart s
|
|
ce = spliceEnd s
|
|
|
|
(before, rest) = splitAt (coordLine cs - 1) lls
|
|
(_oldlines, end) = splitAt (1 + coordLine (offsetCoord ce cs)) rest
|
|
splice = mangleCode $ splicedCode s
|
|
|
|
{- Expression splices are expanded within their line. -}
|
|
expandExpressionSplice :: Splice -> [String] -> [String]
|
|
expandExpressionSplice sp lls = concat [before, spliced:padding, end]
|
|
where
|
|
cs = spliceStart sp
|
|
ce = spliceEnd sp
|
|
|
|
(before, rest) = splitAt (coordLine cs - 1) lls
|
|
(oldlines, end) = splitAt (1 + coordLine (offsetCoord ce cs)) rest
|
|
(splicestart, padding, spliceend) = case map expandtabs oldlines of
|
|
ss:r
|
|
| null r -> (ss, [], ss)
|
|
| otherwise -> (ss, take (length r) (repeat []), last r)
|
|
_ -> ([], [], [])
|
|
spliced = concat
|
|
[ joinsplice $ deqqstart $ take (coordColumn cs - 1) splicestart
|
|
, addindent (findindent splicestart) (mangleCode $ splicedCode sp)
|
|
, deqqend $ drop (coordColumn ce) spliceend
|
|
]
|
|
|
|
{- coordinates assume tabs are expanded to 8 spaces -}
|
|
expandtabs = replace "\t" (take 8 $ repeat ' ')
|
|
|
|
{- splicing leaves $() quasiquote behind; remove it -}
|
|
deqqstart s = case reverse s of
|
|
('(':'$':restq) -> reverse restq
|
|
_ -> s
|
|
deqqend (')':s) = s
|
|
deqqend s = s
|
|
|
|
{- Prepare the code that comes just before the splice so
|
|
- the splice will combine with it appropriately. -}
|
|
joinsplice s
|
|
-- all indentation? Skip it, we'll use the splice's indentation
|
|
| all isSpace s = ""
|
|
-- function definition needs no preparation
|
|
-- ie: foo = $(splice)
|
|
| "=" `isSuffixOf` s' = s
|
|
-- nor does lambda definition or case expression
|
|
| "->" `isSuffixOf` s' = s
|
|
-- nor does a let .. in declaration
|
|
| "in" `isSuffixOf` s' = s
|
|
-- already have a $ to set off the splice
|
|
-- ie: foo $ $(splice)
|
|
| "$" `isSuffixOf` s' = s
|
|
-- need to add a $ to set off the splice
|
|
-- ie: bar $(splice)
|
|
| otherwise = s ++ " $ "
|
|
where
|
|
s' = filter (not . isSpace) s
|
|
|
|
findindent = length . takeWhile isSpace
|
|
addindent n = unlines . map (i ++) . lines
|
|
where
|
|
i = take n $ repeat ' '
|
|
|
|
{- Tweaks code output by GHC in splices to actually build. Yipes. -}
|
|
mangleCode :: String -> String
|
|
mangleCode = flip_colon
|
|
. persist_dequalify_hack
|
|
. let_do
|
|
. remove_unnecessary_type_signatures
|
|
. lambdaparenhackyesod
|
|
. lambdaparenhackpersistent
|
|
. lambdaparens
|
|
. declaration_parens
|
|
. case_layout
|
|
. case_layout_multiline
|
|
. yesod_url_render_hack
|
|
. text_builder_hack
|
|
. nested_instances
|
|
. boxed_fileembed
|
|
. collapse_multiline_strings
|
|
. remove_package_version
|
|
. emptylambda
|
|
where
|
|
{- Lambdas are often output without parens around them.
|
|
- This breaks when the lambda is immediately applied to a
|
|
- parameter.
|
|
-
|
|
- For example:
|
|
-
|
|
- renderRoute (StaticR sub_a1nUH)
|
|
- = \ (a_a1nUI, b_a1nUJ)
|
|
- -> (((pack "static") : a_a1nUI),
|
|
- b_a1nUJ)
|
|
- (renderRoute sub_a1nUH)
|
|
-
|
|
- There are sometimes many lines of lambda code that need to be
|
|
- parenthesised. Approach: find the "->" and scan down the
|
|
- column to the first non-whitespace. This is assumed
|
|
- to be the expression after the lambda.
|
|
-
|
|
- Runs recursively on the body of the lambda, to handle nested
|
|
- lambdas.
|
|
-}
|
|
lambdaparens = parsecAndReplace $ do
|
|
-- skip lambdas inside tuples or parens
|
|
prefix <- noneOf "(, \n"
|
|
preindent <- many1 $ oneOf " \n"
|
|
void $ string "\\ "
|
|
lambdaparams <- restofline
|
|
continuedlambdaparams <- many $ try $ do
|
|
indent1 <- many1 $ char ' '
|
|
p <- satisfy isLetter
|
|
aram <- many $ satisfy isAlphaNum <|> oneOf "_"
|
|
void newline
|
|
return $ indent1 ++ p:aram ++ "\n"
|
|
indent1 <- many1 $ char ' '
|
|
void $ string "-> "
|
|
firstline <- restofline
|
|
lambdalines <- many $ try $ do
|
|
void $ string indent1
|
|
void $ char ' '
|
|
l <- restofline
|
|
return $ indent1 ++ " " ++ l
|
|
return $ concat
|
|
[ prefix:preindent
|
|
, "(\\ " ++ lambdaparams ++ "\n"
|
|
, concat continuedlambdaparams
|
|
, indent1 ++ "-> "
|
|
, lambdaparens $ intercalate "\n" (firstline:lambdalines)
|
|
, ")\n"
|
|
]
|
|
|
|
{- Hack to add missing parens in a specific case in yesod
|
|
- static route code.
|
|
-
|
|
- StaticR
|
|
- yesod_dispatch_env_a4iDV
|
|
- (\ p_a4iE2 r_a4iE3
|
|
- -> r_a4iE3
|
|
- {Network.Wai.pathInfo = p_a4iE2}
|
|
- xrest_a4iDT req_a4iDW)) }
|
|
-
|
|
- Need to add another paren around the lambda, and close it
|
|
- before its parameters. lambdaparens misses this one because
|
|
- there is already one paren present.
|
|
-
|
|
- Note that the { } may be on the same line, or wrapped to next.
|
|
-
|
|
- FIXME: This is a hack. lambdaparens could just always add a
|
|
- layer of parens even when a lambda seems to be in parent.
|
|
-}
|
|
lambdaparenhackyesod = parsecAndReplace $ do
|
|
indent1 <- many1 $ char ' '
|
|
staticr <- string "StaticR"
|
|
void newline
|
|
void $ string indent1
|
|
yesod_dispatch_env <- restofline
|
|
void $ string indent1
|
|
lambdaprefix <- string "(\\ "
|
|
l1 <- restofline
|
|
void $ string indent1
|
|
lambdaarrow <- string " ->"
|
|
l2 <- restofline
|
|
l3 <- if '{' `elem` l2 && '}' `elem` l2
|
|
then return ""
|
|
else do
|
|
void $ string indent1
|
|
restofline
|
|
return $ unlines
|
|
[ indent1 ++ staticr
|
|
, indent1 ++ yesod_dispatch_env
|
|
, indent1 ++ "(" ++ lambdaprefix ++ l1
|
|
, indent1 ++ lambdaarrow ++ l2 ++ l3 ++ ")"
|
|
]
|
|
|
|
{- Hack to reorder misplaced paren in persistent code.
|
|
-
|
|
- = ((Right Fscked)
|
|
- (\ persistValue_a36iM
|
|
- -> case fromPersistValue persistValue_a36iM of {
|
|
- Right r_a36iN -> Right r_a36iN
|
|
- Left err_a36iO
|
|
- -> (Left
|
|
- $ ((("field " `Data.Monoid.mappend` (packPTH "key"))
|
|
- `Data.Monoid.mappend` ": ")
|
|
- `Data.Monoid.mappend` err_a36iO)) }
|
|
- x_a36iL))
|
|
-
|
|
- Fixed by adding another level of params around the lambda
|
|
- (lambdaparams should be generalized to cover this case).
|
|
-}
|
|
lambdaparenhackpersistent = parsecAndReplace $ do
|
|
indent1 <- many1 $ char ' '
|
|
start <- do
|
|
s1 <- string "(\\ "
|
|
s2 <- string "persistValue_"
|
|
s3 <- restofline
|
|
return $ s1 ++ s2 ++ s3
|
|
void $ string indent1
|
|
indent2 <- many1 $ char ' '
|
|
void $ string "-> "
|
|
l1 <- restofline
|
|
lambdalines <- many $ try $ do
|
|
void $ string $ indent1 ++ indent2 ++ " "
|
|
l <- restofline
|
|
return $ indent1 ++ indent2 ++ " " ++ l
|
|
return $ concat
|
|
[ indent1 ++ "(" ++ start ++ "\n"
|
|
, indent1 ++ indent2 ++ "-> " ++ l1 ++ "\n"
|
|
, intercalate "\n" lambdalines
|
|
, ")\n"
|
|
]
|
|
|
|
restofline = manyTill (noneOf "\n") newline
|
|
|
|
{- For some reason, GHC sometimes doesn't like the multiline
|
|
- strings it creates. It seems to get hung up on \{ at the
|
|
- start of a new line sometimes, wanting it to not be escaped.
|
|
-
|
|
- To work around what is likely a GHC bug, just collapse
|
|
- multiline strings. -}
|
|
collapse_multiline_strings = parsecAndReplace $ do
|
|
void $ string "\\\n"
|
|
void $ many1 $ oneOf " \t"
|
|
void $ string "\\"
|
|
return "\\n"
|
|
|
|
{- GHC outputs splices using explicit braces rather than layout.
|
|
- For a case expression, it does something weird:
|
|
-
|
|
- case foo of {
|
|
- xxx -> blah
|
|
- yyy -> blah };
|
|
-
|
|
- This is not legal Haskell; the statements in the case must be
|
|
- separated by ';'
|
|
-
|
|
- To fix, we could just put a semicolon at the start of every line
|
|
- containing " -> " ... Except that lambdas also contain that.
|
|
- But we can get around that: GHC outputs lambdas like this:
|
|
-
|
|
- \ foo
|
|
- -> bar
|
|
-
|
|
- Or like this:
|
|
-
|
|
- \ foo -> bar
|
|
-
|
|
- So, we can put the semicolon at the start of every line
|
|
- containing " -> " unless there's a "\ " first, or it's
|
|
- all whitespace up until it.
|
|
-}
|
|
case_layout = skipfree $ parsecAndReplace $ do
|
|
void newline
|
|
indent1 <- many1 $ char ' '
|
|
prefix <- manyTill (noneOf "\n") (try (string "-> "))
|
|
if length prefix > 20
|
|
then unexpected "too long a prefix"
|
|
else if "\\ " `isInfixOf` prefix
|
|
then unexpected "lambda expression"
|
|
else if null prefix
|
|
then unexpected "second line of lambda"
|
|
else return $ "\n" ++ indent1 ++ "; " ++ prefix ++ " -> "
|
|
{- Sometimes cases themselves span multiple lines:
|
|
-
|
|
- Nothing
|
|
- -> foo
|
|
-
|
|
- -- This is not yet handled!
|
|
- ComplexConstructor var var
|
|
- var var
|
|
- -> foo
|
|
-}
|
|
case_layout_multiline = skipfree $ parsecAndReplace $ do
|
|
void newline
|
|
indent1 <- many1 $ char ' '
|
|
firstline <- restofline
|
|
|
|
void $ string indent1
|
|
indent2 <- many1 $ char ' '
|
|
void $ string "-> "
|
|
if "\\ " `isInfixOf` firstline
|
|
then unexpected "lambda expression"
|
|
else return $ "\n" ++ indent1 ++ "; " ++ firstline ++ "\n"
|
|
++ indent1 ++ indent2 ++ "-> "
|
|
|
|
{- Type definitions for free monads triggers the case_* hacks, avoid. -}
|
|
skipfree f s
|
|
| "MonadFree" `isInfixOf` s = s
|
|
| otherwise = f s
|
|
|
|
{- (foo, \ -> bar) is not valid haskell, GHC.
|
|
- Change to (foo, bar)
|
|
-
|
|
- (Does this ever happen outside a tuple? Only saw
|
|
- it inside them..
|
|
-}
|
|
emptylambda = replace ", \\ -> " ", "
|
|
|
|
{- GHC may output this:
|
|
-
|
|
- instance RenderRoute WebApp where
|
|
- data instance Route WebApp
|
|
- ^^^^^^^^
|
|
- The marked word should not be there.
|
|
-
|
|
- FIXME: This is a yesod and persistent-specific hack,
|
|
- it should look for the outer instance.
|
|
-}
|
|
nested_instances = replace " data instance Route" " data Route"
|
|
. replace " data instance Unique" " data Unique"
|
|
. replace " data instance EntityField" " data EntityField"
|
|
. replace " type instance PersistEntityBackend" " type PersistEntityBackend"
|
|
|
|
{- GHC does not properly parenthesise generated data type
|
|
- declarations. -}
|
|
declaration_parens = replace "StaticR Route Static" "StaticR (Route Static)"
|
|
|
|
{- A type signature is sometimes given for an entire lambda,
|
|
- which is not properly parenthesized or laid out. This is a
|
|
- hack to remove one specific case where this happens and the
|
|
- signature is easily inferred, so is just removed.
|
|
-}
|
|
remove_unnecessary_type_signatures = parsecAndReplace $ do
|
|
void $ string " ::"
|
|
void newline
|
|
void $ many1 $ char ' '
|
|
void $ string "Text.Css.Block Text.Css.Resolved"
|
|
void newline
|
|
return ""
|
|
|
|
{- GHC may add full package and version qualifications for
|
|
- symbols from unimported modules. We don't want these.
|
|
-
|
|
- Examples:
|
|
- "blaze-html-0.4.3.1:Text.Blaze.Internal.preEscapedText"
|
|
- "ghc-prim:GHC.Types.:"
|
|
-}
|
|
remove_package_version = parsecAndReplace $
|
|
mangleSymbol <$> qualifiedSymbol
|
|
|
|
mangleSymbol "GHC.Types." = ""
|
|
mangleSymbol "GHC.Tuple." = ""
|
|
mangleSymbol s = s
|
|
|
|
qualifiedSymbol :: Parser String
|
|
qualifiedSymbol = do
|
|
s <- hstoken
|
|
void $ char ':'
|
|
if length s < 5
|
|
then unexpected "too short to be a namespace"
|
|
else do
|
|
t <- hstoken
|
|
case t of
|
|
(c:r) | isUpper c && "." `isInfixOf` r -> return t
|
|
_ -> unexpected "not a module qualified symbol"
|
|
|
|
hstoken :: Parser String
|
|
hstoken = do
|
|
t <- satisfy isLetter
|
|
oken <- many $ satisfy isAlphaNum <|> oneOf "-.'"
|
|
return $ t:oken
|
|
|
|
{- This works when it's "GHC.Types.:", but we strip
|
|
- that above, so have to fix up after it here.
|
|
- The ; is added by case_layout. -}
|
|
flip_colon = replace "; : _ " "; _ : "
|
|
|
|
{- TH for persistent has some qualified symbols in places
|
|
- that are not allowed. -}
|
|
persist_dequalify_hack = replace "Database.Persist.TH.++" "`Data.Text.append`"
|
|
. replace "Database.Persist.Sql.Class.sqlType" "sqlType"
|
|
. replace "Database.Persist.Class.PersistField.toPersistValue" "toPersistValue"
|
|
. replace "Database.Persist.Class.PersistField.fromPersistValue" "fromPersistValue"
|
|
|
|
{- Sometimes generates invalid bracketed code with a let
|
|
- expression:
|
|
-
|
|
- foo = do { let x = foo;
|
|
- use foo }
|
|
-
|
|
- Fix by converting the "let x = " to "x <- return $"
|
|
-}
|
|
let_do = parsecAndReplace $ do
|
|
void $ string "= do { let "
|
|
x <- many $ noneOf "=\r\n"
|
|
_ <- many1 $ oneOf " \t\r\n"
|
|
void $ string "= "
|
|
return $ "= do { " ++ x ++ " <- return $ "
|
|
|
|
{- Embedded files use unsafe packing, which is problematic
|
|
- for several reasons, including that GHC sometimes omits trailing
|
|
- newlines in the file content, which leads to the wrong byte
|
|
- count. Also, GHC sometimes outputs unicode characters, which
|
|
- are not legal in unboxed strings.
|
|
-
|
|
- Avoid problems by converting:
|
|
- GHC.IO.unsafePerformIO
|
|
- (Data.ByteString.Unsafe.unsafePackAddressLen
|
|
- lllll
|
|
- "blabblah"#)),
|
|
- to:
|
|
- Data.ByteString.Char8.pack "blabblah"),
|
|
-
|
|
- Note that the string is often multiline. This only works if
|
|
- collapse_multiline_strings has run first.
|
|
-}
|
|
boxed_fileembed :: String -> String
|
|
boxed_fileembed = parsecAndReplace $ do
|
|
i <- indent
|
|
void $ string "GHC.IO.unsafePerformIO"
|
|
void newline
|
|
void indent
|
|
void $ string "(Data.ByteString.Unsafe.unsafePackAddressLen"
|
|
void newline
|
|
void indent
|
|
void number
|
|
void newline
|
|
void indent
|
|
void $ char '"'
|
|
s <- restOfLine
|
|
let s' = take (length s - 5) s
|
|
if "\"#))," `isSuffixOf` s
|
|
then return (i ++ "Data.ByteString.Char8.pack \"" ++ s' ++ "\"),\n")
|
|
else fail "not an unboxed string"
|
|
|
|
{- This works around a problem in the expanded template haskell for Yesod
|
|
- type-safe url rendering.
|
|
-
|
|
- It generates code like this:
|
|
-
|
|
- (toHtml
|
|
- (\ u_a2ehE -> urender_a2ehD u_a2ehE []
|
|
- (CloseAlert aid)))));
|
|
-
|
|
- Where urender_a2ehD is the function returned by getUrlRenderParams.
|
|
- But, that function that only takes 2 params, not 3.
|
|
- And toHtml doesn't take a parameter at all!
|
|
-
|
|
- So, this modifes the code, to look like this:
|
|
-
|
|
- (toHtml
|
|
- (flip urender_a2ehD []
|
|
- (CloseAlert aid)))));
|
|
-
|
|
- FIXME: Investigate and fix this properly.
|
|
-}
|
|
yesod_url_render_hack :: String -> String
|
|
yesod_url_render_hack = parsecAndReplace $ do
|
|
void $ string "(toHtml"
|
|
void whitespace
|
|
void $ string "(\\"
|
|
void whitespace
|
|
wtf <- hstoken
|
|
void whitespace
|
|
void $ string "->"
|
|
void whitespace
|
|
renderer <- hstoken
|
|
void whitespace
|
|
void $ string wtf
|
|
void whitespace
|
|
return $ "(toHtml (flip " ++ renderer ++ " "
|
|
where
|
|
whitespace :: Parser String
|
|
whitespace = many $ oneOf " \t\r\n"
|
|
|
|
hstoken :: Parser String
|
|
hstoken = many1 $ satisfy isAlphaNum <|> oneOf "_"
|
|
|
|
{- Use exported symbol. -}
|
|
text_builder_hack :: String -> String
|
|
text_builder_hack = replace "Data.Text.Lazy.Builder.Internal.fromText" "Data.Text.Lazy.Builder.fromText"
|
|
|
|
{- Given a Parser that finds strings it wants to modify,
|
|
- and returns the modified string, does a mass
|
|
- find and replace throughout the input string.
|
|
- Rather slow, but crazy powerful. -}
|
|
parsecAndReplace :: Parser String -> String -> String
|
|
parsecAndReplace p s = case parse find "" s of
|
|
Left _e -> s
|
|
Right l -> concatMap (either return id) l
|
|
where
|
|
find :: Parser [Either Char String]
|
|
find = many $ try (Right <$> p) <|> (Left <$> anyChar)
|
|
|
|
main :: IO ()
|
|
main = do
|
|
useFileSystemEncoding
|
|
go =<< getArgs
|
|
where
|
|
go (destdir:log:header:[]) = run destdir log (Just header)
|
|
go (destdir:log:[]) = run destdir log Nothing
|
|
go _ = error "usage: EvilSplicer destdir logfile [headerfile]"
|
|
|
|
run destdir log mheader = do
|
|
r <- parseFromFile splicesExtractor log
|
|
case r of
|
|
Left e -> error $ show e
|
|
Right splices -> do
|
|
let groups = groupBy (\a b -> splicedFile a == splicedFile b) splices
|
|
imports <- maybe (return Nothing) (catchMaybeIO . readFile) mheader
|
|
mapM_ (applySplices destdir imports) groups
|