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