1- {-# LANGUAGE RecordWildCards, ViewPatterns #-}
1+ {-# LANGUAGE CPP, RecordWildCards, ViewPatterns #-}
22
33module Generate (main ) where
44
55import Control.Exception
66import Control.Monad
7+ import Data.Semigroup
78import Data.Char
89import Data.List
910import System.Directory
@@ -16,19 +17,36 @@ main = do
1617 let tests = map renderTest $ concatMap parseTest $ lines src
1718 writeFileBinaryChanged " tests/TestGen.hs" $ unlines $
1819 [" -- GENERATED CODE: See ../Generate.hs"
20+ #ifndef GHC_MAKE
21+ , " {-# LANGUAGE OverloadedStrings #-}"
22+ , " {-# LANGUAGE ViewPatterns #-}"
23+ #endif
1924 ," module TestGen(tests) where"
2025 ," import TestUtil"
26+ ," import Prelude as P"
27+ ," import Data.Semigroup"
28+ ," import qualified Data.Char as C"
29+ ," import qualified Data.ByteString.Short as SBS"
30+ ," import qualified System.AbstractFilePath.Data.ByteString.Short.Word16 as SBS16"
2131 ," import qualified System.FilePath.Windows as W"
2232 ," import qualified System.FilePath.Posix as P"
23- ," {-# ANN module \" HLint: ignore\" #-}"
33+ #ifdef GHC_MAKE
34+ ," import qualified System.AbstractFilePath.Windows.Internal as AFP_W"
35+ ," import qualified System.AbstractFilePath.Posix.Internal as AFP_P"
36+ #else
37+ ," import System.AbstractFilePath.Types"
38+ ," import qualified System.AbstractFilePath.Windows as AFP_W"
39+ ," import qualified System.AbstractFilePath.Posix as AFP_P"
40+ #endif
41+ , " import System.AbstractFilePath.Data.ByteString.Short.Encode"
2442 ," tests :: [(String, Property)]"
2543 ," tests =" ++
2644 [" " ++ c ++ " (" ++ show t1 ++ " , " ++ t2 ++ " )" | (c,(t1,t2)) <- zip (" [" : repeat " ," ++
2745 [" ]"
2846
2947
3048
31- data PW = P | W deriving Show -- Posix or Windows
49+ data PW = P | W | AFP_P | AFP_W deriving Show -- Posix or Windows
3250data Test = Test
3351 { testPlatform :: PW
3452 ,testVars :: [(String String -- generator constructor, variable
@@ -39,19 +57,22 @@ data Test = Test
3957parseTest :: String -> [Test ]
4058parseTest (stripPrefix " -- > " -> Just x) = platform $ toLexemes x
4159 where
42- platform (" Windows" : " :" : x) = [valid W x]
43- platform (" Posix" : " :" : x) = [valid P x]
44- platform x = [valid P x, valid W x]
60+ platform (" Windows" : " :" : x) = [valid W x, valid AFP_W x ]
61+ platform (" Posix" : " :" : x) = [valid P x, valid AFP_P x ]
62+ platform x = [valid P x, valid W x, valid AFP_P x, valid AFP_W x ]
4563
4664 valid p (" Valid" : x) = free p a $ drop 1 b
4765 where (a,b) = break (== " =>"
4866 valid p x = free p [] x
4967
5068 free p val x = Test p [(ctor v, v) | v <- vars] x
5169 where vars = nub $ sort [v | v@ [c] <- x, isAlpha c]
52- ctor v | v < " x" = " "
70+ ctor v | v < " x" = " "
5371 | v `elem` val = " QFilePathValid" ++ show p
54- | otherwise = " QFilePath"
72+ | otherwise = case p of
73+ AFP_P -> if v == " z" then " QFilePathsAFP_P" else " QFilePathAFP_P"
74+ AFP_W -> if v == " z" then " QFilePathsAFP_W" else " QFilePathAFP_W"
75+ _ -> if v == " z" then " " else " QFilePath"
5576parseTest _ = []
5677
5778
@@ -80,14 +101,67 @@ renderTest Test{..} = (body, code)
80101 body = fromLexemes $ map (qualify testPlatform) testBody
81102
82103
104+
83105qualify :: PW -> String -> String
84106qualify pw str
85- | str `elem` fpops || (all isAlpha str && length str > 1 && str `notElem` prelude) = show pw ++ " ." ++ str
86- | otherwise = str
107+ | str `elem` fpops || (all isAlpha str && length str > 1 && str `notElem` prelude)
108+ = if str `elem` bs then qualifyBS str else show pw ++ " ." ++ str
109+ | otherwise = encode str
87110 where
88- prelude = [" elem" " uncurry" " snd" " fst" " not" " null" " if" " then" " else"
89- ," True" " False" " Just" " Nothing" " fromJust" " concat" " isPrefixOf" " isSuffixOf" " any" " foldr"
111+ bs = [" null" " concat" " isPrefixOf" " isSuffixOf" " any"
112+ prelude = [" elem" " uncurry" " snd" " fst" " not" " if" " then" " else"
113+ ," True" " False" " Just" " Nothing" " fromJust" " foldr"
90114 fpops = [" </>" " <.>" " -<.>"
115+ #ifdef GHC_MAKE
116+ encode v
117+ | isString' v = case pw of
118+ AFP_P -> " (encodeUtf8 " <> v <> " )"
119+ AFP_W -> " (encodeUtf16LE " <> v <> " )"
120+ _ -> v
121+ | isChar' v = case pw of
122+ AFP_P -> " (fromIntegral . C.ord $ " <> v <> " )"
123+ AFP_W -> " (fromIntegral . C.ord $ " <> v <> " )"
124+ _ -> v
125+ | otherwise = v
126+ isString' xs@ (' "' : _: _) = last xs == ' "'
127+ isString' _ = False
128+ isChar' xs@ (' \' ' : _: _) = last xs == ' \' '
129+ isChar' _ = False
130+ qualifyBS v = case pw of
131+ AFP_P -> " SBS." <> v
132+ AFP_W -> " SBS16." <> v
133+ _ -> v
134+ #else
135+ encode v
136+ | isString' v = case pw of
137+ AFP_P -> " (" <> v <> " )"
138+ AFP_W -> " (" <> v <> " )"
139+ _ -> v
140+ | isChar' v = case pw of
141+ AFP_P -> " (PW . fromIntegral . C.ord $ " <> v <> " )"
142+ AFP_W -> " (WW . fromIntegral . C.ord $ " <> v <> " )"
143+ _ -> v
144+ | otherwise = v
145+ isString' xs@ (' "' : _: _) = last xs == ' "'
146+ isString' _ = False
147+ isChar' xs@ (' \' ' : _: _) = last xs == ' \' '
148+ isChar' _ = False
149+ qualifyBS v = case pw of
150+ AFP_P
151+ | v == " concat" -> " (PS . SBS." <> v <> " . fmap unPFP)"
152+ | v == " any" -> " (\\ f (unPFP -> x) -> SBS." <> v <> " (f . PW) x)"
153+ | v == " isPrefixOf" -> " (\\ (unPFP -> x) (unPFP -> y) -> SBS." <> v <> " x y)"
154+ | v == " isSuffixOf" -> " (\\ (unPFP -> x) (unPFP -> y) -> SBS." <> v <> " x y)"
155+ | otherwise -> " (SBS." <> v <> " . unPFP)"
156+ AFP_W
157+ | v == " concat" -> " (WS . SBS16." <> v <> " . fmap unWFP)"
158+ | v == " any" -> " (\\ f (unWFP -> x) -> SBS16." <> v <> " (f . WW) x)"
159+ | v == " isPrefixOf" -> " (\\ (unWFP -> x) (unWFP -> y) -> SBS16." <> v <> " x y)"
160+ | v == " isSuffixOf" -> " (\\ (unWFP -> x) (unWFP -> y) -> SBS16." <> v <> " x y)"
161+ | otherwise -> " (SBS16." <> v <> " . unWFP)"
162+ _ -> v
163+ #endif
164+
91165
92166
93167---------------------------------------------------------------------
0 commit comments