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