1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
-- This module generates the files src/Extra.hs and test/TestGen.hs.
-- Typical usage is run:
--
-- * `cabal test` to install the necessary packages
-- * `cabal exec ghci` to get into GHCi
-- * `:go` or `:generate` to run this generator
module Generate(main) where
import Data.List.Extra
import System.IO.Extra
import Control.Exception
import Control.Monad.Extra
import System.FilePath
import System.Directory
import Data.Char
import Data.Maybe
import Data.Functor
import Prelude
main :: IO ()
main = do
src <- readFile "extra.cabal"
let mods = filter (isSuffixOf ".Extra") $ map trim $ lines src
ifaces <- forM (mods \\ exclude) $ \mod -> do
src <- readFile $ joinPath ("src" : split (== '.') mod) <.> "hs"
let funcs = filter validIdentifier $ takeWhile (/= "where") $
words $ replace "," " " $ drop1 $ dropWhile (/= '(') $
unlines $ filter (\x -> not $ any (`isPrefixOf` trim x) ["--","#"]) $ lines src
let tests = if mod `elem` excludeTests then [] else mapMaybe (stripPrefix "-- > ") $ lines src
pure (mod, funcs, tests)
writeFileBinaryChanged "src/Extra.hs" $ unlines $
["-- GENERATED CODE - DO NOT MODIFY"
,"-- See Generate.hs for details of how to generate"
,""
,"-- | This module documents all the functions available in this package."
,"--"
,"-- Most users should import the specific modules (e.g. @\"Data.List.Extra\"@), which"
,"-- also reexport their non-@Extra@ modules (e.g. @\"Data.List\"@)."
,"module Extra {-# DEPRECATED \"This module is provided as documentation of all new functions, you should import the more specific modules directly.\" #-} ("] ++
concat [ [" -- * " ++ mod
," -- | Extra functions available in @" ++ show mod ++ "@."
," " ++ unwords (map (++",") $ filter (notHidden mod) funs)]
| (mod,funs@(_:_),_) <- ifaces] ++
[" ) where"
,""] ++
["import " ++ addHiding mod | (mod,_:_,_) <- ifaces]
writeFileBinaryChanged "test/TestGen.hs" $ unlines $
["-- GENERATED CODE - DO NOT MODIFY"
,"-- See Generate.hs for details of how to generate"
,""
,"{-# LANGUAGE ExtendedDefaultRules, ScopedTypeVariables, TypeApplications, ViewPatterns #-}"
,"{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}"
,"module TestGen(tests) where"
,"import TestUtil"
,"import qualified Data.Ord"
,"import Test.QuickCheck.Instances.Semigroup ()"
,"default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char))"
,"tests :: IO ()"
,"tests = do"] ++
[" " ++ if "let " `isPrefixOf` t then t else "testGen " ++ show t ++ " $ " ++ tweakTest t | (_,_,ts) <- ifaces, t <- rejoin ts]
rejoin :: [String] -> [String]
rejoin (x1:x2:xs) | " " `isPrefixOf` x2 = rejoin $ (x1 ++ x2) : xs
rejoin (x:xs) = x : rejoin xs
rejoin [] = []
writeFileBinaryChanged :: FilePath -> String -> IO ()
writeFileBinaryChanged file x = do
evaluate $ length x -- ensure we don't write out files with _|_ in them
old <- ifM (doesFileExist file) (Just <$> readFileBinary' file) (pure Nothing)
when (Just x /= old) $
writeFileBinary file x
exclude :: [String]
exclude =
["Data.Foldable.Extra" -- because all their imports clash
]
excludeTests :: [String]
-- FIXME: Should probably generate these in another module
excludeTests =
["Data.List.NonEmpty.Extra" -- because !? clashes and is tested
]
hidden :: String -> [String]
hidden "Data.List.NonEmpty.Extra" = words
"cons snoc sortOn union unionBy nubOrd nubOrdBy nubOrdOn (!?) foldl1' repeatedly compareLength"
hidden _ = []
notHidden :: String -> String -> Bool
notHidden mod fun = fun `notElem` hidden mod
addHiding :: String -> String
addHiding mod
| xs@(_:_) <- hidden mod = mod ++ " hiding (" ++ intercalate ", " xs ++ ")"
| otherwise = mod
validIdentifier xs =
(take 1 xs == "(" || isName (takeWhile (/= '(') xs)) &&
xs `notElem` ["module","Numeric"]
isName (x:xs) = isAlpha x && all (\x -> isAlphaNum x || x `elem` "_'") xs
isName _ = False
tweakTest x
| Just x <- stripSuffix " == undefined" x =
if not $ "\\" `isPrefixOf` x then
(if "fileEq" `isInfixOf` x then "erroneousIO $ " else "erroneous $ ") ++ trim x
else
let (a,b) = breakOn "->" $ trim x
in a ++ "-> erroneous $ " ++ trim (drop 2 b)
| otherwise = x
|
