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