Commit f1531f18 authored by Camil Staps's avatar Camil Staps 🚀

Restructure

parent 182c6e7a
Clean System Files/ Clean System Files/
Tools/clean-compiler/ clean-compiler/
Tools/cleantest cleantest
Tools/makecleantest makecleantest
Cloogle @ 6987d49d
Subproject commit 6987d49de50bdef8d5ec4e3df04a90210d88903d
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 _ _ = []
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment