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,41 @@ 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 System.AbstractFilePath.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 -- legacy posix
50+ | W -- legacy windows
51+ | AFP_P -- abstract-filepath posix
52+ | AFP_W -- abstract-filepath windows
53+ deriving Show
54+
3255data Test = Test
3356 { testPlatform :: PW
3457 ,testVars :: [(String String -- generator constructor, variable
@@ -39,19 +62,22 @@ data Test = Test
3962parseTest :: String -> [Test ]
4063parseTest (stripPrefix " -- > " -> Just x) = platform $ toLexemes x
4164 where
42- platform (" Windows" : " :" : x) = [valid W x]
43- platform (" Posix" : " :" : x) = [valid P x]
44- platform x = [valid P x, valid W x]
65+ platform (" Windows" : " :" : x) = [valid W x, valid AFP_W x ]
66+ platform (" Posix" : " :" : x) = [valid P x, valid AFP_P x ]
67+ platform x = [valid P x, valid W x, valid AFP_P x, valid AFP_W x ]
4568
4669 valid p (" Valid" : x) = free p a $ drop 1 b
4770 where (a,b) = break (== " =>"
4871 valid p x = free p [] x
4972
5073 free p val x = Test p [(ctor v, v) | v <- vars] x
5174 where vars = nub $ sort [v | v@ [c] <- x, isAlpha c]
52- ctor v | v < " x" = " "
75+ ctor v | v < " x" = " "
5376 | v `elem` val = " QFilePathValid" ++ show p
54- | otherwise = " QFilePath"
77+ | otherwise = case p of
78+ AFP_P -> if v == " z" then " QFilePathsAFP_P" else " QFilePathAFP_P"
79+ AFP_W -> if v == " z" then " QFilePathsAFP_W" else " QFilePathAFP_W"
80+ _ -> if v == " z" then " " else " QFilePath"
5581parseTest _ = []
5682
5783
@@ -80,14 +106,67 @@ renderTest Test{..} = (body, code)
80106 body = fromLexemes $ map (qualify testPlatform) testBody
81107
82108
109+
83110qualify :: PW -> String -> String
84111qualify pw str
85- | str `elem` fpops || (all isAlpha str && length str > 1 && str `notElem` prelude) = show pw ++ " ." ++ str
86- | otherwise = str
112+ | str `elem` fpops || (all isAlpha str && length str > 1 && str `notElem` prelude)
113+ = if str `elem` bs then qualifyBS str else show pw ++ " ." ++ str
114+ | otherwise = encode str
87115 where
88- prelude = [" elem" " uncurry" " snd" " fst" " not" " null" " if" " then" " else"
89- ," True" " False" " Just" " Nothing" " fromJust" " concat" " isPrefixOf" " isSuffixOf" " any" " foldr"
116+ bs = [" null" " concat" " isPrefixOf" " isSuffixOf" " any"
117+ prelude = [" elem" " uncurry" " snd" " fst" " not" " if" " then" " else"
118+ ," True" " False" " Just" " Nothing" " fromJust" " foldr"
90119 fpops = [" </>" " <.>" " -<.>"
120+ #ifdef GHC_MAKE
121+ encode v
122+ | isString' v = case pw of
123+ AFP_P -> " (encodeUtf8 " <> v <> " )"
124+ AFP_W -> " (encodeUtf16LE " <> v <> " )"
125+ _ -> v
126+ | isChar' v = case pw of
127+ AFP_P -> " (fromIntegral . C.ord $ " <> v <> " )"
128+ AFP_W -> " (fromIntegral . C.ord $ " <> v <> " )"
129+ _ -> v
130+ | otherwise = v
131+ isString' xs@ (' "' : _: _) = last xs == ' "'
132+ isString' _ = False
133+ isChar' xs@ (' \' ' : _: _) = last xs == ' \' '
134+ isChar' _ = False
135+ qualifyBS v = case pw of
136+ AFP_P -> " SBS." <> v
137+ AFP_W -> " SBS16." <> v
138+ _ -> v
139+ #else
140+ encode v
141+ | isString' v = case pw of
142+ AFP_P -> " (" <> v <> " )"
143+ AFP_W -> " (" <> v <> " )"
144+ _ -> v
145+ | isChar' v = case pw of
146+ AFP_P -> " (PW . fromIntegral . C.ord $ " <> v <> " )"
147+ AFP_W -> " (WW . fromIntegral . C.ord $ " <> v <> " )"
148+ _ -> v
149+ | otherwise = v
150+ isString' xs@ (' "' : _: _) = last xs == ' "'
151+ isString' _ = False
152+ isChar' xs@ (' \' ' : _: _) = last xs == ' \' '
153+ isChar' _ = False
154+ qualifyBS v = case pw of
155+ AFP_P
156+ | v == " concat" -> " (PS . SBS." <> v <> " . fmap unPFP)"
157+ | v == " any" -> " (\\ f (unPFP -> x) -> SBS." <> v <> " (f . PW) x)"
158+ | v == " isPrefixOf" -> " (\\ (unPFP -> x) (unPFP -> y) -> SBS." <> v <> " x y)"
159+ | v == " isSuffixOf" -> " (\\ (unPFP -> x) (unPFP -> y) -> SBS." <> v <> " x y)"
160+ | otherwise -> " (SBS." <> v <> " . unPFP)"
161+ AFP_W
162+ | v == " concat" -> " (WS . SBS16." <> v <> " . fmap unWFP)"
163+ | v == " any" -> " (\\ f (unWFP -> x) -> SBS16." <> v <> " (f . WW) x)"
164+ | v == " isPrefixOf" -> " (\\ (unWFP -> x) (unWFP -> y) -> SBS16." <> v <> " x y)"
165+ | v == " isSuffixOf" -> " (\\ (unWFP -> x) (unWFP -> y) -> SBS16." <> v <> " x y)"
166+ | otherwise -> " (SBS16." <> v <> " . unWFP)"
167+ _ -> v
168+ #endif
169+
91170
92171
93172---------------------------------------------------------------------
0 commit comments