Restructure

.gitignore

 Clean System Files/
-Tools/clean-compiler/
-Tools/cleantest
-Tools/makecleantest
+clean-compiler/
+cleantest
+makecleantest

Cloogle @ 6987d49d

-Subproject commit 6987d49de50bdef8d5ec4e3df04a90210d88903d

Tools/makecleantest.icl

-module makecleantest
-
-import _SystemArray
-import StdBool
-import StdFile
-from StdFunc import o
-import StdOrdList
-import StdString
-import StdTuple
-
-import Control.Monad => qualified join
-import Data.Error
-from Data.Func import $, mapSt, on, `on`, seqSt
-import Data.Functor
-import Data.List
-import Data.Maybe
-import Data.Tuple
-import System.CommandLine
-import System.Directory
-import System.Environment
-import System.File
-import System.FilePath
-import System.Options
-import System.Process
-import Text
-
-import CloogleDBFactory
-import Doc
-
-import TypeUtil
-
-:: Options =
-	{ directory        :: !FilePath
-	, modules          :: ![FilePath]
-	, output_directory :: !FilePath
-	, output_prefix    :: !String
-	, includes         :: ![FilePath]
-	, library_includes :: ![String]
-	, clean_home       :: !FilePath
-	, print_options    :: ![String]
-	, test_options     :: ![String]
-	, compile          :: !Bool
-	, clm_args         :: ![String]
-	, run              :: !Bool
-	, verbosity        :: !Int
-	, color            :: !Bool
-	}
-
-defaultOptions :: Options
-defaultOptions =
-	{ directory        = "."
-	, modules          = []
-	, output_directory = "."
-	, output_prefix    = "_Tests"
-	, includes         = []
-	, library_includes = ["Gast","Platform"]
-	, clean_home       = "/opt/clean"
-	, print_options    = []
-	, test_options     = []
-	, compile          = False
-	, clm_args         = []
-	, run              = False
-	, verbosity        = SUCCESS
-	, color            = True
-	}
-
-Start w
-// Command line
-# ([prog:args],w) = getCommandLine w
-# (clean_home,w) = appFst (fromMaybe "") $ getEnvironmentVariable "CLEAN_HOME" w
-# opts = parseOptions optionDescription args {defaultOptions & clean_home=clean_home}
-| isError opts = exit (join "\n" $ fromError opts) {defaultOptions & color=False} w
-# opts = fromOk opts
-# (modules,w) = case opts.modules of
-	[_:_] -> (Ok [opts.Options.directory </> replaceSubString "." {pathSeparator} mod +++ ".dcl" \\ mod <- opts.modules], w)
-	[]    -> findModules opts.Options.directory w
-| isError modules = exit (snd (fromError modules) +++ " while finding modules") opts w
-# w = seqSt (handleModule opts) (fromOk modules) w
-= w
-where
-	optionDescription :: Option Options
-	optionDescription = WithHelp True $ Options
-		[ Shorthand "-d" "--directory" $ Option
-			"--directory"
-			(\dir opts -> Ok {Options | opts & directory=dir})
-			"DIR"
-			"The directory to test modules from (default: .)"
-		, Shorthand "-m" "--module" $ Option
-			"--module"
-			(\mod opts -> Ok {opts & modules=opts.modules ++ [mod]})
-			"MOD"
-			"Add MOD to the to-test modules -- when no modules are given, all modules from --directory are used"
-		, Shorthand "-D" "--output-directory" $ Option
-			"--output-directory"
-			(\dir opts -> Ok {opts & output_directory=dir})
-			"DIR"
-			"Use DIR as directory for test modules (default: .)"
-		, Shorthand "-p" "--prefix" $ Option
-			"--prefix"
-			(\p opts -> Ok {opts & output_prefix=p})
-			"PREFIX"
-			"The prefix for test module names (default: _Tests, i.e., Data.Set goes to _Tests.Data.Set)"
-		, Shorthand "-I" "--include" $ Option
-			"--include"
-			(\dir opts -> Ok {opts & includes=opts.includes ++ [dir]})
-			"DIR"
-			"Add DIR to the include path"
-		, Shorthand "-IL" "--include-library" $ Option
-			"--include-library"
-			(\lib opts -> Ok {opts & library_includes=opts.library_includes ++ [lib]})
-			"LIB"
-			"Add CLEAN_HOME/lib/LIB to the include path"
-		, Shorthand "-H" "--clean-home" $ Option
-			"--clean-home"
-			(\h opts -> Ok {opts & clean_home=h})
-			"PATH"
-			"Set CLEAN_HOME to PATH (used to find libraries)"
-		, Shorthand "-P" "--print-option" $ Option
-			"--print-option"
-			(\po opts -> Ok {opts & print_options=opts.print_options ++ [po]})
-			"OPT"
-			"Add OPT to the print options (see Gast's PrintOption type)"
-		, Shorthand "-T" "--test-option" $ Option
-			"--test-option"
-			(\po opts -> Ok {opts & test_options=opts.test_options ++ [po]})
-			"OPT"
-			"Add OPT to the test options (see Gast's Testoption type)"
-		, Shorthand "-c" "--compile" $ Flag
-			"--compile"
-			(\opts -> Ok {opts & compile=True})
-			"Compile the tests after generation"
-		, Shorthand "-C" "--clm-arg" $ Option
-			"--clm-arg"
-			(\arg opts -> Ok {opts & clm_args=opts.clm_args ++ [arg]})
-			"ARG"
-			"Add ARG to the command line arguments for clm"
-		, Shorthand "-r" "--run" $ Flag
-			"--run"
-			(\opts -> Ok {opts & compile=True, run=True})
-			"Run the tests after generation (implies --compile)"
-		, Shorthand "-v" "--verbose" $ Flag
-			"--verbose"
-			(\opts -> Ok {opts & verbosity=inc opts.verbosity})
-			"Increase verbosity (can be given multiple times)"
-		, Shorthand "-q" "--quiet" $ Flag
-			"--quiet"
-			(\opts -> Ok {opts & verbosity=dec opts.verbosity})
-			"Decrease verbosity (can be given multiple times)"
-		, Flag "--no-color"
-			(\opts -> Ok {opts & color=False})
-			"Turn off color in output"
-		]
-
-exit :: !String !Options !*World -> *World
-exit error opts w = setReturnCode 1 $ output ERROR error opts w
-
-DEBUG   :== 5
-SUCCESS :== 4
-INFO    :== 3
-WARNING :== 2
-ERROR   :== 1
-
-output :: !Int !String !Options !*World -> *World
-output level s opts w
-| level > opts.verbosity = w
-# (io,w) = stdio w
-= snd $ fclose (io <<< color <<< s <<< newline) w
-where
-	color
-	| opts.color = case level of
-		DEBUG   -> "\033[0;36m"
-		INFO    -> "\033[0;34m"
-		SUCCESS -> "\033[0;32m"
-		WARNING -> "\033[0;33m"
-		ERROR   -> "\033[0;31m"
-	| otherwise = ""
-
-	newline = if opts.color "\033[0m\n" "\n"
-
-findModules :: !FilePath !*World -> *(!MaybeOSError [FilePath], !*World)
-findModules dir w
-# (files,w) = readDirectory dir w
-| isError files = (Error (fromError files), w)
-= appFst (fmap flatten o sequence) $ mapSt recurse [fp \\ fp <- fromOk files | not $ isMember fp [".",".."]] w
-where
-	recurse :: !FilePath !*World -> *(!MaybeOSError [FilePath], !*World)
-	recurse fp w
-	# fp = dir </> fp
-	# (info,w) = getFileInfo fp w
-	| isError info = (Error (fromError info), w)
-	| (fromOk info).FileInfo.directory = findModules fp w
-	| otherwise = (Ok (if (endsWith ".dcl" fp) [fp] []), w)
-
-handleModule :: !Options !FilePath !*World -> *World
-handleModule opts fp w
-# w = output DEBUG ("Checking " +++ fp +++ "...") opts w
-// Find properties
-# (funs,macros,_,_,_,_,_,_,(modname,mod,_),w) = findModuleContents False (dropExtension fp) w
-# output_modname = opts.output_prefix +++ "." +++ modname
-# output_filename = opts.output_directory </> replaceSubString "." {pathSeparator} output_modname +++ ".icl"
-# (nprops,props) = generatePropertyModule
-	output_modname
-	opts.print_options
-	opts.test_options
-	mod
-	[f \\ (_,f,_) <- funs ++ macros]
-// Write properties
-| nprops == 0 = w
-# w = output INFO ("Found " <+ nprops <+ " test cases in module " +++ modname) opts w
-# (dir,_) = splitFileName output_filename
-# (ok,w) = assertDirectory dir w
-| isError ok = exit (snd (fromError ok) <+ " " +++ output_filename) opts w
-# (ok,w) = writeFile output_filename props w
-| isError ok = exit (fromError ok <+ " " +++ output_filename) opts w
-// Compile tests
-| not opts.compile = w
-# w = output INFO ("Compiling " +++ output_modname +++ "...") opts w
-# output_exename = opts.output_directory </> output_modname
-# (ok,w) = callProcess "clm"
-	(opts.clm_args ++
-		interleave "-I" [opts.Options.directory:opts.includes] ++
-		interleave "-IL" opts.library_includes ++
-		["-nr", output_modname, "-o", output_exename]) Nothing w
-| isError ok = exit (snd (fromError ok) <+ " during compilation") opts w
-| fromOk ok <> 0 = exit "Compilation finished with non-zero exit code" opts w
-// Run tests
-| not opts.run = w
-# w = output INFO ("Running " +++ output_modname +++ "...") opts w
-# (ok,w) = callProcess output_exename [] Nothing w
-| isError ok = exit (snd (fromError ok) <+ " while running the tests") opts w
-| fromOk ok <> 0 = exit "Test finished with non-zero exit code" opts w
-= output SUCCESS (output_modname +++ " passed") opts w
-where
-	assertDirectory :: !FilePath !*World -> *(!MaybeOSError (), !*World)
-	assertDirectory "" w = (Ok (), w)
-	assertDirectory fp w
-	# (ex,w) = fileExists fp w
-	| ex = (Ok (), w)
-	# (base,_) = splitFileName fp
-	# (err,w) = assertDirectory base w
-	| isError err = (err, w)
-	= createDirectory fp w
-
-	interleave :: a [a] -> [a]
-	interleave _ []     = []
-	interleave g [x:xs] = [g,x:interleave g xs]
-
-generatePropertyModule :: !String ![String] ![String] !ModuleEntry ![FunctionEntry] -> (!Int, !String)
-generatePropertyModule name print_options test_options me fes = (length props, join "\n\n"
-	[ "module " +++ name
-	, "import Gast, Gast.CommandLine"
-	, bootstrap
-	, start
-	: [gp.gp_implementation \\ gp <- props]
-	])
-where
-	props = concatMap (generateProperties pvis) fes
-	where pvis = fromMaybe [] $ docPropertyTestWith <$> me.me_documentation
-
-	bootstrap = case me.me_documentation of
-		Just d  -> fromMaybe "" $ docPropertyBootstrap d
-		Nothing -> ""
-
-	start = join "\n\t"
-		[ "Start w = exposeProperties"
-		, "[" +++ join "," print_options +++ "]"
-		, "[" +++ join "," test_options +++ "]"
-		, "[ EP " +++ join "\n\t, EP " [gp.gp_name \\ gp <- props]
-		, "] w"
-		]
-
-:: GeneratedProperty =
-	{ gp_name           :: !String
-	, gp_implementation :: !String
-	}
-
-generateProperties :: ![PropertyVarInstantiation] !FunctionEntry -> [GeneratedProperty]
-generateProperties pvis fe=:{fe_documentation=Just doc} =
-	[gen i p config
-		\\ p <- doc.properties
-		, config <- configurations $ groupInstantiations $ pvis ++ docPropertyTestWith doc
-		& i <- [1..]]
-where
-	groupInstantiations :: [PropertyVarInstantiation] -> [[(String,Type)]]
-	groupInstantiations pvis = groupBy ((==) `on` fst) $ sortBy ((<) `on` fst) [vi \\ PropertyVarInstantiation vi <- pvis]
-
-	configurations :: [[(String,Type)]] -> [[(String,Type)]]
-	configurations [vis:viss] = [[vi`:vis`] \\ vi` <- vis, vis` <- configurations viss]
-	configurations [] = [[]]
-
-	gen :: !Int !Property ![(String,Type)] -> GeneratedProperty
-	gen i (ForAll name ts imp) vis =
-		{ gp_name = name`
-		, gp_implementation = join "\n"
-			[ name` +++ " :: " +++ toString type
-			, join " " [name`:map fst ts] +++ " = " +++ imp
-			]
-		}
-	where
-		name` = if (i == 1) name (name +++ "_" +++ toString i)
-		type = fromJust $ assignAll vis $ Func (map snd ts) (Type "Property" []) []
-generateProperties _ _ = []