{-# LANGUAGE TypeApplications #-}
import Prelude hiding (head, init, last, reverse, tail)
import qualified Prelude
import Control.Exception (IOException, try)
import Data.Char (isDigit)
import Data.Either (fromRight)
import Data.Foldable (for_)
import Data.List (intercalate, intersperse, isPrefixOf, replicate, stripPrefix)
import Distribution.Simple (Args, UserHooks (preBuild), defaultMainWithHooks, simpleUserHooks)
import Distribution.Simple.Setup (BuildFlags)
import Distribution.Types.HookedBuildInfo (HookedBuildInfo, emptyHookedBuildInfo)
import System.Directory (copyFile, createDirectoryIfMissing, getModificationTime,
getTemporaryDirectory, removeFile)
import System.FilePath (dropExtension, takeFileName, (</>))
import System.IO (Handle, IOMode (ReadMode), hClose, hGetLine, hIsEOF, hPutStrLn,
hSetNewlineMode, noNewlineTranslation, openTempFile, stdin,
withFile)
main :: IO ()
main =
defaultMainWithHooks
simpleUserHooks
{ preBuild = \_ _ -> preProcessBuilder >> preProcessParser >> preProcessLength >> pure emptyHookedBuildInfo }
preProcess :: FilePath -> (Word -> [String] -> [String]) -> IO ()
preProcess srcPath embed = do
let
fileName = takeFileName srcPath
templatePath = "template" </> fileName
templateItemPath = "template" </> dropExtension fileName ++ "Item.hs"
d <- dirty srcPath templatePath templateItemPath
if d
then do
putStrLn $ "necessary to update " ++ srcPath
tempPath <-
withFile templatePath ReadMode $ \template -> do
tempDir <- (</> "postgresql-pure") <$> getTemporaryDirectory
createDirectoryIfMissing True tempDir
(tempPath, temp) <- openTempFile tempDir fileName
hSetNewlineMode template noNewlineTranslation
hSetNewlineMode temp noNewlineTranslation
hSetNewlineMode stdin noNewlineTranslation
templateItem <- lines <$> readFile templateItemPath
loop template temp templateItem
hClose temp
pure tempPath
copyFile tempPath srcPath
removeFile tempPath
else putStrLn $ "unnecessary to update " ++ srcPath
where
loop :: Handle -> Handle -> [String] -> IO ()
loop template temp templateItem =
go
where
go = do
eof <- hIsEOF template
if eof
then pure ()
else do
line <- hGetLine template
for_ (preprocess line templateItem) (hPutStrLn temp)
go
preprocess :: String -> [String] -> [String]
preprocess line templateItem
| Just rest <- stripPrefix "---- embed " line
, let n = read $ takeWhile isDigit rest
= embed n templateItem
| otherwise = [line]
preProcessBuilder :: IO ()
preProcessBuilder = preProcess "src/Database/PostgreSQL/Pure/Internal/Builder.hs" embed
where
embed :: Word -> [String] -> [String]
embed l templateItem
| l >= 2 = concatMap go templateItem
| otherwise = error "length must be larger than or equal to 2"
where
go "" = [""]
go t
| Just rest <- stripPrefix "<to-field>" t = [toField ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<type-tuple>" t = [typeTuple ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<value-tuple>" t = [valueTuple ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<format-list>" t = [formatList ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<oid-list>" t = [oidList ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<to-field-nothing-list>" t = [toFieldNothingList ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<to-field-just-list>" t = [toFieldJustList ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<length>" t = [length ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<>" t = ["<>" ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<" t = error $ "unknown tag: " ++ takeWhile (/= '>') rest
| (s, rest) <- span (/= '<') t = [s ++ Prelude.head (go rest)]
n = fromIntegral l
toField = paren $ take n $ ("ToField " ++) <$> i012
typeTuple = paren $ take n i012
valueTuple = paren $ take n v012
formatList = bracket $ take n f012
oidList = bracket $ take n o012
toFieldNothingList = bracket $ take n $ (\(f, v) -> "toField backendParams encode Nothing " ++ f ++ " " ++ v) <$> zip f012 v012
toFieldJustList = bracket $ take n $ (\(o, f, v) -> "toField backendParams encode (Just " ++ o ++ ") " ++ f ++ " " ++ v) <$> zip3 o012 f012 v012
length = show l
paren xs = "(" ++ intercalate ", " xs ++ ")"
bracket xs = "[" ++ intercalate ", " xs ++ "]"
i012 = ('i':) . show <$> [0 ..]
o012 = ('o':) . show <$> [0 ..]
f012 = ('f':) . show <$> [0 ..]
v012 = ('v':) . show <$> [0 ..]
preProcessParser :: IO ()
preProcessParser = preProcess "src/Database/PostgreSQL/Pure/Internal/Parser.hs" embed
where
embed :: Word -> [String] -> [String]
embed l templateItem
| l >= 2 = concatMap go templateItem
| otherwise = error "length must be larger than or equal to 2"
where
go "" = [""]
go t
| Just rest <- stripPrefix "<from-field>" t = [fromField ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<tuple>" t = [tuple ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<list>" t = [list ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<length>" t = [length ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<tuple-cons>" t = [tupleCons ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<decode>" t = [decode ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<$>" t = ["<$>" ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<>" t = ["<>" ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<" t = error $ "unknown tag: " ++ takeWhile (/= '>') rest
| (s, rest) <- span (/= '<') t = [s ++ Prelude.head (go rest)]
n = fromIntegral l
fromField = paren $ take n $ ("FromField " ++) <$> i012
tuple = paren $ take n i012
list = bracket $ take n i012
length = show l
tupleCons = "(" ++ replicate (n - 1) ',' ++ ")"
decode = intercalate " <*> " $ take n $ ("column decode " ++) <$> i012
paren xs = "(" ++ intercalate ", " xs ++ ")"
bracket xs = "[" ++ intercalate ", " xs ++ "]"
i012 = ('i':) . show <$> [0 ..]
preProcessLength :: IO ()
preProcessLength = preProcess "src/Database/PostgreSQL/Pure/Internal/Length.hs" embed
where
embed :: Word -> [String] -> [String]
embed l templateItem
| l >= 2 = concatMap go templateItem
| otherwise = error "length must be larger than or equal to 2"
where
go "" = [""]
go t
| Just rest <- stripPrefix "<tuple>" t = [tuple ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<length>" t = [length ++ Prelude.head (go rest)]
| Just rest <- stripPrefix "<" t = error $ "unknown tag: " ++ takeWhile (/= '>') rest
| (s, rest) <- span (/= '<') t = [s ++ Prelude.head (go rest)]
n = fromIntegral l
tuple = paren $ take n i012
length = show l
paren xs = "(" ++ intercalate ", " xs ++ ")"
i012 = ('i':) . show <$> [0 ..]
dirty :: FilePath -> FilePath -> FilePath -> IO Bool
dirty src template templateItem =
try @IOException @Bool (do
srcTime <- getModificationTime src
templateTime <- getModificationTime template
templateItemTime <- getModificationTime templateItem
setupTime <- getModificationTime "Setup.hs"
pure $ srcTime < maximum [templateTime, templateItemTime, setupTime]
) >>= pure . fromRight True