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