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 \\ exclude) $ \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, TypeApplications, ViewPatterns #-}"
50        ,"module TestGen(tests) where"
51        ,"import TestUtil"
52        ,"import qualified Data.List"
53        ,"import qualified Data.List.NonEmpty.Extra"
54        ,"import qualified Data.Ord"
55        ,"import Test.QuickCheck.Instances.Semigroup ()"
56        ,"default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char))"
57        ,"tests :: IO ()"
58        ,"tests = do"] ++
59        ["    " ++ if "let " `isPrefixOf` t then t else "testGen " ++ show t ++ " $ " ++ tweakTest t | (_,_,ts) <- ifaces, t <- rejoin ts]
60
61rejoin :: [String] -> [String]
62rejoin (x1:x2:xs) | " " `isPrefixOf` x2 = rejoin $ (x1 ++ x2) : xs
63rejoin (x:xs) = x : rejoin xs
64rejoin [] = []
65
66writeFileBinaryChanged :: FilePath -> String -> IO ()
67writeFileBinaryChanged file x = do
68    evaluate $ length x -- ensure we don't write out files with _|_ in them
69    old <- ifM (doesFileExist file) (Just <$> readFileBinary' file) (pure Nothing)
70    when (Just x /= old) $
71        writeFileBinary file x
72
73exclude :: [String]
74exclude = ["Data.Foldable.Extra"] -- because all their imports clash
75
76hidden :: String -> [String]
77hidden "Data.List.NonEmpty.Extra" = words
78    "cons snoc sortOn union unionBy nubOrd nubOrdBy nubOrdOn"
79hidden _ = []
80
81notHidden :: String -> String -> Bool
82notHidden mod fun = fun `notElem` hidden mod
83
84addHiding :: String -> String
85addHiding mod
86  | xs@(_:_) <- hidden mod = mod ++ " hiding (" ++ intercalate ", " xs ++ ")"
87  | otherwise = mod
88
89validIdentifier xs =
90    (take 1 xs == "(" || isName (takeWhile (/= '(') xs)) &&
91    xs `notElem` ["module","Numeric"]
92
93isName (x:xs) = isAlpha x && all (\x -> isAlphaNum x || x `elem` "_'") xs
94isName _ = False
95
96tweakTest x
97    | Just x <- stripSuffix " == undefined" x =
98        if not $ "\\" `isPrefixOf` x then
99            (if "fileEq" `isInfixOf` x then "erroneousIO $ " else "erroneous $ ") ++ trim x
100        else
101            let (a,b) = breakOn "->" $ trim x
102            in a ++ "-> erroneous $ " ++ trim (drop 2 b)
103    | otherwise = x
104