filepath-1.5.0.0: Generate.hs
{-# LANGUAGE CPP, RecordWildCards, ViewPatterns #-}
module Generate(main) where
import Control.Exception
import Control.Monad
import Data.Semigroup
import Data.Char
import Data.List
import System.Directory
import System.IO
main :: IO ()
main = do
src <- readFile "System/FilePath/Internal.hs"
let tests = map renderTest $ concatMap parseTest $ lines src
writeFileBinaryChanged "tests/filepath-tests/TestGen.hs" $ unlines $
["-- GENERATED CODE: See ../Generate.hs"
#ifndef GHC_MAKE
, "{-# LANGUAGE OverloadedStrings #-}"
, "{-# LANGUAGE ViewPatterns #-}"
#endif
, "{-# LANGUAGE CPP #-}"
, "{-# OPTIONS_GHC -Wno-name-shadowing #-}"
, "{-# OPTIONS_GHC -Wno-orphans #-}"
,"module TestGen(tests) where"
,"import TestUtil"
,"#if !MIN_VERSION_base(4,11,0)"
,"import Data.Semigroup"
,"#endif"
,"import Prelude as P"
,"import Data.String"
,"import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )"
,"import GHC.IO.Encoding.UTF16 ( mkUTF16le )"
,"import GHC.IO.Encoding.UTF8 ( mkUTF8 )"
,"import System.OsString.Internal.Types"
,"import System.OsString.Encoding.Internal"
,"import qualified Data.Char as C"
,"import qualified System.OsString.Data.ByteString.Short as SBS"
,"import qualified System.OsString.Data.ByteString.Short.Word16 as SBS16"
,"import qualified System.FilePath.Windows as W"
,"import qualified System.FilePath.Posix as P"
#ifdef GHC_MAKE
,"import qualified System.OsPath.Windows.Internal as AFP_W"
,"import qualified System.OsPath.Posix.Internal as AFP_P"
#else
,"import qualified System.OsPath.Windows as AFP_W"
,"import qualified System.OsPath.Posix as AFP_P"
#endif
,"instance IsString WindowsString where fromString = WS . either (error . show) id . encodeWithTE (mkUTF16le TransliterateCodingFailure)"
,"instance IsString PosixString where fromString = PS . either (error . show) id . encodeWithTE (mkUTF8 TransliterateCodingFailure)"
,"#if defined(mingw32_HOST_OS) || defined(__MINGW32__)"
,"instance IsString OsString where fromString = OsString . WS . either (error . show) id . encodeWithTE (mkUTF16le TransliterateCodingFailure)"
,"#else"
,"instance IsString OsString where fromString = OsString . PS . either (error . show) id . encodeWithTE (mkUTF8 TransliterateCodingFailure)"
,"#endif"
,"tests :: [(String, Property)]"
,"tests ="] ++
[" " ++ c ++ "(" ++ show t1 ++ ", " ++ t2 ++ ")" | (c,(t1,t2)) <- zip ("[":repeat ",") tests] ++
[" ]"]
data PW = P -- legacy posix
| W -- legacy windows
| AFP_P -- abstract-filepath posix
| AFP_W -- abstract-filepath windows
deriving Show
data Test = Test
{testPlatform :: PW
,testVars :: [(String,String)] -- generator constructor, variable
,testBody :: [String]
}
parseTest :: String -> [Test]
parseTest (stripPrefix "-- > " -> Just x) = platform $ toLexemes x
where
platform ("Windows":":":x) = [valid W x, valid AFP_W x]
platform ("Posix" :":":x) = [valid P x, valid AFP_P x]
platform x = [valid P x, valid W x, valid AFP_P x, valid AFP_W x]
valid p ("Valid":x) = free p a $ drop 1 b
where (a,b) = break (== "=>") x
valid p x = free p [] x
free p val x = Test p [(ctor v, v) | v <- vars] x
where vars = nub $ sort [v | v@[c] <- x, isAlpha c]
ctor v | v < "x" = ""
| v `elem` val = "QFilePathValid" ++ show p
| otherwise = case p of
AFP_P -> if v == "z" then "QFilePathsAFP_P" else "QFilePathAFP_P"
AFP_W -> if v == "z" then "QFilePathsAFP_W" else "QFilePathAFP_W"
_ -> if v == "z" then "" else "QFilePath"
parseTest _ = []
toLexemes :: String -> [String]
toLexemes x = case lex x of
[("","")] -> []
[(x,y)] -> x : toLexemes y
y -> error $ "Generate.toLexemes, " ++ show x ++ " -> " ++ show y
fromLexemes :: [String] -> String
fromLexemes = unwords . f
where
f ("`":x:"`":xs) = ("`" ++ x ++ "`") : f xs
f (x:y:xs) | x `elem` ["[","("] || y `elem` [",",")","]"] = f $ (x ++ y) : xs
f (x:xs) = x : f xs
f [] = []
renderTest :: Test -> (String, String)
renderTest Test{..} = (body, code)
where
code = "property $ " ++ if null testVars then body else "\\" ++ unwords vars ++ " -> " ++ body
vars = [if null ctor then v else "(" ++ ctor ++ " " ++ v ++ ")" | (ctor,v) <- testVars]
body = fromLexemes $ map (qualify testPlatform) testBody
qualify :: PW -> String -> String
qualify pw str
| str `elem` fpops || (all isAlpha str && length str > 1 && str `notElem` prelude)
= if str `elem` bs then qualifyBS str else show pw ++ "." ++ str
| otherwise = encode str
where
bs = ["null", "concat", "isPrefixOf", "isSuffixOf", "any"]
prelude = ["elem","uncurry","snd","fst","not","if","then","else"
,"True","False","Just","Nothing","fromJust","foldr"]
fpops = ["</>","<.>","-<.>"]
#ifdef GHC_MAKE
encode v
| isString' v = case pw of
AFP_P -> "(encodeUtf8 " <> v <> ")"
AFP_W -> "(encodeUtf16LE " <> v <> ")"
_ -> v
| isChar' v = case pw of
AFP_P -> "(fromIntegral . C.ord $ " <> v <> ")"
AFP_W -> "(fromIntegral . C.ord $ " <> v <> ")"
_ -> v
| otherwise = v
isString' xs@('"':_:_) = last xs == '"'
isString' _ = False
isChar' xs@('\'':_:_) = last xs == '\''
isChar' _ = False
qualifyBS v = case pw of
AFP_P -> "SBS." <> v
AFP_W -> "SBS16." <> v
_ -> v
#else
encode v
| isString' v = case pw of
AFP_P -> "(" <> v <> ")"
AFP_W -> "(" <> v <> ")"
_ -> v
| isChar' v = case pw of
AFP_P -> "(PW . fromIntegral . C.ord $ " <> v <> ")"
AFP_W -> "(WW . fromIntegral . C.ord $ " <> v <> ")"
_ -> v
| otherwise = v
isString' xs@('"':_:_) = last xs == '"'
isString' _ = False
isChar' xs@('\'':_:_) = last xs == '\''
isChar' _ = False
qualifyBS v = case pw of
AFP_P
| v == "concat" -> "(PS . SBS." <> v <> " . fmap getPosixString)"
| v == "any" -> "(\\f (getPosixString -> x) -> SBS." <> v <> " (f . PW) x)"
| v == "isPrefixOf" -> "(\\(getPosixString -> x) (getPosixString -> y) -> SBS." <> v <> " x y)"
| v == "isSuffixOf" -> "(\\(getPosixString -> x) (getPosixString -> y) -> SBS." <> v <> " x y)"
| otherwise -> "(SBS." <> v <> " . getPosixString)"
AFP_W
| v == "concat" -> "(WS . SBS16." <> v <> " . fmap getWindowsString)"
| v == "any" -> "(\\f (getWindowsString -> x) -> SBS16." <> v <> " (f . WW) x)"
| v == "isPrefixOf" -> "(\\(getWindowsString -> x) (getWindowsString -> y) -> SBS16." <> v <> " x y)"
| v == "isSuffixOf" -> "(\\(getWindowsString -> x) (getWindowsString -> y) -> SBS16." <> v <> " x y)"
| otherwise -> "(SBS16." <> v <> " . getWindowsString)"
_ -> v
#endif
---------------------------------------------------------------------
-- UTILITIES
writeFileBinary :: FilePath -> String -> IO ()
writeFileBinary file x = withBinaryFile file WriteMode $ \h -> hPutStr h x
readFileBinary' :: FilePath -> IO String
readFileBinary' file = withBinaryFile file ReadMode $ \h -> do
s <- hGetContents h
evaluate $ length s
pure s
writeFileBinaryChanged :: FilePath -> String -> IO ()
writeFileBinaryChanged file x = do
b <- doesFileExist file
old <- if b then fmap Just $ readFileBinary' file else pure Nothing
when (Just x /= old) $
writeFileBinary file x