git @ Cat's Eye Technologies Falderal / abafe29
Refactor in the process of implementing skip-functionality. catseye 10 years ago
3 changed file(s) with 90 addition(s) and 46 deletion(s). Raw diff Collapse all Expand all
6060 --
6161
6262 data Block = Section String
63 | Directive Directive
6364 | Test Int [Functionality] String String Expectation (Maybe Expectation)
6465 deriving (Show, Eq, Ord)
6566
00 module Test.Falderal.Loader (
11 loadFile,
2 loadFiles,
32 loadText,
43 parseFunctionality
54 ) where
2221 (ls, bs) <- return $ loadText testText funcsToClear givenFuncDefs
2322 return (ls, bs)
2423
25 loadFiles [] funcsToClear givenFuncDefs = do
26 return ([], [])
27 loadFiles (fileName:rest) funcsToClear givenFuncDefs = do
28 (ls, bs) <- loadFile fileName funcsToClear givenFuncDefs
29 (restLs, restBs) <- loadFiles rest funcsToClear givenFuncDefs
30 return (ls ++ restLs, bs ++ restBs)
31
32 --
33 -- Returns both the (coaslesced) lines and the (redescribed) blocks,
34 -- allowing the caller to choose which one they want to look at.
24 --
25 -- Returns a pair of the lines and the blocks, allowing the caller to choose
26 -- which one they want to look at.
27 --
28 -- Note that the lines so returned are coalesced, and contain parsed pragmas.
29 --
30 -- SOON:
31 -- Note that the blocks so returned are redescribed, but are not processed;
32 -- that is, named functionalities are not expanded to their underlying
33 -- implementations. We leave this up to the caller. The functions to do
34 -- the processing should maybe be in some module other than this one.
3535 --
3636
3737 loadText text funcsToClear givenFuncDefs =
4141 fds = (collectFunctionalityDefinitions ls')
4242 fds' = clearFuncs fds funcsToClear
4343 fds'' = fds' ++ givenFuncDefs
44 bs = convertLinesToBlocks ls' [] fds''
45 bs' = reDescribeBlocks bs
46 in
47 (ls', bs')
44 bs = convertLinesToBlocks ls'
45 bs' = assignFunctionalities bs [] fds''
46 bs'' = reDescribeBlocks bs'
47 in
48 (ls', bs'')
4849
4950 transformLines ls =
5051 let
112113 resolvePragmas [] = []
113114
114115 --
115 -- Convert (coalesced) lines to blocks.
116 --
117
118 convertLinesToBlocks :: [Line] -> [Functionality] -> [(String, Functionality)] -> [Block]
119
120 convertLinesToBlocks ((LiteralText literalText):(TestInput testText):(ExpectedResult expected):rest) fns fnMap =
121 ((Test 0 fns literalText testText (Output expected) Nothing):(convertLinesToBlocks rest fns fnMap))
122 convertLinesToBlocks ((LiteralText literalText):(TestInput testText):(ExpectedError expected):rest) fns fnMap =
123 ((Test 0 fns literalText testText (Exception expected) Nothing):(convertLinesToBlocks rest fns fnMap))
124 convertLinesToBlocks ((TestInput testText):(ExpectedResult expected):rest) fns fnMap =
125 ((Test 0 fns "(undescribed output test)" testText (Output expected) Nothing):(convertLinesToBlocks rest fns fnMap))
126 convertLinesToBlocks ((TestInput testText):(ExpectedError expected):rest) fns fnMap =
127 ((Test 0 fns "(undescribed output test)" testText (Exception expected) Nothing):(convertLinesToBlocks rest fns fnMap))
128 convertLinesToBlocks ((SectionHeading text):rest) fn fnMap =
129 ((Section text):(convertLinesToBlocks rest fn fnMap))
130 convertLinesToBlocks ((Pragma _ (Just (TestsFor (NamedFunctionality name)))):rest) fns fnMap =
116 -- Convert (coalesced) lines to blocks. We expect the pragmas to have
117 -- been parsed, and retain directives from them in the blocks.
118 --
119
120 convertLinesToBlocks :: [Line] -> [Block]
121
122 convertLinesToBlocks ((LiteralText literalText):(TestInput testText):(ExpectedResult expected):rest) =
123 (Test 0 [] literalText testText (Output expected) Nothing):convertLinesToBlocks rest
124 convertLinesToBlocks ((LiteralText literalText):(TestInput testText):(ExpectedError expected):rest) =
125 (Test 0 [] literalText testText (Exception expected) Nothing):convertLinesToBlocks rest
126 convertLinesToBlocks ((TestInput testText):(ExpectedResult expected):rest) =
127 (Test 0 [] "(undescribed output test)" testText (Output expected) Nothing):convertLinesToBlocks rest
128 convertLinesToBlocks ((TestInput testText):(ExpectedError expected):rest) =
129 (Test 0 [] "(undescribed error test)" testText (Exception expected) Nothing):convertLinesToBlocks rest
130 convertLinesToBlocks ((SectionHeading text):rest) =
131 (Section text):convertLinesToBlocks rest
132 convertLinesToBlocks ((Pragma _ (Just dir)):rest) =
133 (Directive dir):convertLinesToBlocks rest
134 convertLinesToBlocks ((LiteralText _):(SectionHeading text):rest) =
135 ((Section text):convertLinesToBlocks rest)
136 convertLinesToBlocks (_:rest) =
137 convertLinesToBlocks rest
138 convertLinesToBlocks [] = []
139
140 --
141 -- Give each test block a functionality, expanding named functionalities to
142 -- concrete functionalities as needed. Strip all Directives and Sections(?)
143 -- from the list of blocks.
144 --
145
146 assignFunctionalities :: [Block] -> [Functionality] -> [(String, Functionality)] -> [Block]
147
148 assignFunctionalities ((Test 0 [] literalText testText expectation Nothing):rest) fns fnMap =
149 (Test 0 fns literalText testText expectation Nothing):assignFunctionalities rest fns fnMap
150
151 assignFunctionalities ((Directive (TestsFor (NamedFunctionality name))):rest) fns fnMap =
131152 case map (snd) $ filter (\(s,fn) -> s == name) fnMap of
132153 [] -> error ("Can't find " ++ name ++ " in " ++ (show fnMap))
133 fns' -> convertLinesToBlocks rest fns' fnMap
134 convertLinesToBlocks ((Pragma _ (Just (TestsFor fn))):rest) fns fnMap =
135 convertLinesToBlocks rest [fn] fnMap
136 convertLinesToBlocks ((Pragma _ Nothing):rest) fns fnMap =
137 error $ "should have resolved all pragmas to directives by now"
138 convertLinesToBlocks ((Pragma _ _):rest) fns fnMap =
139 convertLinesToBlocks rest fns fnMap
140 convertLinesToBlocks ((LiteralText _):(SectionHeading text):rest) fns fnMap =
141 ((Section text):(convertLinesToBlocks rest fns fnMap))
142
143 convertLinesToBlocks (_:rest) fns fnMap =
144 convertLinesToBlocks rest fns fnMap
145 convertLinesToBlocks [] _ _ = []
154 fns' -> assignFunctionalities rest fns' fnMap
155
156 assignFunctionalities ((Directive (TestsFor fn)):rest) fns fnMap =
157 assignFunctionalities rest [fn] fnMap
158
159 assignFunctionalities (_:rest) fns fnMap =
160 assignFunctionalities rest fns fnMap
161
162 assignFunctionalities [] _ _ = []
163
164 --
165 -- Collect Functionality-definition pragmas.
166 --
146167
147168 collectFunctionalityDefinitions ((Pragma _ (Just (FunctionalityDefinition name functionality))):rest) =
148169 ((name, functionality):collectFunctionalityDefinitions rest)
22 import System.Console.GetOpt
33
44 import Test.Falderal.Common
5 import Test.Falderal.Loader (loadFiles, parseFunctionality)
5 import Test.Falderal.Loader (loadFile, parseFunctionality)
66 import Test.Falderal.Partitioner (
77 partitionTests,
88 isHaskellFunctionality,
2727 | Verbosity String
2828 | Functionality String
2929 | ClearFunctionality String
30 | SkipFunctionality String
3031 | Messy
3132 deriving (Show, Ord, Eq)
3233
6566 determineFunctionalitiesToClear (_:rest) =
6667 determineFunctionalitiesToClear rest
6768
69 determineFunctionalitiesToSkip [] = []
70 determineFunctionalitiesToSkip (SkipFunctionality name:rest) =
71 (name:determineFunctionalitiesToSkip rest)
72 determineFunctionalitiesToSkip (_:rest) =
73 determineFunctionalitiesToSkip rest
74
6875 --
6976 -- Command-line entry point
7077 --
8794 Option ['c'] ["clear-functionality"] (ReqArg ClearFunctionality "NAME") "clear all implementations of a named functionality",
8895 Option ['f'] ["functionality"] (ReqArg Functionality "SPEC") "specify additional implementation of a named functionality",
8996 Option ['h'] ["haskell-command"] (ReqArg HaskellRunCommand "CMD") "command to run Haskell tests (default: 'runhaskell')",
97 Option ['k'] ["skip-functionality"] (ReqArg SkipFunctionality "NAME") "skip all tests for this named functionality",
9098 Option ['m'] ["messy"] (NoArg Messy) "messy: do not delete generated files (default: clean)",
9199 Option ['r'] ["report-format"] (ReqArg ReportFormat "FORMAT") "success/failure report format (default: standard)",
92100 Option ['s'] ["shell-command"] (ReqArg ShellRunCommand "CMD") "command to run shell scripts (default: 'sh')",
103111 verbosity = determineVerbosity flags
104112 funcDefs = collectFunctionalityDefinitions flags
105113 funcsToClear = determineFunctionalitiesToClear flags
114 funcsToSkip = determineFunctionalitiesToSkip flags
106115 preds = [isHaskellFunctionality, isShellFunctionality]
107116 in do
108117 (lines, blocks) <- loadFiles fileNames funcsToClear funcDefs
109 [haskellBlocks, shellBlocks] <- return $ partitionTests preds blocks
118 --print blocks
119 blocks' <- return $ removeFuncsToSkip blocks funcsToSkip
120 [haskellBlocks, shellBlocks] <- return $ partitionTests preds blocks'
110121 haskellBlocks' <- testHaskell haskellBlocks flags
111122 shellBlocks' <- testShell shellBlocks flags
112123 report reportFormat (haskellBlocks' ++ shellBlocks')
129140
130141 testShell blocks flags =
131142 runTests blocks "GeneratedFalderalTests.sh" "shell" ((determineShellRunCommand flags) ++ " GeneratedFalderalTests.sh") (Messy `elem` flags)
143
144 removeFuncsToSkip blocks funcsToSkip =
145 blocks
146
147 loadFiles [] funcsToClear givenFuncDefs = do
148 return ([], [])
149 loadFiles (fileName:rest) funcsToClear givenFuncDefs = do
150 (ls, bs) <- loadFile fileName funcsToClear givenFuncDefs
151 (restLs, restBs) <- loadFiles rest funcsToClear givenFuncDefs
152 return (ls ++ restLs, bs ++ restBs)
153