haskell-te: 724eab2fc1ff839f720928b1f57624d6e8ef258a
1: { bash, fail, haskellPackages, jq, lib, mkBin, nixEnv, withNix, wrap,
2: writeScript }:
3:
4: with builtins;
5: with lib;
6: with rec {
7: # Run GHCi with all relevant packages available. We need "--pure" to avoid
8: # multiple GHCs appearing in $PATH, since we may end up calling one with the
9: # wrong package database.
10: repl = mkBin {
11: name = "repl";
12: paths = (withNix {}).buildInputs ++ [ replLines ];
13: vars = nixEnv // {
14: cmd = "ghci -v0 -XTemplateHaskell";
15: pkg =
16: with {
17: hs = "with builtins; (haskellPackages.ghcWithPackages";
18: hsPkgs = "x.QuickCheck x.quickspec x.cereal x.murmur-hash";
19: };
20: ''
21: ${hs} (x: [ ${hsPkgs} (x.callPackage (getEnv "pkgSrc") {}) ])).override { ignoreCollisions = true; }
22: '';
23: };
24: script = ''
25: #!${bash}/bin/bash
26: set -e
27: set -o pipefail
28: nix-shell --show-trace --pure -p "$pkg" --run "$cmd" | replLines
29: '';
30: };
31:
32: # Makes sure that the modules we've been given can be imported.
33: checkMods = mkBin {
34: name = "checkMods";
35: paths = [ repl ];
36: script = ''
37: #!${bash}/bin/bash
38: set -e
39: set -o pipefail
40:
41: ALL_MODS=$(echo -e "$MODS\nData.Serialize\nData.Digest.Murmur32" |
42: sort -u)
43: IMPORTS=$(echo "$ALL_MODS" |
44: while read -r MOD
45: do
46: echo "import $MOD"
47: done |
48: repl 2>&1) || {
49: echo "$IMPORTS" 1>&2
50: echo "Unknown error while checking modules" 1>&2
51: exit 1
52: }
53:
54: if echo "$IMPORTS" | grep "Could not find module"
55: then
56: echo "$IMPORTS" 1>&2
57: exit 1
58: fi
59: exit 0
60: '';
61: };
62:
63: # Try to type-check QuickSpec signatures, to see which work
64: # TODO: Higher-kinded polymorphism, eg. Functors and Monads
65: mkQuery = mkBin {
66: name = "mkQuery";
67: vars = {
68: # Shorthand
69: QS = "Test.QuickSpec";
70:
71: # Make sure our parens stay balanced!
72: FUNCS = concatStringsSep " " [
73: "Data.Digest.Murmur32.asWord32"
74: "(Data.Digest.Murmur32.hash32"
75: "(Data.Serialize.runPut"
76: "(Data.Serialize.put"
77: ];
78: };
79: script = ''
80: #!${bash}/bin/bash
81: # The name of the value we're trying to send through QuickSpec
82: GIVEN="$1"
83:
84: # Use Template Haskell to monomorphise our value (tries to
85: # instantiate all type variables with "Integer")
86: MONO="Test.QuickCheck.All.monomorphic ('$1)"
87:
88: # We must use a layer of let/in for TH to work, so we call our
89: # monomorphic value "f"
90: BIND="let f = \$($MONO) in"
91:
92: # Get the monomorphised type
93: echo ":t $BIND f"
94:
95: # See if our monomorphised value can be added to a QuickSpec
96: # Sig(nature). This can be done in two ways:
97: #
98: # - Directly, using `fun0`, `fun1`, `fun2`, etc. depending on the
99: # arity. This requires the type (or result type, for functions)
100: # be an instance of `Ord`. Values of this type will be compared
101: # to discover equivalence classes; such values can build up on
102: # the heap, causing memory exhaustion.
103: # - Indirectly, by adding our value using one of the `blind0`,
104: # `blind1`, etc. functions (depending on arity) which don't
105: # compare (or store) their outputs. We then add a hash function
106: # to the signature using `observer1`; whenever our function
107: # generates an output (or any other value of that type is
108: # produced) they're hashed into an `Word32` for storage and
109: # comparison.
110: #
111: # We prefer the indirect method, to keep down memory usage.
112:
113: function tryCall() {
114: # Try to make a QuickSpec signature using the given parameters,
115: # writing JSON to stdout on success.
116: # - $1 is the function to call, an arbitrarily complex expression
117: # - $2 is the arity we'll report in our JSON
118: # - $3 is whether results are hashable (indirect) or not
119:
120: # Construct the JSON we'll send to stdout. This is double-escaped:
121: # - We need to use "" in the shell to splice in variables
122: # - We're generating Haskell code, which uses "" for strings
123: # - The Haskell string contains JSON, which uses "" for strings
124: # We include the given name, the given arity and whether it's
125: # hashable. We can assume it's quickspecable, since the message
126: # won't appear if it isn't.
127: QNAME="\\\"qname\\\": \\\"$GIVEN\\\""
128: FIELDS="$QNAME, \\\"quickspecable\\\": true"
129: JSON="\"{\\\"arity\\\": $NUM, \\\"hashable\\\":$3, $FIELDS}\""
130:
131: # We use the given function to add our term (monomorphised as `f`)
132: # to a QuickSpec signature; we use the above JSON as its name. We
133: # extract this name and print it out; if this works, then the term
134: # must be suitable for use in QuickSpec.
135:
136: EXPR="$QS.Term.name (Prelude.head ($QS.Signature.symbols ($1 ($JSON) f)))"
137:
138: # Print out the JSON, so we can spot it when we parse the results
139: echo "$BIND Prelude.putStrLn ($EXPR)"
140: }
141:
142: # Try `blind` functions first; the higher the arity the better,
143: # since outputting curried functions will likely prevent comparison.
144: for NUM in 5 4 3 2 1 0
145: do
146: # We try calling our value as a function with $NUM arguments, then
147: # send the result through cereal and murmur-hash.
148: CALL="f"
149: for ARG in $(seq 1 "$NUM")
150: do
151: CALL="$CALL Prelude.undefined"
152: done
153: CALL="($FUNCS ($CALL)))))"
154:
155: # We don't need the result of the hash call, so we put it in an
156: # unused let/in variable; the result we want is a call to `blind`
157: tryCall "let g = $CALL in $QS.blind$NUM" "$NUM" true
158: done
159:
160: # If we can't hash, try adding directly (requires output be `Ord`)
161: for NUM in 5 4 3 2 1 0
162: do
163: # Try constructing a signature using `fun5`, `fun4`, etc. until
164: # we either get a success, or run out (not QuickSpecable).
165: tryCall "$QS.fun$NUM" "$NUM" false
166: done
167: '';
168: };
169:
170: # Writes GHCi commands to stdout, which we use to test the types of terms
171: typeCommand = mkBin {
172: name = "typeCommand";
173: paths = [ jq mkQuery ];
174: script = ''
175: echo ":m"
176:
177: # Used for hashing values, to reduce memory usage.
178: echo "import qualified Data.Serialize"
179: echo "import qualified Data.Digest.Murmur32"
180:
181: while read -r MOD
182: do
183: echo "import qualified $MOD"
184: done < <(echo "$MODS")
185:
186: grep "^{" | while read -r LINE
187: do
188: MOD=$(echo "$LINE" | jq -r '.module')
189: echo "import qualified $MOD"
190: QNAME=$(echo "$LINE" | jq -r '.module + "." + .name')
191: mkQuery "$QNAME"
192: done
193: '';
194: };
195:
196: # Makes sure the types we've been given are actually available in scope (ie.
197: # they're not off in some hidden package)
198: typeScopes = mkBin {
199: name = "typeScopes";
200: script = ''
201: echo ":m"
202:
203: while read -r MOD
204: do
205: echo "import qualified $MOD"
206: done < <(echo "$MODS")
207:
208: grep "in f[ ]*::" |
209: while IFS= read -r LINE
210: do
211: NAME=$(echo "$LINE" | sed -e "s/^.*('\(.*\)))[ ]*in f[ ]*::.*$/\1/g")
212: TYPE=$(echo "$LINE" | sed -e "s/^.*::[ ]*\(.*\)$/\1/g")
213: echo ":t ($NAME) :: ($TYPE)"
214: done
215: '';
216: };
217:
218: # Recombines any lines which GHCi split up
219: replLines = mkBin {
220: name = "replLines";
221: script = ''
222: #!${bash}/bin/bash
223: while IFS= read -r LINE
224: do
225: if echo "$LINE" | grep '^ ' > /dev/null
226: then
227: printf " %s" "$LINE"
228: else
229: printf "\n%s" "$LINE"
230: fi
231: done
232: '';
233: };
234: };
235:
236: # Runs GHCi to get type information
237: rec {
238: script = wrap {
239: name = "runTypesScript-raw";
240: paths = [ bash checkMods fail jq repl typeCommand typeScopes ];
241: vars = {
242: JQ_COMMAND = concatStrings [
243: "{"
244: (concatStringsSep ", "
245: (map (x: x + ": $" + x)
246: [ "asts" "cmd" "result" "scopecmd" "scoperesult" ]))
247: "}"
248: ];
249: };
250: script = ''
251: #!${bash}/bin/bash
252: set -e
253: set -o pipefail
254:
255: ERR=$(mktemp "/tmp/haskell-te-runTypesScript-XXXXX.stderr")
256:
257: function finish {
258: cat "$ERR" 1>&2
259: rm -f "$ERR"
260: }
261: trap finish EXIT
262:
263: ASTS=$(cat)
264:
265: MODS=$(echo "$ASTS" | jq -r '.[] | .module')
266: export MODS
267:
268: echo "Checking module availability" 1>&2
269: if checkMods
270: then
271: echo "Found modules" 1>&2
272: else
273: fail "Couldn't find modules, aborting"
274: fi
275:
276: echo "Building type-extraction command" 1>&2
277: CMD=$(echo "$ASTS" | jq -c '.[]' | typeCommand) 2> "$ERR" ||
278: fail "Error building type extraction command"
279:
280: echo "Extracting types" 1>&2
281: RESULT=$(echo "$CMD" | repl 2>> "$ERR") ||
282: fail "Error extracting types"
283:
284: echo "Building scope-checking command" 1>&2
285: SCOPECMD=$(echo "$RESULT" | typeScopes)
286:
287: echo "Checking scope" 1>&2
288: SCOPERESULT=$(echo "$SCOPECMD" | repl)
289:
290: echo "Outputting JSON" 1>&2
291: # shellcheck disable=SC2016
292: jq -n --argfile asts <(echo "$ASTS") \
293: --argfile cmd <(echo "$CMD" | jq -s -R '.') \
294: --argfile result <(echo "$RESULT" | jq -s -R '.') \
295: --argfile scopecmd <(echo "$SCOPECMD" | jq -s -R '.') \
296: --argfile scoperesult <(echo "$SCOPERESULT" | jq -s -R '.') \
297: "$JQ_COMMAND"
298: echo "Finished output" 1>&2
299:
300: if [[ -z "$IN_SELF_TEST" ]]
301: then
302: if [[ "$DEBUG" -eq 1 ]]
303: then
304: {
305: echo 'DEBUG detected, showing stderr output'
306: echo 'NOTE: This comes from trial-and-error in GHCi, so we expect'
307: echo "many error messages. They can aid debugging, but if you aren't"
308: echo 'experiencing a problem then they can be safely ignored.'
309: cat "$ERR"
310: } 1>&2
311: else
312: echo "Set DEBUG=1 if you want to see gory GHCi output." 1>&2
313: fi
314: fi
315: echo "" > "$ERR"
316: '';
317: };
318:
319: runTypesScript = { pkgSrc }: wrap {
320: name = "runTypesScript";
321: file = script;
322: vars = { inherit pkgSrc; };
323: };
324: }
Generated by git2html.