haskell-te: a1c21702f53a1d9387d732f55eeeec697a599a75
1: { bash, checkStderr, dumpToNix, extractedEnv, fail, getDepsScript,
2: haskellPackages, jq, lib, mkBin, nixedHsPkg, pkgName, runCommand,
3: runTypesScript, runTypesScriptData, testData, unpack, utillinux, withDeps,
4: wrap }:
5:
6: with builtins;
7: with lib;
8:
9: with rec {
10: getArities = mkBin {
11: name = "getArities";
12: paths = [ bash jq ];
13: vars = {
14: # Extract the name and module from the qname of each object
15: EXTRACT =
16: with rec {
17: # Splits a qualified name into a module and a name ("bits")
18: input = ''(.qname | split(".") | reverse) as $bits'';
19:
20: # The name is the last "bit"
21: name = ''$bits[0]'';
22:
23: # The module is all except the last "bit", joined by dots
24: mod = ''$bits[1:] | reverse | join(".")'';
25: };
26: "${input} | . + {name: ${name}, module: ${mod}}";
27:
28: # There may be duplicates: one which is hashed and one which isn't. We
29: # prefer to be hashed if possible, so we update each objects' "hashable"
30: # field to true if the array contains a hashable object with the same
31: # qname.
32: SET_HASHABLE = ''
33: . as $all | map(.qname as $qn | . + {
34: "hashable": ($all | map(select(.qname == $qn) | .hashable) | any)
35: })
36: '';
37:
38: # Any duplicates will be identical, including their "hashable" field, so we
39: # can dedupe using "unique".
40: UNIQUIFY = ". | unique | map(del(.qname))";
41: };
42: script = ''
43: #!${bash}/bin/bash
44: set -e
45:
46: # Keep lines which look like JSON objects
47: grep '^{' | jq -c -M "$EXTRACT" | # Set the right name
48: jq -s -M "$SET_HASHABLE" | # Prefer hashable
49: jq "$UNIQUIFY" # Remove dupes
50: '';
51: };
52:
53: getTypes = mkBin {
54: name = "getTypes";
55: paths = [ bash jq utillinux ];
56: script = ''
57: #!${bash}/bin/bash
58: set -e
59:
60: # Monomorphic types come in via stdin
61:
62: function trim {
63: grep -o '[^ ].*[^ ]'
64: }
65:
66: # Turn (foo)::bar::baz into foo\tbaz
67: grep '::' |
68: sed 's/(\(.*\)).*::*.*::\(.*\)/\1\t\2/g' |
69: while read -r LINE
70: do
71: # Cut at the \t, trim whitespace and reverse the (qualified) name
72: RNAME=$(echo "$LINE" | cut -f 1 | trim | rev)
73: TYPE=$( echo "$LINE" | cut -f 2 | trim)
74:
75: # Chop the reversed name at the first dot, eg. 'eman.2doM.1doM' gives
76: # 'eman' and '2doM.1doM', then reverse to get 'name' and 'Mod1.Mod2'
77: NAME=$(echo "$RNAME" | cut -d '.' -f 1 | rev)
78: MODS=$(echo "$RNAME" | cut -d '.' -f 2- | rev)
79:
80: echo "{\"module\": \"$MODS\", \"name\": \"$NAME\", \"type\": \"$TYPE\"}"
81: done |
82: jq -s '.'
83: '';
84: };
85:
86: tagAstsScript = default: wrap {
87: name = "tagAsts";
88: paths = [ bash jq ];
89: vars = {
90: inherit default;
91: FALLBACK_ID = ''
92: {
93: "name" : $this.name,
94: "module" : $this.module,
95: "package" : $this.package
96: }
97: '';
98:
99: # Select $tags matching $this
100: QUERY = ''map(select((.module == $this.module) and
101: (.name == $this.name))) | .[0]'';
102:
103: # Combine matching $tags with $this
104: ACTION = ". + $this";
105: };
106: script = ''
107: #!${bash}/bin/bash
108:
109: # Given JSON objects on stdin, and a file descriptor containing JSON objects
110: # as $1, combines those elements of each with matching pkg/mod/name. If no
111: # match is found in $1, 'default' is used as a fallback
112:
113: function msg {
114: echo -e "$1" 1>&2
115: }
116:
117: [[ -n "$1" ]] || {
118: msg "tagAsts requires an argument for its tags"
119: msg "For example, 'echo FOO | tagAsts <(echo BAR)'"
120: exit 1
121: }
122:
123: TYPE=$(echo "$default" | jq -r 'type') || {
124: msg "Couldn't parse tagAsts default argument '$default' as JSON"
125: exit 3
126: }
127:
128: [[ "x$TYPE" = "xobject" ]] || {
129: msg "tagAsts default argument '$default' has type '$TYPE'"
130: msg "It should be an object"
131: exit 4
132: }
133:
134: export FALLBACK="($FALLBACK_ID + $default)"
135:
136: # Call the current AST $this, then loop over $tags
137: INPUT=".[] | . as \$this | \$tags + [$FALLBACK]"
138:
139: jq --argfile tags "$1" "[$INPUT | $QUERY | $ACTION]"
140: '';
141: };
142:
143: annotateAsts = mkBin {
144: name = "annotateAsts";
145: paths = [ getArities getTypes jq ];
146: vars = {
147: tagTypesScript = tagAstsScript ''{"type":null}'';
148: tagAritiesScript = tagAstsScript ''
149: {
150: "arity" : null,
151: "quickspecable" : false,
152: "hashable" : false
153: }
154: '';
155: };
156: script = ''
157: #!${bash}/bin/bash
158: set -e
159:
160: function msg {
161: echo -e "$1" 1>&2
162: }
163:
164: function tagTypes {
165: "$tagTypesScript" <(echo "$RAWSCOPE" | getTypes)
166: }
167:
168: function tagArities {
169: "$tagAritiesScript" <(echo "$RAWTYPES" | getArities)
170: }
171:
172: INPUT=$(cat)
173: if [[ -z "$IN_SELF_TEST" ]]
174: then
175: if [[ "$DEBUG" -eq 1 ]]
176: then
177: NAME=$(echo "$INPUT" | sha256sum | head -n1 | cut -d ' ' -f1)
178: msg "DEBUG detected, writing to '$NAME.annotateInput'"
179: echo "$INPUT" > "$NAME.annotateInput"
180: else
181: msg "This stage is tricky. Set DEBUG=1 to see the debug info."
182: fi
183: fi
184:
185: msg "Getting ASTs"; RAWASTS=$(echo "$INPUT" | jq -c '.asts' )
186: msg "Getting types"; RAWTYPES=$(echo "$INPUT" | jq -r '.result' )
187: msg "Getting scope"; RAWSCOPE=$(echo "$INPUT" | jq -r '.scoperesult')
188:
189: msg "Tagging"
190: echo "$RAWASTS" | tagTypes | tagArities
191:
192: msg "Tagged"
193: '';
194: };
195:
196: annotateDbScript = wrap {
197: name = "annotateDb";
198: paths = [ annotateAsts bash getDepsScript ];
199: script = ''
200: #!${bash}/bin/bash
201: set -e
202: set -o pipefail
203:
204: "$typesScript" | annotateAsts | getDepsScript
205: '';
206: };
207:
208: annotateScript = withDeps (concatLists (attrValues
209: (mapAttrs testsFor {
210: inherit (testData.haskellDrvs) test-theory;
211: })) ++ checkDlist)
212: annotateScript-untested;
213:
214: annotateScript-untested = mkBin {
215: name = "annotate";
216: paths = [ bash checkStderr fail ];
217: vars = { annotateDb = annotateDbScript; };
218: script = ''
219: #!${bash}/bin/bash
220: [[ -n "$typesScript" ]] || fail "No typesScript set"
221: "$annotateDb" 2> >(checkStderr)
222:
223: # Give checkStderr some time to process (hacky and racy)
224: CODE="$?"
225: sleep 1
226: exit "$CODE"
227: '';
228: };
229:
230: testsFor = attr: pkg:
231: with rec {
232: asts = annotatedWith annotateScript-untested {
233: pkgDir = unpack pkg.src;
234: extras = { IN_SELF_TEST = "1"; };
235: };
236: annotatedExists = runCommand "annotatedExists"
237: {
238: inherit asts;
239: buildInputs = [ fail ];
240: }
241: ''
242: set -e
243: [[ -e "$asts" ]] || fail "annotated '$asts' doesn't exist"
244: mkdir "$out"
245: '';
246:
247: haveAsts = runCommand "test-have-asts"
248: {
249: inherit asts;
250: buildInputs = [ fail jq ];
251: }
252: ''
253: set -e
254: jq -e 'length | . > 0' < "$asts" || fail "Empty ASTs"
255: mkdir "$out"
256: '';
257:
258: astsLabelled = runCommand "test-asts-are-labelled"
259: {
260: inherit asts;
261: buildInputs = [ fail jq ];
262: pkgName = pkgName pkg.name;
263: }
264: ''
265: set -e
266: jq -cr '.[] | .package' < "$asts" | while read -r LINE
267: do
268: [[ "x$LINE" = "x$pkgName" ]] || fail "Unlabelled: '$pkgName' '$LINE'"
269: done
270: mkdir "$out"
271: '';
272:
273: astsHaveField = map (f: runCommand "${attr}-asts-have-${f}"
274: {
275: inherit asts;
276: buildInputs = [ fail jq ];
277: }
278: ''
279: set -e
280: jq -e 'map(has("${f}")) | all' < "$asts" || fail "No '$f' field found"
281: mkdir "$out"
282: '')
283: [ "package" "module" "name" "ast" "type" "arity" "quickspecable"
284: "hashable" ];
285:
286: noCoreNames = runCommand "no-core-names"
287: {
288: inherit asts;
289: buildInputs = [ fail jq ];
290: }
291: ''
292: set -e
293: if jq -cr '.[] | .name' < "$asts" | grep -cF ".$"
294: then
295: fail "Found core names in '$asts'"
296: fi
297: mkdir "$out"
298: '';
299:
300: getTypes = runCommand "have-types-for-asts"
301: {
302: annotations = annotatedWith annotateScript-untested {
303: extras = { IN_SELF_TEST = "1"; };
304: pkgDir = toString (nixedHsPkg (toString runCommand "hsPkg"
305: {
306: buildInputs = tipBenchmarks.tools;
307: example = ../benchmarks/nat-simple.smt2;
308: }
309: ''
310: set -e
311: mkdir hsPkg
312: export OUT_DIR="$PWD/hsPkg"
313: full_haskell_package < "$example"
314: cp -r hsPkg "$out"
315: ''));
316: };
317: buildInputs = [ jq ];
318: }
319: ''
320: set -e
321: jq -e 'map(has("type") and .type != null) | any' < "$annotations"
322: mkdir "$out"
323: '';
324:
325: dependencyNameVersions = runCommand "dependency-name-versions"
326: {
327: inherit asts;
328: pName = pkg.name;
329: buildInputs = [ fail jq ]; }
330: ''
331: set -e
332: DEPS=$(jq -cr '.[] | .dependencies | .[] | .package' < "$asts" |
333: sort -u) ||
334: fail "Couldn't get packages of '$pName' dependencies" 1>&2
335:
336: if echo "$DEPS" | grep -- "-[0-9][0-9.]*$" > /dev/null
337: then
338: fail "Deps of '$pkgName' have versions in package IDs:\n$DEPS" 1>&2
339: fi
340: mkdir "$out"
341: '';
342:
343: haveDependencies = runCommand "haveDeps-${pkg.name}"
344: {
345: inherit asts;
346: buildInputs = [ jq ];
347: }
348: ''
349: set -e
350: jq -e 'map(has("dependencies")) | all' < "$asts" > "$out"
351: '';
352:
353: namesUnversioned = runCommand "names-unversioned-${attr}"
354: {
355: F = asts;
356: buildInputs = [ fail jq ];
357: pkgName = pkg.name;
358: }
359: ''
360: set -e
361:
362: function assertNoVersions {
363: if grep -- "-[0-9][0-9.]*$" > /dev/null
364: then
365: fail "Versions found in package names of $1$pkgName"
366: fi
367: }
368:
369: [[ -e "$F" ]] || fail "Couldn't find file '$F'"
370:
371: jq -rc '.[] | .package' < "$F" |
372: assertNoVersions ""
373:
374: jq -rc '.[] | .dependencies | .[] | .package' < "$F" |
375: assertNoVersions "dependencies of "
376:
377: mkdir "$out"
378: '';
379: };
380: astsHaveField ++ [
381: annotatedExists astsHaveField astsLabelled dependencyNameVersions getTypes
382: haveAsts haveDependencies namesUnversioned noCoreNames
383: ];
384:
385: # Regression tests for ef5280028f66a9e7
386: checkDlist =
387: with rec {
388: pkg = haskellPackages.dlist;
389: asts = annotatedWith annotateScript-untested {
390: pkgDir = unpack pkg.src;
391: extras = { IN_SELF_TEST = "1"; };
392: };
393: notHashable = runCommand "dlist-not-hashable"
394: {
395: inherit asts;
396: buildInputs = [ fail jq ];
397: }
398: ''
399: set -e
400: jq -e 'map(select(.name == "replicate")) | length |
401: . == 1 ' < "$asts" ||
402: fail "No 'replicate' found"
403: jq -e '.[] | select(.name == "replicate") | .hashable |
404: not ' < "$asts" ||
405: fail "'replicate' shouldn't be hashable (DLists are functions)"
406:
407: jq -e 'map(select(.name == "toList")) | length |
408: . == 1 ' < "$asts" ||
409: fail "No 'toList' found"
410: jq -e '.[] | select(.name == "toList") | .hashable' < "$asts" ||
411: fail "'toList' should be hashable ([Integer] can be serialised)"
412:
413: mkdir "$out"
414: '';
415: };
416: [ notHashable ];
417:
418: annotatedWith = annotateScript: { pkgDir, extras ? {} }:
419: with rec {
420: pkgSrc = nixedHsPkg pkgDir;
421: f = dumpToNix { pkgDir = pkgSrc; };
422: env = extractedEnv {
423: inherit f;
424: standalone = pkgSrc;
425: };
426: };
427: runCommand "annotate"
428: ({
429: inherit f;
430: __noChroot = true;
431: buildInputs = env ++ [ annotateScript ];
432: typesScript = runTypesScript { inherit pkgSrc; };
433: } // extras)
434: ''
435: set -e
436: annotate < "$f" > "$out"
437: '';
438: };
439:
440: rec {
441: annotated = annotatedWith annotateScript;
442:
443: annotateRawAstsFrom = mkBin {
444: name = "annotateRawAstsFrom";
445: paths = [ annotateScript bash ];
446: vars = { typesScript = runTypesScriptData.script; };
447: script = ''
448: #!${bash}/bin/bash
449: set -e
450: pkgSrc=$(readlink -f "$1")
451: export pkgSrc
452:
453: annotate
454: '';
455: };
456: }
Generated by git2html.